



		    command_processor_.pl1          11/11/89  1103.4rew 11/11/89  0803.5     1118898



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

/* format: off */

/* The Multics Command Processor */

/* Created:  1 May 1976 by Steve Herbst */
/* Modified and reorganized by Jay Goldman, '77 */
/* Reorganized and fixed bugs: February-March 1978 by Gary Palter */
/* Modified: June 1978 by G. Palter to fix several bugs and implement new definition of |[, ||[, |], and |; */
/* Modified: 5-6 August 1978 by G. Palter to make command_processor_$af work properly */
/* Modified: 13 August 1978 by G. Palter to not forget about temporary segments */
/* Modified: 11 September 1978 by G. Palter to remove definition of |; */
/* Modified: 31 October 1978 by G. Palter to call fc_no_message when invoked as cp_$af */
/* Modified: 29 November 1978 by G. Palter to implement newer definition of |[ */
/* Modified: 23 June 1979 by G. Palter to make null iteration sets within brackets not be considered an error
      but instead return no value */
/* Modified: 13 July 1979 by G. Palter to fix a bug wherein an &if clause in an exec_com with unbalanced brackets
      causes a fault in match_iters */
/* Modified: 16 August 1979 by G. Palter to not bother to zero the automatic node block before returning */
/* Modified: 14 March 1980 by G. Palter to add faster simple command processing */
/* Modified: 31 March 1980 by G. Palter to add new directly callable interfaces and the subsystem entries */
/* Modified: 5 May 1980 by G. Palter to change calling sequence of eval_string entries and add include file for active
      string types */
/* Modified: 7 May 1980 by G. Palter to change calling sequence of subsys* entries to include a subsys_cp_info_ptr; this
      pointer is presently unused, however */
/* Modified: 3 October 1980 by G. Palter to fix bug #0016 -- the command processor takes an out_of_bounds fault when
      passed a zero-length input line (TR07834) */
/* Modified: 1 December 1980 by G. Palter to fix bug #0017 -- the command processor may cause the PL/1 free_based
      operator to take a random fault when processing a null command line */
/* Modified: May-June 1982 by G. Palter to (1) make simple_command_processor a quick block, (2) create the
      complex_command_processor internal procedure to hold all automatic storage not shared by the simple and complex
      command processor cases, (3) add support for tailoring the request line language within subsystems (eg: disabling
      iteration), (4) delete command_processor_$af (finally!), and (5) fix several bugs relating to temporary segment
      management and treatment of semicolons in active function/request return values (command_processor 5, 21, 22) */
/* Modified: March 1984 by Keith Loepere for non-existant error_table_$bad_subr_call */
/* Modified: July 1984 by G. Palter to use multiple permanent scratch segments in order to improve the performance of
      recursive invocations of the evaluate_active_string entrypoints such as those made by the LINUS Report Writer */


/****^  HISTORY COMMENTS:
  1) change(86-05-17,GDixon), approve(86-05-17,MCR7357),
     audit(86-06-16,Farley), install(86-07-17,MR12.0-1097):
     Change call to tct_ to reference find_char_$first_in_table instead. This
     subroutine has been renamed.
  2) change(86-05-17,DGHowe), approve(86-05-15,MCR7375),
     audit(86-07-15,Schroth), install(86-08-01,MR12.0-1108):
     added the ability to save the command name given on the command line to
     simple_command_processor and produce_argument_list.
  3) change(87-07-13,GWMay), approve(87-07-13,MCR7730), audit(87-08-10,JRGray),
     install(87-09-10,MR12.1-1104):
     Added the ability to pipe data between commands and files.
  4) change(87-09-10,GWMay), approve(87-09-10,MCR7730), audit(87-09-10,GDixon),
     install(87-09-10,MR12.1-1104):
     Changed position within the code where the pipe structure is suspended
     and restored.  Fixed several problems found by the security auditor.
  5) change(87-09-10,GWMay), approve(87-09-10,PBF7730), audit(87-09-14,GDixon),
     install(87-09-15,MR12.1-1107):
     Remove extra call to copy_thru_pipe from the process_pipe_command routine.
     Matching attaches are handled in the process_attach_description code.
  6) change(87-12-15,GWMay), approve(87-12-15,MCR7810), audit(87-12-15,GDixon),
     install(88-01-12,MR12.2-1011):
     Changed call main error return call to com_err_ to only output a newline
     when there is error text.
  7) change(88-02-03,GWMay), approve(88-02-25,MCR7848),
     audit(88-02-26,Fawcett), install(88-03-01,MR12.2-1029):
     Changed pipe facility to allow $ in the name of a command.
                                                   END HISTORY COMMENTS */
%page;
/*  LIMITATIONS AN KNOWN BUGS:  */

/*  1)  Nested iteration sets will not return the expected results.

        example:

        string (xxx_(a b) (c d)_yyy zzz)

        intermixes the inner interation set.

    2)  The pipe processing code cannot deal with pipes that are
        embedded as part of an active return string.

        examples:

        string "show;|cols";| xx
        ls;| [contents xx;|]

        string [[ioa_ "string (ab a bc cd ae ef);|match /a/";|]]

        Because the pipe code evaluates the command line as it is input,
        the value returned by the active string will not be diagnosed
        correctly as a pipe.
*/        
%page;
/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */

command_processor_:
     procedure (P_line_ptr, P_line_len, P_code);


/* Parameters */

dcl  P_line_ptr pointer parameter;			/* command_processor_: -> line to process (input) */
dcl  P_line_len fixed binary (21) parameter;		/* command_processor_: length of line to process (input) */

dcl  P_line character (*) parameter;			/* *execute_line, *eval_string: line to process (input) */

dcl  P_return_value character (*) varying parameter;	/* *eval_string: result of evaluation (output) */

dcl  P_eval_string_options_ptr pointer parameter;		/* eval_string: -> options controlling interpretation of the
						   active string (unused at present) (input) */

dcl  P_active_string_type fixed binary parameter;		/* *eval_string: type of active string (input) */

dcl  P_cp_subsys_info_ptr pointer parameter;		/* subsys_*, validate_cp_subsys_info: -> options controlling
						   interpretation of the request line (input) */

dcl  P_subsystem_name character (*) parameter;		/* subsys_*: the subsystem (input) */
dcl  P_subsystem_info_ptr pointer parameter;		/* subsys_*: -> data used by the subsystem (input) */
dcl  P_execute_request entry (pointer, character (*), pointer, fixed binary (35)) variable parameter;
						/* subsys_*: procedure to lookup & execute request (input) */

dcl  P_old_execute_request entry (character (*), pointer, fixed binary (35)) variable parameter;
						/* execute_command_line_: same as above (input) */

dcl  P_code fixed binary (35) parameter;		/* *: status code (output) */


/* Local copies of parameters */

dcl  line character (line_len) unaligned based (line_ptr);
dcl  line_ptr pointer;
dcl  line_len fixed binary (21);

dcl  execute_request entry (pointer, character (*), pointer, fixed binary (35)) variable;
dcl  old_execute_request entry (character (*), pointer, fixed binary (35)) variable;

dcl  code fixed binary (35);
dcl  ignore_code fixed bin (35);			/* this value is for speed, never check it */

/* Remaining declarations */

dcl  multics_cp bit (1) aligned;			/* ON => Multics entry;  OFF => subsystem entry */
dcl  evaluate_string bit (1) aligned;			/* ON => called to evaluate an active string */
dcl  new_subsystem_call bit (1) aligned;		/* ON => new form of execute_request, etc */

dcl  null_cl bit (1) aligned;				/* ON => command line is only whitspace */

dcl  complex_line bit (1) aligned;			/* ON => command line contains quoting, iteration, active
						   strings, or commands with more than 32 arguments */

dcl  lss_on bit (1) aligned;				/* ON => running Limited Service System */

dcl  use_standard_language bit (1) aligned;		/* ON => can use PL/I builtins for search */

dcl  executing bit (1) aligned;			/* ON => executing a command at the moment */
dcl  abort_command_execution label variable;

dcl  top_level_string_type fixed binary;		/* for evaluating active strings: [], |[], ||[] */

dcl  start fixed binary (21);

dcl  error_message char (256) varying;

dcl  COMMAND_PROCESSOR_ character (32) static options (constant) initial ("command_processor_");
dcl  EXECUTE_COMMAND_LINE_ character (32) static options (constant) initial ("execute_command_line_");

dcl  MAX_STACK_EXTENSION fixed binary (21) static options (constant) initial (16384);
						/* do not extend stack more than 16 pages */
dcl  MIN_AF_RETURN_LTH fixed binary (21) static options (constant) initial (32768);
						/* always give active function at least 32K chars */

/* format: off */
dcl (error_table_$bad_file_name,
    error_table_$bad_pipe_syntax,
    error_table_$bad_subr_arg,
    error_table_$command_line_overflow,
    error_table_$mismatched_iter,
    error_table_$null_brackets,
    error_table_$no_file,
    error_table_$noentry,
    error_table_$unbalanced_brackets,
    error_table_$unbalanced_parentheses,
    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  absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl  check_star_name_ entry (char (*), bit (36), fixed bin (2), fixed bin (35));
dcl  com_err_ entry () options (variable);
dcl  cu_$gen_call entry (pointer, pointer);
dcl  cu_$grow_stack_frame entry (fixed binary (21), pointer, fixed binary (35));
dcl  find_char_$first_in_table entry (char (*), char (512) aligned) returns (fixed bin (21)) reducible;
dcl  find_command_ entry (pointer, fixed binary, pointer, fixed binary (35));
dcl  find_command_$fc_no_message entry (pointer, fixed binary, pointer, fixed binary (35));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  get_wdir_ entry () returns (char (168));
dcl  hcs_$get_uid_file entry (char (*), char (*), bit (36) aligned, fixed bin (35));
dcl  pipe_$terminate entry (ptr, ptr, fixed bin (35));
dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
dcl  release_temp_segments_ entry (character (*), (*) pointer, fixed binary (35));
dcl  sub_err_ entry () options (variable);
dcl  transform_command_ entry (pointer, fixed binary, pointer, fixed binary (35));

dcl  (cleanup, command_abort_, request_abort_) condition;

dcl  (addr, addcharno, addrel, after, before, bit, currentsize, dimension, divide, fixed, hbound, index, lbound, length,
     ltrim, low, max, maxlength, min, mod, null, rank, rtrim, search, stacq, substr, unspec, verify) builtin;
%page;
/* Various combinations of those characters special to command language: many almost blank listing pages follow ... */

dcl  BREAKS character (12) static options (constant) initial (";()[]""|
	 ");						/* command language break characters and NL, HT, SP, VT, FF */

dcl  TOKEN_BREAKS character (6) static options (constant) initial ("""
	 ");						/* breaks for tokens only: " NL HT SP VT FF */

dcl  SIMPLE_BREAKS character (6) static options (constant) initial (";
	 ");						/* ; and whitespace (NL HT SP VT FF) */

dcl  NON_SIMPLE_BREAKS character (6) static options (constant) initial ("()[]""|");
						/* characters requiring special processing */

dcl  PIPE_BREAK character (2) static options (constant) initial (";|");

dcl  LEFT_BRACKET character (1) static options (constant) initial ("[");

dcl  RIGHT_BRACKET character (1) static options (constant) initial ("]");

dcl  VERTICAL_BAR character (1) static options (constant) initial ("|");

dcl  COMMAND_BREAKS character (2) static options (constant) initial (";
");						/* characters which separate command invocations (;, NL) */
dcl  SPACE character (1) internal static options (constant) init (" ");
%page;
/* Execute a Multics command line:  this entry is intended to be called only via cu_$cp */

/* command_processor_: entry (P_line_ptr, P_line_len, P_code); */

	multics_cp = "1"b;				/* not a subsystem invocation */
	new_subsystem_call = "0"b;
	evaluate_string = "0"b;
	line_ptr = P_line_ptr;
	line_len = P_line_len;
	go to CONTINUE_SETUP;


/* Evaluate a Multics active string */

eval_string:
     entry (P_eval_string_options_ptr, P_line, P_active_string_type, P_return_value, P_code);

	multics_cp = "1"b;				/* not a subsystem */
	new_subsystem_call = "0"b;
	evaluate_string = "1"b;
	top_level_string_type = max (P_active_string_type, NORMAL_ACTIVE_STRING);
	top_level_string_type = min (top_level_string_type, ATOMIC_ACTIVE_STRING);
						/* defaults to [] */
	go to SETUP;


/* Execute a subsystem request line:  the caller must supply a procedure which is used to find and execute each request */

subsys_execute_line:
     entry (P_subsystem_name, P_subsystem_info_ptr, P_execute_request, P_cp_subsys_info_ptr, P_line, P_code);

	multics_cp = "0"b;				/* this is a subsystem */
	new_subsystem_call = "1"b;
	evaluate_string = "0"b;
	lss_on = "0"b;
	go to SETUP;


/* Execute a subsystem request line:  this is an obsolete entry provided for compatibility */

execute_command_line_:
     entry (P_line, P_old_execute_request, P_code);

	multics_cp = "0"b;
	new_subsystem_call = "0"b;			/* use old fashioned calling sequence */
	evaluate_string = "0"b;
	lss_on = "0"b;
	go to SETUP;


/* Evaluate a subsystem active string */

subsys_eval_string:
     entry (P_subsystem_name, P_subsystem_info_ptr, P_execute_request, P_cp_subsys_info_ptr, P_line, P_active_string_type,
	P_return_value, P_code);

	multics_cp = "0"b;
	new_subsystem_call = "1"b;
	evaluate_string = "1"b;
	lss_on = "0"b;
	top_level_string_type = max (P_active_string_type, NORMAL_ACTIVE_STRING);
	top_level_string_type = min (top_level_string_type, ATOMIC_ACTIVE_STRING);
	go to SETUP;
%page;
/* Execute/evaluate the command/request line/active-string:  for simplicity, all future references will assume that a
   Multics command line is being executed */

SETUP:
	line_ptr = addr (P_line);			/* this point is reached by all but command_processor_ */
	line_len = length (P_line);

CONTINUE_SETUP:					/* command_processor_ joins here */
	error_message = "";
	code = 0;

	use_standard_language = "1"b;			/* until proven otherwise: assume normal case */

	if ^multics_cp then				/* subsystem entries: check for special request language */
	     if new_subsystem_call then
		if P_cp_subsys_info_ptr ^= null () then do;
		     cp_subsys_info_ptr = P_cp_subsys_info_ptr;
		     if cp_subsys_info.version ^= CP_SUBSYS_INFO_VERSION_1 then do;
RESIGNAL_INCOMPATIBLE_SUBSYSTEM_INFO:			/* wrong version is quite fatal */
			call sub_err_ (error_table_$unimplemented_version, COMMAND_PROCESSOR_, ACTION_CANT_RESTART,
			     null (), (0), "^24.3b from subsystem ^a.", unspec (cp_subsys_info.version),
			     P_subsystem_name);
			go to RESIGNAL_INCOMPATIBLE_SUBSYSTEM_INFO;
		     end;
		     use_standard_language = ^cp_subsys_info.non_standard_language;
		end;

	if evaluate_string then P_return_value = "";	/* initialize the return value */

	if use_standard_language then do;		/* can perform some short cuts for the normal language */
	     line_len = length (rtrim (line, SIMPLE_BREAKS));
	     start = verify (line, SIMPLE_BREAKS);	/* ... strip leading/trailing whitespace/null commands */
	     null_cl = (start = 0);
	     if null_cl then do;			/* ... the line is empty */
		complex_line = "0"b;
		go to SILENTLY_RETURN_FROM_CP;
	     end;
	end;
	else do;					/* have no idea what the whitespace characters are ... */
	     start = 1;				/* ... must scan the entire line */
	     null_cl = "1"b;			/* ... until proven otherwise by complex_command_processor */
	end;

	if multics_cp then
	     lss_on = cp_data_$under_lss;		/* running under Limited Service System */
	else do;					/* a subsystem entry: get the appropriate apply procedure */
	     if new_subsystem_call then
		execute_request = P_execute_request;
	     else old_execute_request = P_old_execute_request;
	end;

	if evaluate_string then			/* evaluating an active string: always a complex operation */
	     complex_line = "1"b;
	else if use_standard_language then		/* standard language: try faster command processor if OK */
						/* The pipe token ";|" does not need to be checked here  */
						/* because "|" is a non-simple break which will set the  */
						/* complex line switch on.			       */
	     complex_line = (search (substr (line, start), NON_SIMPLE_BREAKS) ^= 0);
	else complex_line = "1"b;			/* no idea what the language is like */

	if ^complex_line then do;			/* first try faster command processor ... */
	     executing = "0"b;			/* ... execution is not in progress */
	     abort_command_execution = SILENTLY_RETURN_FROM_CP;
	     if multics_cp then			/* ... establish appropriate abort handler once */
		on condition (command_abort_)
		     begin;
		     if executing then go to abort_command_execution;
		end;
	     else on condition (request_abort_)
		     begin;
		     if executing then go to abort_command_execution;
		end;
	     call simple_command_processor (line_ptr, line_len, start, complex_line);
	     if multics_cp then
		revert condition (command_abort_);
	     else revert condition (request_abort_);
	end;

	if complex_line then call complex_command_processor (line_ptr, line_len, start);

RETURN_FROM_CP:
	if (code ^= 0) & ^evaluate_string then
	     if multics_cp then call com_err_ (code, COMMAND_PROCESSOR_,
"^[^/^]^a", error_message ^= "", error_message);
	     else if new_subsystem_call then call com_err_ (code, P_subsystem_name, "^/^a", error_message);
	     else call com_err_ (code, EXECUTE_COMMAND_LINE_, "^/^a", error_message);

SILENTLY_RETURN_FROM_CP:
	if (code = 0) & null_cl then code = 100;

	P_code = code;

	return;
%page;
/* Simple command processor:  processes command lines which do not contain quoted strings, iteration, or active strings.
   Argument lists are constructed and commands invoked until either the entire command line is processed or a command
   invocation if found with more than 32 arguments in which case the full command processor must be used */

simple_command_processor:
     procedure (p_line_ptr, p_line_lth, p_start, p_complex_line) /* options (quick) */;


/* Parameters */

dcl  p_line_ptr pointer parameter;			/* -> command line to execute */
dcl  p_line_lth fixed binary (21) parameter;		/* length of above command line */
dcl  p_start fixed binary (21) parameter;		/* where to start in the command line */
dcl  p_complex_line bit (1) aligned parameter;		/* set ON => something in this command line was too much to
						   handle -- the normal processor must be used */


/* Local copies of parameters */

dcl  line character (line_lth) unaligned based (line_ptr);	/* command line being processed */
dcl  (line_lth, start) fixed binary (21);
dcl  line_ptr pointer;


/* Remaining declarations */

dcl  1 arg_list aligned,				/* the argument list being constructed */
       2 twice_n_arguments fixed binary (18) unaligned unsigned,
       2 tag bit (18) unaligned initial ("000004"b3),	/* PL/1 */
       2 twice_n_descriptors fixed binary (18) unaligned unsigned,
       2 has_command_name bit (1) unal,
       2 pad bit (17) unal,
       2 arg_ptrs (32) pointer,
       2 descriptor_ptrs (32) pointer,
       2 name,
         3 command_name_ptr pointer,
         3 command_name_length fixed bin (21);

dcl  1 descriptors (32) aligned,			/* descriptions of above arguments */
       2 bits bit (12) unaligned,			/* flag(1), type(6), packed(1), ndims(4) */
       2 size fixed binary (24) unaligned unsigned;

dcl  descriptor_ptrs_for_move bit (72 * n_arguments) aligned based;
						/* to move descriptor pointers to proper place in arglist */
dcl  command_name_for_move bit (144) aligned based;
dcl  arg_list_overlay (68) bit (72) based (addr (arg_list.arg_ptrs (1)));
dcl  saved_start fixed binary (21);			/* where each command start in case it aborts */

dcl  reading_command_name bit (1) aligned;		/* ON => picking up command name, not an argument */
dcl  end_of_command bit (1) aligned;			/* ON => reached the end of a command */

dcl  n_arguments fixed binary;			/* # of arguments for this command */

dcl  (token_lth, next_start) fixed binary (21);

dcl  command_name character (command_name_lth) unaligned based (command_name_ptr);
dcl  command_name_ptr pointer;			/* -> name of the command to invoke */
dcl  command_name_lth fixed binary;
dcl  command_entry_ptr pointer;			/* -> the actual command to be run */
%page;
	line_ptr = p_line_ptr;
	line_lth = p_line_lth;
	start = p_start;

	abort_command_execution = ABORT_COMMAND_EXECUTION;/* bypass PL/I's lexical scoping rules */

	do while (start <= line_lth);

	     saved_start = start;			/* save start of command in case not simple */

	     reading_command_name = "1"b;
	     end_of_command = "0"b;
	     n_arguments = 0;

	     do while (^end_of_command);

		token_lth = search (substr (line, start), SIMPLE_BREAKS) - 1;

		if token_lth = -1 then		/* rest of the command line */
		     token_lth = line_lth - start + 1;	/* break is one beyond the end */

		if reading_command_name then do;
		     command_name_ptr = addr (substr (line, start, 1));
		     command_name_lth = token_lth;
		     reading_command_name = "0"b;
		end;
		else do;
		     n_arguments = n_arguments + 1;
		     if n_arguments > hbound (arg_list.arg_ptrs, 1) then do;
			p_start = saved_start;	/* command has too many arguments: use full processor */
			p_complex_line = "1"b;
			return;
		     end;
		     arg_list.arg_ptrs (n_arguments) = addr (substr (line, start, 1));
		     arg_list.descriptor_ptrs (n_arguments) = addr (descriptors (n_arguments));
		     descriptors (n_arguments).bits = "5260"b3;
						/* unaligned, nonvarying string */
		     descriptors (n_arguments).size = token_lth;
		end;

		start = start + token_lth;		/* skip over token to delimiters */

		if (start > line_lth) then
		     end_of_command = "1"b;		/* entire line used */

		else do;				/* search for next token and check for end of a command
						   invocation (semicolon or newline in delimiters) */
		     next_start = verify (substr (line, start), SIMPLE_BREAKS);
		     if (next_start = 0) then do;	/* rest of line is delimiters */
			next_start = line_lth - start + 2;
			end_of_command = "1"b;
		     end;
		     else end_of_command = (search (substr (line, start, (next_start - 1)), COMMAND_BREAKS) ^= 0);
		     start = start + next_start - 1;
		end;
	     end;

	     arg_list.twice_n_arguments, arg_list.twice_n_descriptors = 2 * n_arguments;

/* save the name on the current argument list NOTE this is  a new structure */

	     arg_list.has_command_name = "1"b;
	     arg_list.name.command_name_length = command_name_lth;
	     arg_list.name.command_name_ptr = command_name_ptr;


	     if n_arguments < hbound (arg_list.arg_ptrs, 1) then do;
						/* need to move descriptor pointers down */
		addr (arg_list.arg_ptrs (n_arguments + 1)) -> descriptor_ptrs_for_move =
		     addr (arg_list.descriptor_ptrs) -> descriptor_ptrs_for_move;
		addr (arg_list_overlay (2 * n_arguments + 1)) -> command_name_for_move =
		     addr (arg_list.name) -> command_name_for_move;
	     end;


	     if multics_cp then do;			/* executing a Multics command line */
		if lss_on then do;			/* running within Limited Service System */
		     call transform_command_ (command_name_ptr, command_name_lth, cp_data_$command_table_ptr, code);
		     if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		end;
		call find_command_ (command_name_ptr, command_name_lth, command_entry_ptr, code);
		if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		executing = "1"b;			/* handle command_abort_ now */
		call cu_$gen_call (command_entry_ptr, addr (arg_list));
	     end;

	     else if new_subsystem_call		/* new type of subsystem request line */
	     then do;
		executing = "1"b;			/* handler request_abort_ now */
		call execute_request (P_subsystem_info_ptr, command_name, addr (arg_list), code);
		if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
	     end;

	     else do;				/* executing an old-fashioned subsystem request line */
		executing = "1"b;			/* handler request_abort_ now */
		call old_execute_request (command_name, addr (arg_list), code);
		if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
	     end;

ABORT_COMMAND_EXECUTION:
	     executing = "0"b;
	end;

	return;

     end simple_command_processor;
%page;
/* Complex command processor: processes command lines which contain quoted strings, iteration, or active strings.  In
   order to solve several bugs in the command processor, this procedure will have to be rewritten */

complex_command_processor:
     procedure (p_line_ptr, p_line_len, p_start) options (non_quick);


/* Parameters */

dcl  p_line_ptr pointer parameter;			/* -> the command line/active string */
dcl  p_line_len fixed binary (21) parameter;		/* length of the line */
dcl  p_start fixed binary (21) parameter;		/* where in the line to start procesing */


/* Local copies of paramerters */

dcl  (line_len, start) fixed binary (21);
dcl  line_ptr pointer;


/* Nodes */

dcl  1 atom aligned based,
       2 next pointer unaligned,			/* forward thread */
       2 pad1 pointer unaligned,
       2 string_ptr pointer unaligned,			/* pointer into command line */
       2 type fixed binary,
       2 pad2 fixed binary,
       2 string_len fixed binary (21),			/* length of substring */
       2 flags aligned,
         3 space bit (1);                                   /* followed by white space */

dcl  1 iter_begin aligned based,
       2 next pointer unaligned,			/* forward thread */
       2 end pointer unaligned,			/* forward thread to matching ) */
       2 parent pointer unaligned,			/* pointer to parent iter or af node */
       2 type fixed binary,
       2 delimiter_class fixed binary,			/* which of 8 possible end iteration set breaks to match */
       2 pad fixed binary (21),
       2 flags aligned,
         3 space bit (1);				/* this value is ignored */

dcl  1 iter_end aligned based,
       2 next pointer unaligned,			/* forward thread */
       2 begin pointer unaligned,			/* backward thread to matching ( */
       2 parent pointer unaligned,			/* pointer to parent iter or af node */
       2 type fixed binary,
       2 pad fixed binary,
       2 level fixed binary (21),			/* number of iter sets not ended */
       2 flags aligned,
         3 space bit (1);				/* if iteration set is followed by white space */

dcl  1 af aligned based,
       2 next pointer unaligned,			/* forward thread */
       2 prev pointer unaligned,			/* backward thread */
       2 parent pointer unaligned,			/* pointer to parent iter or af node */
       2 type fixed binary,
       2 delimiter_class fixed binary,			/* which of 8 possible end active string breaks to match */
       2 level fixed binary (21),			/* iter level at start of af */
       2 flags aligned,
         3 space bit (1),				/* this value is ignored */
         3 atom_sw bit (1),				/* result is to be a single atom */
         3 tokens_sw bit (1),				/* result is to be broken into tokens only */
         3 catenate_sw bit (1);			/* catenate results of iterations */

dcl  1 node aligned based,
       2 next pointer unaligned,			/* forward thread */
       2 af_prev pointer unaligned,			/* backward thread */
       2 af_iter_parent pointer unaligned,		/* pointer to parent iter or af node */
       2 type fixed binary,
       2 delimiter_class fixed binary,			/* which of 8 possible end iteration/active string breaks */
       2 len_or_level fixed binary (21),		/* length of character string for atom nodes, or
						   iter level at start of af or after iter_end */
       2 flags aligned,
         3 space bit (1),				/* followed by white space */
         3 af_atom_sw bit (1),			/* result is a single atom */
         3 af_tokens_sw bit (1),			/* result is to be broken into tokens only */
         3 af_catenate_sw bit (1);			/* catenate results of iterations */

/* format: off */
dcl (ATOM			initial (1),		/* a piece of text which will form part of an argument */
     BEGIN_ITERATION	initial (2),		/* start of an iteration set */
     END_ITERATION		initial (3),		/* end of one or more iteration sets */
     ACTIVE_STRING		initial (4),		/* an active string */
     END_OF_COMMAND		initial (5))		/* a command delimter returned by an active function */
	fixed binary static options (constant);
/* format: on */


/* Data used for scratch segment management:  The command processor maintains two lists of scratch segments -- the
   "permanent" scratch segments are obtained only once per-process and are shared amongst various invocations of the
   command processor through the use of a simple locking scheme.  (In actuality, the permanent segments will be released
   every cp_data_$scratch_release_factor uses to help keep process directory usage low).  The other list of scratch
   segments is a per-invocation list of temporary segments which are allocated and then released once per top-level
   command/request (ie: once per semicolon) */

dcl  scratch_lock_id bit (36) aligned;			/* unique identifier for acquiring "permanent" segments */

dcl  1 temporary_scratch_segment_list aligned based (temporary_scratch_segment_list_ptr),
       2 header,
         3 n_allocated fixed binary,			/* # of available temporary scratch segments */
         3 n_used fixed binary,			/* # actually in use at present */
       2 segment_ptrs (temporary_scratch_segment_list_n_allocated refer (temporary_scratch_segment_list.n_allocated))
	  pointer;

dcl  1 local_temporary_scratch_segment_list aligned,	/* initial set of temporary scratch segments */
       2 header like temporary_scratch_segment_list.header,
       2 segment_ptrs (8) pointer;

dcl  temporary_scratch_segment_list_ptr pointer;
dcl  temporary_scratch_segment_list_n_allocated fixed binary;


/* Remaining declarations */

dcl  1 dummy_node aligned like node;
dcl  1 dummy_af_node aligned like af;			/* top level active string for evaluate entries */

dcl  1 node_block aligned based (block_ptr),		/* block of thirty nodes */
       2 array (30) like node,			/* four words each */
       2 next pointer;				/* forward thread */
dcl  block_ptr pointer;
dcl  last_block_ptr pointer;				/* for chaining blocks */

dcl  node_index fixed binary (5);			/* index of free node in a block */

dcl  1 stack_space like node_block aligned;		/* space in stack for first block of nodes */

dcl  system_area area based (system_area_ptr);		/* area to allocate later blocks if needed */
dcl  system_area_ptr pointer;

dcl  atom_string character (atom_len) based (atom_ptr);
dcl  atom_len fixed binary (21);
dcl  atom_ptr pointer;

dcl  return_string character (return_len) aligned varying based (return_ptr);
dcl  return_ptr pointer;				/* -> AF return string */
dcl  return_len fixed binary (21);

dcl  1 full_language like cp_data_$standard_language aligned based (full_language_ptr);
dcl  full_language_ptr pointer;			/* defines the full language being interpreted */

dcl  1 token_language like cp_data_$standard_language aligned based (token_language_ptr);
dcl  token_language_ptr pointer;			/* defines the language with non-whitespace, non-quoting
						   special characters treated normally */

dcl  using_stack bit (1) aligned;			/* ON => arguments are being constructed on the stack */

dcl  last_np pointer;
dcl  (first_node, new_first_node) pointer;		/* node pointers for match_iters & read_list */
dcl  arg_count fixed binary;				/* number of arguments to command/af, set by match_iters */
dcl  (count, iter_count, iter_index) fixed binary;	/* number of iterations, set by match_iters */

/* format: off */
dcl (command		 initial ("0"b),		/* executing a command */
     active_function	 initial ("1"b))		/* evaluating an active function */
	bit (1) aligned static options (constant);
/* format: on */

dcl  make_list_depth fixed binary;			/* recursion depth of make_list procedure */
dcl  iter_level fixed binary;				/* depth of ()'s in line */
						/* for use by the pipe facility only */
dcl  command_pipe_control_ptr ptr;
dcl  1 command_pipe_control aligned based (command_pipe_control_ptr),
       2 Npipes_in_line fixed bin,			/* occurances of ;| in a line */
       2 Niters fixed bin,				/* iteration level		*/
       2 niters fixed bin,				/* iteration count		*/
       2 Sevaluate_pipe bit (1) aligned,		/* on = processing an active function */
       2 Sbuild_return_string bit (1) aligned,		/* on = build the af return str */
       2 Sinclude_NL_in_af_ret_str bit (1) aligned,	/* on = do not remove NLs from the ret str */
       2 Sterminate bit (1) aligned,			/* on = delete pipe files and free storage */
       2 pipe_input_path char (58),			/* built by pipe_$initiate */
       2 pipe_output_path char (58),			/* built by pipe_$initiate */
       2 previous_pipe_ptr ptr,			/* data before the ;| */
       2 previous_pipe_len fixed bin,
       2 current_pipe_ptr ptr,			/* current command line */
       2 current_pipe_len fixed bin,
       2 next_pipe_ptr ptr,				/* data after the next ;| */
       2 next_pipe_len fixed bin,
       2 input_ptr ptr,				/* input attachment */
       2 output_ptr ptr;				/* output attachment */
%page;
	command_pipe_control_ptr = null;
	line_ptr = p_line_ptr;
	line_len = p_line_len;
	start = p_start;

	system_area_ptr = get_system_free_area_ ();

	block_ptr = addr (stack_space);		/* initialize node allocation variables */
	unspec (node_block) = "0"b;
	node_block.next = null ();
	node_index = 0;

	call initialize_scratch_segments ("1"b);	/* setup scratch segment management */

	on condition (cleanup)
	     begin;				/* non-local goto in progress ... */
	     if command_pipe_control_ptr ^= null then do;
		call pipe_$terminate (addr (command_pipe_control.pipe_input_path),
		     addr (command_pipe_control.pipe_output_path), ignore_code);

		free command_pipe_control in (system_area);
		command_pipe_control_ptr = null;
	     end;

	     call free_nodes ("1"b);			/* ... don't zero automatic storage */
	     call release_scratch_segments ("1"b);	/* ... or setup scratch segments for another pass */
	end;

	if use_standard_language then			/* pick up character type from constant definition */
	     full_language_ptr, token_language_ptr = addr (cp_data_$standard_language);
	else do;					/* strange language: caller has supplied the definitions */
	     full_language_ptr = addr (cp_subsys_info.full_tct_table);
	     token_language_ptr = addr (cp_subsys_info.tokens_only_tct_table);
	end;
%page;
/* Process the line one command at a time -- a command invocation is delimited by non-quoted semicolons and newlines.
   Evaluating an active string in the command line may return semicolons -- this case is handled by make_list and
   match_iters */

	do while (start > 0);

	     iter_level = 0;			/* no unclosed iteration sets */
	     iter_count = 0;
	     iter_index = 0;
	     make_list_depth = 0;

	     return_ptr = null ();			/* no place for return values yet */
	     using_stack = "1"b;			/* read_list will use additional stack space if necessary */

	     unspec (dummy_node) = "0"b;
	     last_np = addr (dummy_node);
	     dummy_node.next = null ();
	     dummy_node.type = ATOM;

	     if evaluate_string then do;		/* evaluating active string: make dummy AF node */
		unspec (dummy_af_node) = "0"b;
		last_np = addr (dummy_af_node);
		dummy_af_node.type = ACTIVE_STRING;
		dummy_af_node.prev = addr (dummy_node); /* make sure result is seen */
		dummy_af_node.parent = null ();
		if (top_level_string_type = TOKENS_ONLY_ACTIVE_STRING) then dummy_af_node.tokens_sw = "1"b;
						/* caller requested |[] */
		else if (top_level_string_type = ATOMIC_ACTIVE_STRING) then dummy_af_node.atom_sw = "1"b;
						/* caller requested ||[] */
	     end;

	     call make_list (line_ptr, line_len, ("0"b), start, command_pipe_control_ptr);
						/* parse line up to first explicit semicolon */

	     do first_node = dummy_node.next		/* process this command */
		repeat (new_first_node)		/* and any within it from AF's */
		while (first_node ^= null ());
		call match_iters (first_node, evaluate_string, arg_count, iter_count, new_first_node);
		do iter_index = 1 to iter_count;	/* process parentheses */
		     if command_pipe_control_ptr ^= null then do;
			command_pipe_control.Niters = iter_count;
			command_pipe_control.niters = iter_index;
		     end;

		     if ^evaluate_string then
			call read_list (first_node, evaluate_string, arg_count, command_pipe_control_ptr);
		     else do;			/* cp_$af: get list as a string */
			call write_list (first_node, evaluate_string, arg_count, command_pipe_control_ptr);
			if (iter_index < iter_count) | (new_first_node ^= null ()) then
			     P_return_value = P_return_value || ";";
		     end;				/* if not last element of list */
		end;
	     end;

	     call free_nodes ((start = 0));		/* forget command but zero automatic only if more to do */
	     call release_scratch_segments ((start = 0));

	     if command_pipe_control_ptr ^= null then
		if command_pipe_control.Sterminate then do;
		     call pipe_$terminate (addr (command_pipe_control.pipe_input_path),
			addr (command_pipe_control.pipe_output_path), ignore_code);

		     free command_pipe_control in (system_area);
		     command_pipe_control_ptr = null;
		end;

	end;

	return;
%page;
/* Construct the token list:  Evaluates active strings and properly threads parentheses for use by match_iters and
   read_list */

make_list:
	procedure (p_line_ptr, p_line_len, p_token_breaks_sw, p_start, p_pipe_control_ptr);

dcl  p_line_ptr pointer parameter;
dcl  (p_line_len, p_start) fixed binary (21) parameter;
dcl  p_token_breaks_sw bit (1) aligned parameter;		/* controls if ()[}; recognized */
dcl  p_pipe_control_ptr ptr;

dcl  line_ptr pointer;				/* parameter copies */
dcl  (line_len, start, pipe_line_pos) fixed binary (21);
dcl  token_breaks_sw bit (1) aligned;

dcl  line character (line_len) based (line_ptr);
dcl  c (line_len) character (1) unaligned based (line_ptr);

dcl  af_is_atom bit (1) aligned;			/* ON => return value is not to be rescanned */
dcl  af_is_tokens bit (1) aligned;			/* ON => return value should be tokenized only */
dcl  catenate_values bit (1) aligned;			/* ON => iteration in active string catenates */
dcl  semicolon_in_af bit (1) aligned;			/* ON => command separator within an active string */

dcl  (pp, np, top_level_pp) pointer;
dcl  processing_type fixed binary (9);

dcl  (afp, first_node, new_first_node, af_line_ptr) pointer;
dcl  (the_character, next_character, next_next_character) character (1);
dcl  continue_scan bit (1) aligned;
dcl  (arg_count, iter_count, iter_index) fixed binary;
dcl  (af_line_len, af_start, idx) fixed binary (21);

dcl  sv_pipe_control_ptr ptr;
dcl  1 pipe_control aligned like command_pipe_control based (p_pipe_control_ptr);
dcl  current_pipe aligned char (pipe_control.current_pipe_len) based (pipe_control.current_pipe_ptr);
dcl  next_pipe aligned char (pipe_control.next_pipe_len) based (pipe_control.next_pipe_ptr);
dcl  after_bracket_idx fixed bin (21);

	     make_list_depth = make_list_depth + 1;
	     line_ptr = p_line_ptr;
	     line_len = p_line_len;
	     token_breaks_sw = p_token_breaks_sw;
	     start = p_start;
	     sv_pipe_control_ptr = null;

	     if (make_list_depth = 1) & evaluate_string then do;
		top_level_pp, pp = addr (dummy_af_node);/* need a psuedo "[" for string evaluation */
		semicolon_in_af = "0"b;		/* ... and be sure not to confuse it */
		afp = null ();
	     end;
	     else pp = null ();
%page;
/* Main scanning loop */

/* pipe line position offset equals the starting char less 1. */

	     pipe_line_pos = start - 1;

	     do while (start <= line_len);

		if token_breaks_sw then		/* ignore iteration, active strings, and multiple commands */
		     if use_standard_language then
			atom_len = search (substr (line, start), TOKEN_BREAKS) - 1;
		     else atom_len =
			     find_char_$first_in_table (substr (line, start), cp_subsys_info.tokens_only_tct_table)
			     - 1;
		else do;				/* allow all features defined in this language */
		     if use_standard_language then	/* ... default situation: all features are enabled */
			atom_len = search (substr (line, start), BREAKS) - 1;
		     else atom_len =
			     find_char_$first_in_table (substr (line, start), cp_subsys_info.full_tct_table) - 1;
		end;

		if atom_len = -1 then do;		/* rest of line is ordinary characters ... */
		     atom_len = line_len - start + 1;
		     call get_node ();		/* ... so create an ATOM node to represent it */
		     np -> atom.type = ATOM;
		     np -> atom.string_ptr = addr (c (start));
		     np -> atom.string_len = atom_len;
		     start = line_len + 1;		/* ... and force the scanning loop to terminate */
		end;

		else do;				/* have found a character with special meaning ... */
		     if atom_len > 0 then do;		/* ... some ordinary characters in front of it ... */
			call get_node ();		/* ... ... so create a node to hold onto them */
			np -> atom.type = ATOM;
			np -> atom.string_ptr = addr (c (start));
			np -> atom.string_len = atom_len;
			start = start + atom_len;	/* ... and position to the interesting character */
		     end;

		     af_is_atom = "0"b;		/* turn off any active string modifiers */
		     af_is_tokens = "0"b;
		     catenate_values = "0"b;
		     processing_type = get_type (c (start));
		     go to PROCESS_CHARACTER (processing_type);


/* Determine the processing type of the given character */

get_type:
     procedure (p_character) returns (fixed binary);

dcl  p_character character (1) unaligned parameter;

	if token_breaks_sw then
	     return (token_language.character_types (rank (p_character)));
	else return (full_language.character_types (rank (p_character)));

     end get_type;
%page;
/* Whitespace: separates tokens on the line but is otherwise ignored (space, horizontal/vertical tab, form feed, newline
   when scanning just for tokens */

PROCESS_WHITESPACE:
PROCESS_CHARACTER (1):
		     last_np -> node.space = "1"b;	/* separate this token from what (if anything) follows */
		     go to CONTINUE_SCAN;


/* Command separator: separates multiple commands on the line but is        */
/* otherwise ignored (semicolon) */

PROCESS_COMMAND_SEPARATOR:
PROCESS_CHARACTER (2):

/* The pipe facility is activated when the string ";|" exists within a command
   line.  Pipes are not available in limited service subsystems or subsystems
   that do not use the standard command language. */
	
                         if ^use_standard_language | lss_on then go to PROCESS_SEMICOLON;
		     if substr (line, start, length (PIPE_BREAK)) = PIPE_BREAK then do;
			if p_pipe_control_ptr = null then do;
						/* init values here to save on performance. */
			     allocate pipe_control in (system_area) set (p_pipe_control_ptr);
			     pipe_control.Npipes_in_line = 0;
			     pipe_control.Sterminate = "0"b;
			     pipe_control.Sevaluate_pipe = "0"b;
			     pipe_control.Sbuild_return_string = "0"b;
			     pipe_control.Sinclude_NL_in_af_ret_str = "0"b;
			     pipe_control.pipe_input_path = "";
			     pipe_control.pipe_output_path = "";
			     pipe_control.previous_pipe_ptr = null;
			     pipe_control.previous_pipe_len = 0;
			     pipe_control.current_pipe_ptr = null;
			     pipe_control.current_pipe_len = 0;
			     pipe_control.next_pipe_ptr = null;
			     pipe_control.next_pipe_len = 0;
			     pipe_control.input_ptr = null;
			     pipe_control.output_ptr = null;
			end;

			pipe_control.Npipes_in_line = pipe_control.Npipes_in_line + 1;

/* Construct pointers to the previous and current section of the command line
   delimited by pipe tokens and line extents. */

			pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr;
			pipe_control.previous_pipe_len = pipe_control.current_pipe_len;
			pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos);
			pipe_control.current_pipe_len = start - pipe_line_pos - length (";");
			start = start + length (PIPE_BREAK);

			if pp ^= null () then
			     if pp -> node.type = ACTIVE_STRING then do;

/* Position the section pointer after the left bracket so that the pipe
   processor can figure out the type of thing being done.                   */

				after_bracket_idx = search (current_pipe, LEFT_BRACKET);
				pipe_control.current_pipe_ptr =
				     addcharno (pipe_control.current_pipe_ptr, after_bracket_idx);
				pipe_control.current_pipe_len = pipe_control.current_pipe_len - after_bracket_idx;

/* Look for the next character. It will be a vertical bar or a right        */
/* bracket.  If it isn't, an error will be reported when the end of the     */
/* active function is processed in PROCESS_END_ACTIVE_FUNCTION below.	      */

				pipe_control.Sevaluate_pipe = "1"b;
				if substr (line, start, length (VERTICAL_BAR)) = VERTICAL_BAR then do;
				     pipe_control.Sinclude_NL_in_af_ret_str = "1"b;
				     start = start + length (VERTICAL_BAR);
				end;
			     end;


/* Construct pointers to the next section of the command line delimited by
   pipe tokens and line extents.  The value of next_pipe may or may not be
   the entire contents of the next command or attach description
   processed.  The value will be the entire contents when there are no
   special characters within it.  It is not required for the string to be
   complete. Using this strategy, the value will contain the first special
   character.  The value is checked a by subroutine of process_pipe below.
   Whenever a the string contains special characters, a temporary pipe
   file will be used for output.  When the string does not contain special
   characters and is a valid attach description, then and only then, it is
   used as the output of the pipe. */

			pipe_control.next_pipe_len = search (substr (line, start), COMMAND_BREAKS);

			if pipe_control.next_pipe_len > 0 then do;
			     pipe_control.next_pipe_ptr = addcharno (line_ptr, start - 1);
			     pipe_control.next_pipe_len = pipe_control.next_pipe_len - 1;
			end;
			else do;
			     pipe_control.next_pipe_ptr = addcharno (line_ptr, start - 1);
			     if line_len >= start then
				pipe_control.next_pipe_len = line_len - (start - 1);
			     else pipe_control.next_pipe_len = 0;
			end;

/* If the pipe is to run as an active function, determine if this is the
   last section of the active string. If so, setup for the active function
   return string to be built.  If there is an include new line token in the
   middle of the pipe, report an error.  Otherwise, call the active function
   processor. */

			if pipe_control.Sevaluate_pipe then do;
			     if substr (ltrim (next_pipe), 1, length (RIGHT_BRACKET)) = RIGHT_BRACKET then
				pipe_control.Sbuild_return_string = "1"b;
			     else do;
				if pipe_control.Sinclude_NL_in_af_ret_str then do;
				     code = error_table_$bad_pipe_syntax;
				     error_message =
					"The string "";||"" may only appear at the end of pipe active strings.";
				     go to RETURN_FROM_CP;
				end;
			     end;

			     start = start - 1;	/* make_list adds 1 */
			     pipe_line_pos = start;
			     semicolon_in_af = "1"b;
			     call process_active_function (p_pipe_control_ptr);
			end;
		     end;

/* A regular semicolon was found.  If the pipe facility is "on", turn it off */

		     else do;
			if p_pipe_control_ptr ^= null then do;
			     pipe_control.Sterminate = "1"b;
			     pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr;
			     pipe_control.previous_pipe_len = pipe_control.current_pipe_len;
			     pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos);
			     pipe_control.current_pipe_len = start - pipe_line_pos - 1;
			     pipe_control.next_pipe_ptr = null;
			     pipe_control.next_pipe_len = 0;
			end;
PROCESS_SEMICOLON:
			start = start + 1;		/* next command follows the ; */
			if (start > 0) & (pp ^= null ()) then
			     if pp -> node.type = ACTIVE_STRING then do;

/* Because the return string from a pipe is built at the end of the bracket
   pair, it is not possible to process active functions after pipe active
   functions.  If this were done, the return string would not be builr in the
   same sequence as the command line issued them.  If this is done, report
   an error message. */

				if p_pipe_control_ptr ^= null then
				     if pipe_control.Sevaluate_pipe then do;
					code = error_table_$bad_pipe_syntax;
					error_message =
					     "Nonpipe semicolons cannot appear after pipe breaks in pipe active strings."
					     ;
					go to RETURN_FROM_CP;
				     end;

				start = start - 1;	/* ... make_list will add 1 */
				pipe_line_pos = start;
				semicolon_in_af = "1"b;
				call process_active_function (p_pipe_control_ptr);
			     end;			/* ... above procedure doesn't return (sigh) */
		     end;

		     go to RETURN_FROM_MAKE_LIST;


/* Command separator or whitespace: separates multiple commands on the line when using the full language but is also
   recognized when scanning active function return values for tokens as being equivalent to whitespace (new-line) */

PROCESS_CHARACTER (3):
		     if token_breaks_sw then
			go to PROCESS_WHITESPACE;	/* nice and easy ... */
		     else go to PROCESS_COMMAND_SEPARATOR;
%page;
/* Single character token: appears as a one character argument to the command even if not surrounded by whitespace */

PROCESS_CHARACTER (4):
		     last_np -> node.space = "1"b;	/* forced separation */

		     call get_node ();		/* create an atom node for this character */
		     np -> atom.type = ATOM;
		     np -> atom.string_ptr = addr (c (start));
		     np -> atom.string_len = 1;
		     np -> atom.space = "1"b;		/* ... and separate it from whatever follows */
		     go to CONTINUE_SCAN;


/* Compound token: appears as an argument to the command even if not surrounded by whitespace; if several of this type of
   character appear on the line without any intervening characters, they are merged into a single argument (eg: ^=) */

PROCESS_CHARACTER (5):
		     last_np -> node.space = "1"b;	/* forced separation */

		     call get_node ();		/* create an atom for this and following compounded chars */
		     np -> atom.type = ATOM;
		     np -> atom.string_ptr = addr (c (start));
		     np -> atom.string_len = 0;
		     np -> atom.space = "1"b;		/* ... and separate them from whatever follows */

		     do while (start <= line_len);	/* scan until we hit end of compound token characters */
			processing_type = get_type (c (start));
			if processing_type = COMPOUND_TOKEN then
			     np -> atom.string_len = np -> atom.string_len + 1;
			else do;			/* found a non-compound character */
			     start = start - 1;	/* ... CONTINUE_SCAN label bumps this value */
			     go to CONTINUE_SCAN;
			end;
			start = start + 1;		/* move right along */
		     end;

		     go to RETURN_FROM_MAKE_LIST;	/* here iff rest of line was compound tokens */
%page;
/* Quote character -- begins and ends a quoted string: only the same character ends the quoted string (ie: "' isn't a
   completed string if both are quoting characters); within the string, any occurence of this character must be doubled */

PROCESS_CHARACTER (6):
		     the_character = c (start);	/* this is the only character that will stop us */

		     continue_scan = "1"b;		/* until we find the closing quote character */
		     do while (continue_scan);
			idx = index (substr (line, (start + 1)), the_character);
			if idx = 0 then do;		/* unbalanced quoting characters ... */
			     code = error_table_$unbalanced_quotes;
			     go to RETURN_FROM_CP;
			end;
			call get_node ();		/* make an atom for next piece of quoted string */
			np -> atom.type = ATOM;
			np -> atom.string_ptr = addr (c (start + 1));
			np -> atom.string_len = idx - 1;
			start = start + idx;	/* skip to next quoting character */
			if start < line_len then	/* check for literal quoted character within the string */
			     if substr (line, (start + 1), 1) = the_character then do;
				np -> atom.string_len = np -> atom.string_len + 1;
				start = start + 1;	/* ... yes: add one to the string and keep scanning */
			     end;
			     else continue_scan = "0"b;
			else continue_scan = "0"b;	/* ... no: have completed the string */
		     end;

		     go to CONTINUE_SCAN;		/* here iff we have a completed quoted string */


/* Active string modifier: modifies the interpretation of active strings; otherwise, treat as normal character (|) */

PROCESS_CHARACTER (7):
		     the_character = c (start);	/* pick up the modifier */

		     if start < line_len then		/* and the following character (if present) */
			next_character = substr (line, (start + 1), 1);
		     else next_character = low (1);

		     if start < (line_len - 1) then	/* and the character after that ... */
			next_next_character = substr (line, (start + 2), 1);
		     else next_next_character = low (1);

		     if (start < (line_len - 1)) & (next_character = the_character)
			& (get_type (next_next_character) >= BEGIN_ACTIVE_STRING_1)
			& (get_type (next_next_character) <= BEGIN_ACTIVE_STRING_8) then do;
			af_is_atom = "1"b;		/* ||[ -- do not scan active string result */
			start = start + 2;
			processing_type = get_type (next_next_character);
			go to PROCESS_BEGIN_ACTIVE_STRING;
		     end;

		     else if (start < line_len) & (get_type (next_character) >= BEGIN_ACTIVE_STRING_1)
			& (get_type (next_character) <= BEGIN_ACTIVE_STRING_8) then do;
			af_is_tokens = "1"b;	/* |[ -- rescan only for whitespace and quoted strings */
			start = start + 1;
			processing_type = get_type (next_character);
			go to PROCESS_BEGIN_ACTIVE_STRING;
		     end;

		     else if (start < line_len) & (get_type (next_character) >= END_ACTIVE_STRING_1)
			& (get_type (next_character) <= END_ACTIVE_STRING_8) then do;
			catenate_values = "1"b;	/* |] -- catenate iterated results */
			start = start + 1;
			processing_type = get_type (next_character);
			go to PROCESS_END_ACTIVE_STRING;
		     end;

		     else do;			/* nothing special about this occurence ... */
			call get_node ();		/* ... create a node to hold onto the character */
			np -> atom.type = ATOM;
			np -> atom.string_ptr = addr (c (start));
			np -> atom.string_len = 1;
			go to CONTINUE_SCAN;
		     end;
%page;
/* Begin an iteration set: there may be up to eight different groups of iteration set delimiters (left parenthesis) */

/* format: off */
PROCESS_CHARACTER (17):  PROCESS_CHARACTER (18):  PROCESS_CHARACTER (19):  PROCESS_CHARACTER (20):
PROCESS_CHARACTER (21):  PROCESS_CHARACTER (22):  PROCESS_CHARACTER (23):  PROCESS_CHARACTER (24): ;
						/* format: on */
		     call get_node ();		/* add an iteration node */
		     np -> iter_begin.type = BEGIN_ITERATION;
		     np -> iter_begin.parent = pp;
		     np -> iter_begin.delimiter_class = processing_type;

		     pp = np;			/* push parent */
		     iter_level = iter_level + 1;

		     go to CONTINUE_SCAN;


/* End an iteration set (right parenthesis) */

/* format: off */
PROCESS_CHARACTER (25):  PROCESS_CHARACTER (26):  PROCESS_CHARACTER (27):  PROCESS_CHARACTER (28):
PROCESS_CHARACTER (29):  PROCESS_CHARACTER (30):  PROCESS_CHARACTER (31):  PROCESS_CHARACTER (32): ;
						/* format: on */
		     if pp = null () then do;		/* no matching begin iteration set delimiter */
			code = error_table_$unbalanced_parentheses;
			go to RETURN_FROM_CP;
		     end;

		     else if pp -> node.type ^= BEGIN_ITERATION then do;
			code = error_table_$unbalanced_brackets;
			go to RETURN_FROM_CP;	/*  [) situation */
		     end;

		     else if pp -> iter_begin.delimiter_class ^= (processing_type - 8) then do;
			code = error_table_$unbalanced_parentheses;
			go to RETURN_FROM_CP;	/* previous begin iteration is of the wrong class */
		     end;

		     if last_np -> node.type = END_ITERATION then
			last_np -> node.space = "0"b; /* multiple end iterations: ignore intervening whitespace */

		     else do;			/* first end iteration so far */
			if last_np -> node.type = ATOM then last_np -> node.space = "1"b;
			call get_node ();		/* ... create an end iteration node */
			np -> node.type = END_ITERATION;
			np -> iter_end.begin = pp;
		     end;

		     iter_level = iter_level - 1;	/* one less unclosed iteration set */
		     last_np -> iter_end.level = iter_level;
		     last_np -> iter_end.parent = pp;
		     pp -> iter_begin.end = last_np;	/* let begin iteration node know where we are */
		     pp = pp -> iter_begin.parent;	/* pop parent */

		     go to CONTINUE_SCAN;
%page;
/* Begin an active string: there may be up to eight different groups of active string delimiters (left bracket) */

/* format: off */
PROCESS_BEGIN_ACTIVE_STRING:
PROCESS_CHARACTER (33):  PROCESS_CHARACTER (34):  PROCESS_CHARACTER (35):  PROCESS_CHARACTER (36):
PROCESS_CHARACTER (37):  PROCESS_CHARACTER (38):  PROCESS_CHARACTER (39):  PROCESS_CHARACTER (40): ;
						/* format: on */
		     call get_node ();		/* add an active string node */
		     np -> af.type = ACTIVE_STRING;
		     np -> af.parent = pp;
		     np -> af.delimiter_class = processing_type;

		     np -> af.atom_sw = af_is_atom;	/* record options known so far */
		     np -> af.tokens_sw = af_is_tokens;
		     np -> af.catenate_sw = "0"b;

		     if evaluate_string & (afp = top_level_pp) then top_level_pp = np;
						/* new top level of evaluate_active_string */
		     pp = np;			/* push parent */

		     np -> af.level = iter_level;	/* save iteration level */
		     iter_level = 0;		/* iteration sets in an active string are independent */

/* This case label is entered when a left bracket is found and after a
   semicolon or pipe token pair is found within an active string.  The value
   must be checked.  If this is a new active function and if there is a pipe
   active for the current level, the processing of the string as a pipe must
   be suspended.  Once done, this new active string can be evaluated on its
   own.  Processing of the new active function is ended and the previous
   pipe is restored when the right bracket is found. */

		     if p_pipe_control_ptr ^= null then
			if substr (line, start, length (LEFT_BRACKET)) = LEFT_BRACKET then do;
			     sv_pipe_control_ptr = p_pipe_control_ptr;

			     on condition (cleanup)
				begin;

			          if p_pipe_control_ptr ^= null then do;
				     call pipe_$terminate (addr (pipe_control.pipe_input_path),
					addr (pipe_control.pipe_output_path), ignore_code);
				     free pipe_control in (system_area);
				end;

/* Put back the command level pipe info if there is any */
				p_pipe_control_ptr = sv_pipe_control_ptr;
				sv_pipe_control_ptr = null;
			     end;
			     p_pipe_control_ptr = null;
			end;

		     go to CONTINUE_SCAN;


/* End an active string (right bracket) */

/* format: off */
PROCESS_END_ACTIVE_STRING:
PROCESS_CHARACTER (41):  PROCESS_CHARACTER (42):  PROCESS_CHARACTER (43):  PROCESS_CHARACTER (44):
PROCESS_CHARACTER (45):  PROCESS_CHARACTER (46):  PROCESS_CHARACTER (47):  PROCESS_CHARACTER (48): ;
						/* format: on */
		     if pp = null () then do;		/* no begin active string */
			code = error_table_$unbalanced_brackets;
			go to RETURN_FROM_CP;
		     end;

		     else if (make_list_depth = 1) & evaluate_string & (pp = top_level_pp) then do;
			code = error_table_$unbalanced_brackets;
			go to RETURN_FROM_CP;	/* evaluate_active_string: caller should've stripped this */
		     end;

		     else if pp -> node.type ^= ACTIVE_STRING then do;
			code = error_table_$unbalanced_parentheses;
			go to RETURN_FROM_CP;	/* (] situation */
		     end;

		     else if pp -> af.delimiter_class ^= (processing_type - 8) then do;
			code = error_table_$unbalanced_brackets;
			go to RETURN_FROM_CP;	/* previous begin active string is of the wrong class */
		     end;

		     if p_pipe_control_ptr ^= null then do;

/* If the pipe facility is in use as an active function, check for proper
   termination of the string. Then, terminate the pipe facility for this
   active string. */

			if return_ptr = null | ^pipe_control.Sbuild_return_string then do;
			     if current_pipe = "" then do;
				code = error_table_$null_brackets;
				go to RETURN_FROM_CP;
			     end;
			     else do;
				code = error_table_$bad_pipe_syntax;
				error_message = "Pipe active strings must end with "";|]"" or "";||]""";
				go to RETURN_FROM_CP;
			     end;
			end;

			call pipe_$terminate (addr (pipe_control.pipe_input_path),
			     addr (pipe_control.pipe_output_path), ignore_code);
			free pipe_control in (system_area);
			p_pipe_control_ptr = sv_pipe_control_ptr;
			sv_pipe_control_ptr = null;
			if p_pipe_control_ptr ^= null then revert cleanup;
		     end;

		     else if return_ptr = null then
			if pp -> af.next = null () then do;
			     code = error_table_$null_brackets;
			     go to RETURN_FROM_CP;
			end;

		     if p_pipe_control_ptr = null then do;
		        p_pipe_control_ptr = sv_pipe_control_ptr;
		        sv_pipe_control_ptr = null;
		        end;

		     semicolon_in_af = "0"b;

		     call process_active_function (p_pipe_control_ptr);

/* doesn't return */
%page;
CONTINUE_SCAN:					/* finished processing of special character ... */
		     start = start + 1;		/* ... so move on to the rest of the line (if any) */

		end;
	     end;


/* End of line */
	     if p_pipe_control_ptr ^= null then do;
		pipe_control.Sterminate = "1"b;
		pipe_control.previous_pipe_ptr = pipe_control.current_pipe_ptr;
		pipe_control.previous_pipe_len = pipe_control.current_pipe_len;
		pipe_control.current_pipe_ptr = addcharno (line_ptr, pipe_line_pos);
		pipe_control.current_pipe_len = start - pipe_line_pos - 1;
		pipe_control.next_pipe_ptr = null;
		pipe_control.next_pipe_len = 0;
	     end;

	     start = 0;				/* remember no more commands left on this line */

RETURN_FROM_MAKE_LIST:
	     if pp ^= null () then do;		/* possibly unbalanced line */
		if (make_list_depth = 1) & evaluate_string & (pp = top_level_pp) then
		     call process_active_function (p_pipe_control_ptr);
						/* end of evaluate_active_string: do it */
		if pp -> node.type = BEGIN_ITERATION then
		     code = error_table_$unbalanced_parentheses;
		else code = error_table_$unbalanced_brackets;
		go to RETURN_FROM_CP;
	     end;

	     p_start = start;			/* set result */

	     make_list_depth = make_list_depth - 1;
	     return;
%page;
/* Evaluates part of an active string:  Processes a single active function's portion of the active string.  The active
   function may be invoked several times as parentheses may have been used in this portion of the active string */

process_active_function:
	     procedure (pipe_control_ptr);

dcl  pipe_control_ptr ptr;
dcl  1 pipe_control aligned like command_pipe_control based (pipe_control_ptr);

dcl  nonvarying_return_string character (length (return_string)) unaligned based (addrel (addr (return_string), 1));


		last_np -> node.space = "1"b;		/* finish last argument to the active function */
		afp = pp;				/* save pointer to beginning of active function sublist */
		pp = afp -> af.parent;		/* pop parent */
		last_np = afp -> af.prev;		/* unthread from list */
		last_np -> node.next = null ();

		afp -> af.catenate_sw = catenate_values;/* ON if |] */


		do first_node = afp -> node.next	/* process the active function */
		     repeat (new_first_node)		/* ... and any returned command delimiters */
		     while (first_node ^= null ());

		     call match_iters (first_node, active_function, arg_count, iter_count, new_first_node);

/* pipes as active functions do not use the last argument as the return string
   so arg_count is reduced by 1. */

		     if pipe_control_ptr ^= null then
			if pipe_control.Sevaluate_pipe then
			     if arg_count > 0 then arg_count = arg_count - 1;

		     do iter_index = 1 to iter_count;
			if pipe_control_ptr = null then
			     call read_list (first_node, active_function, arg_count, null);
			else if pipe_control.Sevaluate_pipe then do;
						/* calling a pipe. set the call up as a command */
			     pipe_control.Niters = iter_count;
			     pipe_control.niters = iter_index;
			     call read_list (first_node, command, arg_count, pipe_control_ptr);
			end;
			else			/* regular af mixed with pipe af */
			     call read_list (first_node, active_function, arg_count, null);
			if return_ptr ^= null then
			     if ((length (return_string) = 0) & ^afp -> af.atom_sw)
				| (return_string = "" & p_pipe_control_ptr ^= null) then
				;		/* ignore null return value unless ||[ */

			     else do;		/* may have to process return value */
				if ^afp -> af.atom_sw & ^afp -> af.tokens_sw then
				     if use_standard_language then
					if search (return_string, BREAKS) ^= 0 then
					     call evaluate_af_result ();
					else call treat_af_result_as_atom ();
				     else if
					find_char_$first_in_table (nonvarying_return_string,
					cp_subsys_info.full_tct_table) ^= 0 then
					call evaluate_af_result ();
				     else call treat_af_result_as_atom ();

				else if afp -> af.atom_sw then call treat_af_result_as_atom ();

				else do;		/* don't recognize iteration, active strings, etc */
				     if use_standard_language then
					if search (return_string, TOKEN_BREAKS) ^= 0 then
					     call evaluate_af_result ();
					else call treat_af_result_as_atom ();
				     else if
					find_char_$first_in_table (nonvarying_return_string,
					cp_subsys_info.tokens_only_tct_table) ^= 0 then
					call evaluate_af_result ();
				     else call treat_af_result_as_atom ();
				end;

				if (iter_index = iter_count) & (new_first_node = null ()) then
				     last_np -> node.space = "0"b;
						/* last value from active function */
				else last_np -> node.space = ^(afp -> af.catenate_sw);
						/* intermediate value: normally space */
			     end;
		     end;
		end;


		iter_level = afp -> af.level;

		if semicolon_in_af then do;		/* if active string has more sub-parts */
		     semicolon_in_af = "0"b;
		     af_is_atom = afp -> af.atom_sw;	/* "quoting" result applies to all parts */
		     af_is_tokens = afp -> af.tokens_sw;
		     if pipe_control_ptr = null then last_np -> node.space = "1"b;
		     else if ^pipe_control.Sevaluate_pipe then last_np -> node.space = "1"b;

/* always separate sub-parts */
		     processing_type = afp -> af.delimiter_class;
		     go to PROCESS_BEGIN_ACTIVE_STRING;
		end;

		if (make_list_depth = 1) & evaluate_string & (afp = top_level_pp) then go to RETURN_FROM_MAKE_LIST;
						/* end of an evaluate_string entry */
		go to CONTINUE_SCAN;

/* Internal to process_active_function: rescans and re-evaluates the active function's return string */

evaluate_af_result:
		procedure ();

dcl  pipe_control_ptr		ptr;
dcl  1 pipe_control			aligned like command_pipe_control based (pipe_control_ptr);

		     af_line_ptr = addrel (return_ptr, 1);
		     af_line_len = length (return_string);
		     call return_string_advance ();

		     af_start = 1;
		     pipe_control_ptr = null;

		     on condition (cleanup)
			begin;

			if pipe_control_ptr ^= null then do;
			     call pipe_$terminate (addr (pipe_control.pipe_input_path),
				addr (pipe_control.pipe_output_path), ignore_code);
			     free pipe_control in (system_area);
			     p_pipe_control_ptr = null;
			end;
		     end;

		     call make_list (af_line_ptr, af_line_len, afp -> af.tokens_sw, af_start, pipe_control_ptr);

		     do while (af_start > 0);		/*  see if af value had semicolon */
			call get_node ();		/*  sets af_prev of new node */
			np -> node.type = END_OF_COMMAND;
			np -> node.af_prev -> atom.space = "1"b;
						/* previous node ends list */
			call make_list (af_line_ptr, af_line_len, afp -> af.tokens_sw, af_start, pipe_control_ptr);
			if pipe_control_ptr ^= null then do;
			     call pipe_$terminate (addr (pipe_control.pipe_input_path),
				addr (pipe_control.pipe_output_path), ignore_code);
			     free pipe_control in (system_area);
			     pipe_control_ptr = null;
			end;
		     end;

		     return;

		end evaluate_af_result;



/* Internal to process_active_function: makes the active function's return string appear as a single token in the expanded
   command line */

treat_af_result_as_atom:
		procedure ();

		     call get_node ();
		     np -> atom.type = ATOM;
		     np -> atom.string_ptr = addrel (return_ptr, 1);
		     np -> atom.string_len = length (return_string);

		     call return_string_advance ();

		     return;

		end treat_af_result_as_atom;

	     end process_active_function;
%page;
/* Internal to make_list:  "Allocate" a node, obtaining a new node_block if necessary */

get_node:
	     procedure ();

		null_cl = "0"b;			/* has to be something there or we wouldn't be here */

		node_index = node_index + 1;
		if node_index > hbound (node_block.array, 1) then do;
						/* allocate a new block */

		     last_block_ptr = block_ptr;

		     allocate node_block in (system_area) set (block_ptr);

		     unspec (node_block) = "0"b;
		     node_block.next = null ();
		     last_block_ptr -> node_block.next = block_ptr;
		     node_index = 1;
		end;

		np = addr (node_block.array (node_index));
						/* the node starts out as all zeroes */
		np -> node.next = null ();
		np -> node.af_prev = last_np;		/* in case node is af node */
		np -> node.af_iter_parent = null ();

		last_np -> node.next = np;
		last_np = np;

	     end get_node;



/* Internal to make_list:  Move return_ptr past the string just returned from the current active string invocation so that
   the result will not be lost */

return_string_advance:
	     procedure ();

		return_len = return_len - 4 * divide (length (return_string) + 3, 4, 21, 0) - 1;

		if return_len >= MIN_AF_RETURN_LTH then /* always give AF a certain minimum amount of space */
		     return_ptr = addrel (return_ptr, divide (length (return_string) + 7, 4, 17, 0));
		else return_ptr = null ();		/* not enough space left in this segment */

	     end return_string_advance;

	end make_list;
%page;
/* Compute number of iteration and arguments for the command and validate that matching iteration sets contain matching
   numbers of elements:  Two iteration sets are matching if either (1) they are connected (ie: the right parenthesis
   ending the first is not separated from the left parenthesis of the second by white space) or (2) they are top level
   iteration sets */

match_iters:
	procedure (p_first_node, p_command_type, p_arg_count, p_iter_count, p_new_first_node);

dcl  (p_first_node, p_new_first_node) pointer parameter;
dcl  p_command_type bit (1) aligned parameter;
dcl  (p_arg_count, p_iter_count) fixed binary parameter;

dcl  (p, pp) pointer;
dcl  first_iter bit (1) aligned;


	     first_iter = "1"b;
	     p_arg_count, p_iter_count = 0;
	     p_new_first_node = null ();		/* assume no semicolon left by AF */

	     p = p_first_node;
	     if p = null () then return;		/* empty list */
	     pp = null ();				/* pointer to last outer iteration set to be processed */
	     do while (p ^= null ());			/* to end of list */

		if p -> node.type = BEGIN_ITERATION then do;
						/* outer iteration set */
		     pp = p;			/* record pointer to iter node of iteration set */

		     call count_iteration ((p), count, 0, iter_level);
						/* iter_level should equal 0 */

		     if first_iter then do;
			first_iter = "0"b;
			p_iter_count = count;	/* save for later comparison */
		     end;
		     else if count ^= p_iter_count then do;
MISMATCH:
			code = error_table_$mismatched_iter;
			go to RETURN_FROM_CP;
		     end;

		     p_arg_count = p_arg_count + 1;	/* each outer iteration set is an argument */
		     if p ^= null () then		/* if iteration set does not end node list */
			if p -> node.next = null () then
						/* but node after it does */
			     p -> atom.space = "1"b;	/* list ends with atom */
			else ;
		end;
		else if p -> node.type = END_OF_COMMAND then do;
						/* semicolon embedded by an AF */
		     p_new_first_node = p -> node.next; /* remember where next piece is */
		     p -> node.af_prev -> node.next = null ();
						/* remove from chain */
		     p = null ();			/* do not look at rest */
		end;
		else do;				/* not ( or ; */
		     if p -> atom.next = null () then p -> atom.space = "1"b;
						/* last node in list */
		     if p -> node.space then p_arg_count = p_arg_count + 1;
		     p = p -> atom.next;
		end;
	     end;

	     if p_arg_count = 0 then
		p_iter_count = 0;			/* no arguments: this is an empty list */

	     else do;
		if p_command_type ^= active_function then p_arg_count = p_arg_count - 1;
						/* first argument is actually the command/AF name and should
						   not be included in the argument count: however, as AFs have
						   an extra argument (the return value), it isn't necessary to
						   change this value for AFs */
		if first_iter then p_iter_count = 1;	/* no iterations: read the list once */
	     end;

	     return;
%page;
/* Internal to match_iters:  processes a single iteration set (and any interation connected to it).  For example, (1 2) is
   a simple iteration set containing two (2) members; while (1 2)x(3 4) is a more complication expression involving two
   (2) connected iteration sets, but again only containing 2 members (1x3 and 2x4).  The iteration set (a (1 2)x(3 4) 5)x
   is an iteration set which contains four (4) members, namely ax, 1x3x, 2x4x, and 5x.

   Count_iteration returns the number of members in iteration_count and updates final_level to include all parentheses
   encountered in any of the nodes processed.  The node pointer variable 'p' is alsoupdated to point to the node following
   the node which ends the iteration set.  This is the first node unconnected to the iteration set */

count_iteration:
	     procedure (p_initial_p, p_iteration_count, p_parent_level, p_final_level);

dcl  p_initial_p pointer parameter;
dcl  (p_iteration_count, p_parent_level, p_final_level) fixed binary parameter;
dcl  (sub_count, temp_count) fixed binary;
dcl  (need_space, first_count) bit (1) aligned;

		p_iteration_count = 0;
		p_final_level = p_parent_level + 1;	/* count left paren */
		p = p_initial_p;			/* actually a no-op */

		p = p -> node.next;
		do while (p_final_level > p_parent_level);
		     if p = null () then go to MISMATCH;/* not enough )'s */
		     need_space = "1"b;		/* need to find a node which separates this
						   iteration set from rest of command line */
		     first_count = "1"b;		/* next iteration node begins an imbedded
						   iteration set which is not connected to previous one */

		     sub_count = 0;
		     do while (need_space);
			if p -> node.type = END_ITERATION then do;
			     if p -> node.next = null () then p -> node.space = "1"b;
			     pp = p -> iter_end.parent -> iter_begin.parent;
			     p_final_level = p -> iter_end.level;
			     if p_final_level < p_parent_level then do;
						/* multiple closure, pop one level */
				p_final_level = p_parent_level;
				need_space = "0"b;	/* do not advance to next node */
			     end;
			     else do;		/* closing one level */
				need_space = ^p -> iter_end.space;
				p = p -> iter_end.next;
			     end;
			end;
			else if p -> node.type = ATOM then do;
			     if p -> atom.space & (p_final_level = (p_parent_level + 1)) then
				sub_count = sub_count + 1;
			     if p -> node.next = null () then
						/* if last node in list */
				p -> node.space = "1"b;
			     need_space = ^p -> node.space;
			     p = p -> node.next;
			end;
			else if p -> node.type = BEGIN_ITERATION then do;
						/* another iteration  set */
			     if p_final_level = p_parent_level then do;
						/* this iteration is connected to */
				first_count = "0"b; /* initial iteration at p_parent_level+1 */
				sub_count = sub_count + p_iteration_count;
						/* save for later comparison */
				p_iteration_count = 0;
						/* compute iter count for connected iter */
			     end;			/* count the sub iteration */
			     call count_iteration ((p), temp_count, (p_final_level), p_final_level);
			     if first_count then do;
				sub_count = temp_count;
						/* save count of first iteration */
				first_count = "0"b;
			     end;
			     else if sub_count ^= temp_count then go to MISMATCH;
						/* this is count of an iter set connected to the first iter */
			     need_space = "0"b;
			end;
			else do;			/* semicolon in AF result embedded in parentheses ... */
			     code = error_table_$unbalanced_parentheses;
			     go to RETURN_FROM_CP;	/* ... is an error */
			end;
		     end;
		     p_iteration_count = p_iteration_count + sub_count;
						/* add to sum for parent iter set */
		end;

	     end count_iteration;

	end match_iters;
%page;
/* Create a command's argument list and either invoke it or produce a character string representation of the arguments:
   An argument list is generated (with descriptors) for the node list beginning at p_first_node */

produce_argument_list:
	procedure (p_first_node, p_command_type, p_arg_count);

dcl  p_first_node pointer parameter;
dcl  p_command_type bit (1) aligned parameter;
dcl  p_arg_count fixed binary parameter;
dcl  p_pipe_control_ptr ptr;

dcl  read_list_entry bit (1) aligned;

dcl  (p, pp) pointer;

dcl  start_arg bit (1) aligned;
dcl  null_iter bit (1) aligned;			/* ON means a null nested iter was found */
dcl  rethreaded bit (1) aligned;			/* ON if list already rethreaded */
dcl  (saved_level, argument_idx) fixed binary;

dcl  command_name character (arg_len (0)) unaligned based (command_name_ptr);
dcl  command_name_ptr pointer;
dcl  command_entry_ptr pointer;			/* command to call */

dcl  (extension_size, needed_space) fixed binary (21);
dcl  (arg_ptr, stack_ptr, space_ptr) pointer;
dcl  arg_space fixed binary (21);			/* number of chars left in space acquired */

dcl  object character (object_lth) unaligned based (object_ptr);
dcl  object_ptr pointer;
dcl  object_lth fixed binary (21);
dcl  suffix character (1) varying;

dcl  current_arg_len fixed binary (21);			/* number of chars in (non-simple) arg being developed */
dcl  current_arg character (current_arg_len) unaligned based (arg_ptr);

dcl  arg character (arg_space) unaligned based (arg_ptr);
dcl  arg_len (0:p_arg_count + 1) fixed binary automatic;

dcl  1 arg_list aligned automatic,
       2 twice_no_of_args fixed binary (18) unaligned unsigned,
       2 tag bit (18) unaligned initial ("000004"b3),
       2 twice_no_of_descriptors fixed binary (18) unaligned unsigned,
       2 has_command_name bit (1) unal,
       2 pad bit (17) unaligned initial ("0"b),
       2 arg_ptr (p_arg_count) pointer,
       2 descriptor_ptr (p_arg_count) pointer,
       2 name,
         3 command_name_ptr pointer,
         3 command_name_length fixed bin (21);

dcl  1 descriptor (p_arg_count) aligned automatic,
       2 bits bit (12) unaligned,			/* flag(1), type(6), packed(1), and ndims(4) */
       2 size fixed binary (24) unaligned unsigned;
%page;
/* Construct the argument list and then invoke the command */

read_list:
	entry (p_first_node, p_command_type, p_arg_count, p_pipe_control_ptr);

	     read_list_entry = "1"b;
	     go to RL_COMMON;



/* Construct the argument list and then produce a character string representation of the command invocation */

write_list:
	entry (p_first_node, p_command_type, p_arg_count, p_pipe_control_ptr);

	     read_list_entry = "0"b;


RL_COMMON:
	     count, current_arg_len, arg_space, extension_size = 0;
	     space_ptr = null ();
	     start_arg = "1"b;			/* need to get space for arg */
	     arg_ptr = null ();			/* just to catch programming errors */

	     p = p_first_node;

	     do while (p ^= null ());			/* to end of list */

		if p -> node.type = ATOM then do;	/* atom */
		     atom_ptr = p -> atom.string_ptr;
		     atom_len = p -> atom.string_len;
		     if start_arg & p -> atom.space then do;
						/* single command line token as arg */
			arg_len (count) = atom_len;
			if count = 0 then
			     command_name_ptr = atom_ptr;
			else arg_list.arg_ptr (count) = atom_ptr;
			current_arg_len = 0;
			count = count + 1;
			start_arg = "1"b;
		     end;
		     else do;
			call non_simple_arg ();
			if p -> atom.space then call end_arg ();
		     end;
		     p = p -> atom.next;
		end;

		else do;				/* iteration set */
		     rethreaded = "0"b;
		     iter_level = 1;
		     pp = p;			/* go inside; set parent pointer */

		     do p = p -> node.next repeat (p -> node.next) while (iter_level > 0);
						/* to end of outer iteration set */

			if p -> node.type = BEGIN_ITERATION then do;
						/* nested iteration */
			     if ^start_arg & rethreaded then rethreaded = "0"b;
						/* if connected iteration must rethread each iteration set */
			     iter_level = iter_level + 1;
			     pp = p;
			     if p -> iter_begin.next = p -> iter_begin.end then do;
						/* null iteration set */
				current_arg_len = 0;/* have to begin arg over */
				start_arg = "1"b;
				null_iter = "1"b;
				rethreaded = "0"b;
				go to skip_iter;
			     end;
			end;
			else do;
			     null_iter = "0"b;
			     atom_ptr = p -> atom.string_ptr;
			     atom_len = p -> atom.string_len;
			     if start_arg & (p -> atom.space) & (pp -> iter_begin.end -> iter_end.space)
				& (iter_level = 1) then do;
						/* single command line token as arg */
						/* depends upon whether right paren is followed by space */
						/* only simple tokens in the outermost iteration set
						   are not copied, to detect simple tokens when additional
						   levels of nesting are involved is quite complicated and not
						   deemed worth the effort for a very unlikely construct */
				arg_len (count) = atom_len;
				if count = 0 then
				     command_name_ptr = atom_ptr;
				else arg_list.arg_ptr (count) = atom_ptr;
				current_arg_len = 0;
				count = count + 1;
				start_arg = "1"b;
			     end;
			     else call non_simple_arg ();

			     if p -> atom.space then do;
						/* this atom ends an element of the iteration set */
				if ^rethreaded then do;
						/* rethread next iteration element */
				     rethreaded = "1"b;
						/* assume we can do the rethreading */
				     if p -> atom.next -> node.type ^= END_ITERATION then
					pp -> iter_begin.next = p -> atom.next;
						/* if not last element of iteration set */
				     else if p -> atom.next -> iter_end.space then do;
						/* if last element of iteration set followed by space */
					if iter_level = 1 then
					     p -> atom.next -> iter_end.parent -> iter_begin.next =
						p -> atom.next;
						/* and top level */
					else pp -> iter_begin.parent -> iter_begin.next =
						p -> atom.next -> iter_end.next;
						/* not top level, its done */
				     end;
				     else rethreaded = "0"b;
						/* last element of iteration set not followed by space */
						/* have to perform rethreading later */
				end;

/* Skip to the end of this iteration set */

skip_iter:
				saved_level = iter_level;
				p = pp -> iter_begin.end;
						/* move p to ) node */

				do while (iter_level > 0);
				     if p -> node.type = BEGIN_ITERATION then do;
						/* left paren, jump to right paren which matches */
					iter_level = iter_level + 1;
					pp = p;
					p = pp -> iter_begin.end;
				     end;

/* Node must be either an atom or iter_end node */
				     if p -> node.type = END_ITERATION then do;
					iter_level = p -> iter_end.level;
					pp = p -> iter_end.parent -> iter_begin.parent;
					if iter_level = 0 then
					     if p -> iter_end.space then
						if ^start_arg then
						     call end_arg ();
						else ;
						/* no arg needs to be ended */
					     else ;
						/* reached outermost ), but it is connected to something */
					else do;	/* reached end of nested iteration */
					     if iter_level >= saved_level then ;
						/* some other iter set */
					     else if p -> iter_end.space then
						if null_iter then
						     go to more_arg;
						/* finished with stuff connected to null iteration */
						else ;
						/* nested iter, nothing connected to it */
					     else if null_iter then ;
						/* end of iter connected to null iter */
					     else go to more_arg;
						/* nested iter with something attached */
					     p = p -> node.next;
					end;
				     end;
				     else if null_iter & p -> atom.space then go to more_arg;
						/* reached last node connected to null iteration */
				     else p = p -> node.next;
						/* an atom node */
				end;
			     end;
			end;
more_arg:
		     end;				/* p can be null at this point */
		end;
	     end;
%page;
	     if read_list_entry then do;

/* All arguments have been completed and the command or active function should be called */

		if p_command_type = active_function then
		     twice_no_of_args, twice_no_of_descriptors = 2 * count;
		else twice_no_of_args, twice_no_of_descriptors = 2 * (count - 1);

		do argument_idx = 1 to count - 1;
		     descriptor_ptr (argument_idx) = addr (descriptor (argument_idx));
		     descriptor (argument_idx).bits = "5260"b3;
		     descriptor (argument_idx).size = arg_len (argument_idx);
		end;				/* unaligned nonvarying strings */

		if p_command_type = active_function then do;
		     call setup_return_string ();	/* prepare the return string */
		     arg_list.arg_ptr (p_arg_count) = addrel (addr (return_string), 1);
		     descriptor_ptr (p_arg_count) = addr (descriptor (p_arg_count));
		     descriptor (p_arg_count).bits = "5320"b3;
						/* aligned, varying string */
		     descriptor (p_arg_count).size = return_len;
		end;


/* save the name on the current argument list NOTE this is  a new structure
*/

		arg_list.has_command_name = "1"b;
		arg_list.name.command_name_length = length (command_name);
		arg_list.name.command_name_ptr = command_name_ptr;
		command_entry_ptr = null;

		if multics_cp then on condition (command_abort_) go to ABORT_EXECUTION;
		else if p_command_type = command then on condition (request_abort_) go to ABORT_EXECUTION;


		if p_command_type = active_function | p_pipe_control_ptr = null then do;
						/* regular command call         */

		     call process_command (command_entry_ptr, code);
		     if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		end;
		else do;				/* the pipe facility is invoked */
		     on condition (cleanup) call process_pipe_cleanup (p_pipe_control_ptr);

		     call process_pipe (p_pipe_control_ptr, command_name, code);
		     if code ^= 0 then go to RETURN_FROM_CP;
		end;

	     end;
%page;
	     else do;

/* All arguments have been completed and the list is to be retruned as a character string */

		do argument_idx = 0 to count - 1;

		     if (argument_idx ^= count - 1) then
			suffix = " ";		/* more to come */
		     else suffix = "";

		     if argument_idx = 0 then
			object_ptr = command_name_ptr;
		     else object_ptr = arg_list.arg_ptr (argument_idx);
		     object_lth = arg_len (argument_idx);

		     if length (P_return_value) + object_lth + length (suffix) > maxlength (P_return_value) then
			code = error_table_$command_line_overflow;

		     P_return_value = P_return_value || object;
						/* two statements generates better code */
		     P_return_value = P_return_value || suffix;

		     if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
						/* failure to fit */
		end;
	     end;
ABORT_EXECUTION:
	     return;
%page;
/* Internal to produce_argument_list:  moves the atom_string into the current_arg, obtaining more space if necessary */

non_simple_arg:
	     procedure () /* options (quick) */;	/* MUST BE A QUICK BLOCK */

		if current_arg_len + atom_len > arg_space then do;
		     needed_space = 16 * max (4, divide (currentsize (atom_string) + 15, 16, 21, 0));
		     extension_size = extension_size + needed_space;
		     if using_stack & (needed_space < 1024) & (extension_size < MAX_STACK_EXTENSION) then do;
						/* OK to continue extending the stack */
			call cu_$grow_stack_frame (needed_space, stack_ptr, ignore_code);
						/* grow_stack_frame always returns zero code */
			if space_ptr = null () then do;
			     space_ptr = stack_ptr;
			     arg_ptr = space_ptr;	/* first call, must initialize arg_ptr */
			end;
			arg_space = arg_space + 4 * needed_space;
		     end;

		     else do;			/* use space in a temporary segment */
			using_stack = "0"b;
			space_ptr = select_scratch_segment ();
			arg_space = 4 * sys_info$max_seg_size;
			if ^start_arg then do;
			     substr (space_ptr -> arg, 1, current_arg_len) = current_arg;
			     arg_space = arg_space - current_arg_len;
			end;
			arg_ptr = space_ptr;	/* have switched spaces */
		     end;
		end;

		substr (arg, current_arg_len + 1, atom_len) = atom_string;
		current_arg_len = current_arg_len + atom_len;
		start_arg = "0"b;			/* arg has been started */
		arg_space = arg_space - atom_len;

	     end non_simple_arg;
%page;
/* Internal to produce_argument_list:  complete construction of the current argument */

end_arg:
	     procedure ();

		if count = 0 then
		     command_name_ptr = arg_ptr;
		else arg_list.arg_ptr (count) = arg_ptr;
		arg_len (count) = current_arg_len;

		arg_ptr = addr (substr (arg, current_arg_len + 1, 1));
						/* get pointer to char after
						   last char of this arg */
		arg_space = arg_space - current_arg_len;

		count = count + 1;
		start_arg = "1"b;
		current_arg_len = 0;

	     end end_arg;



/* Internal to produce_argument_list:  Prepares the return string for an active function invocation */

setup_return_string:
	     procedure ();

		if return_ptr = null () then do;	/* first active function or last one used too much space */
		     return_ptr = select_scratch_segment ();
		     return_len = 4 * (sys_info$max_seg_size - 1);
		end;

		return_string = "";

		return;

	     end setup_return_string;
%page;
process_command:
	     proc (command_entry_ptr, code);

dcl  command_entry_ptr ptr,
     code fixed bin (35);

		if multics_cp then do;		/* executing Multics command line */
		     if lss_on then do;		/* running Limited Service System */
			call transform_command_ (command_name_ptr, arg_len (0), cp_data_$command_table_ptr, code);

			if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		     end;

		     if command_entry_ptr = null then do;
			if evaluate_string then	/* be silent for cp_$af */
			     call find_command_$fc_no_message (command_name_ptr, arg_len (0), command_entry_ptr,
				code);

			else call find_command_ (command_name_ptr, arg_len (0), command_entry_ptr, code);

			if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;

		     end;

		     call cu_$gen_call (command_entry_ptr, addr (arg_list));
		end;

		else if new_subsystem_call		/* executing a new-style subsystem request */
		then do;
		     call execute_request (P_subsystem_info_ptr, command_name, addr (arg_list), code);
		     if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		end;

		else do;				/* executing an old-style subsystem request */
		     call old_execute_request (command_name, addr (arg_list), code);
		     if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
		end;
		return;

	     end process_command;
%page;

/* Internal to produce_argument_list: determines whether the entry is an io
   attachment or command, then processes accordingly. */

process_pipe:
	     proc (p_pipe_control_ptr, command_name, code);

dcl  p_pipe_control_ptr ptr parameter,				/* (input) - ptr 2 pipe control info */
     command_name char (*) parameter,				/* (input) - name of the command    */
     code fixed bin (35) parameter;				/* (output)- error status	      */

dcl  aligned_command_name char (32) aligned;
dcl  pipe_control_ptr ptr;
dcl  1 pipe_control aligned like command_pipe_control based (pipe_control_ptr);
dcl  Satds_match bit (1) aligned;
dcl  Sdefault_curr_to_vfile bit (1) aligned;
dcl  attach_description char (1024) aligned;
dcl  command_entry_ptr ptr;
dcl  current_pipe aligned char (pipe_control.current_pipe_len) based (pipe_control.current_pipe_ptr);
dcl  next_pipe aligned char (pipe_control.next_pipe_len) based (pipe_control.next_pipe_ptr);
dcl  previous_pipe aligned char (pipe_control.previous_pipe_len) based (pipe_control.previous_pipe_ptr);
dcl  pipeout_file_path char (168) aligned;
dcl  sv_pipe_path char (58);

dcl  FALSE bit (1) aligned internal static options (constant) init ("0"b),
     TRUE bit (1) aligned internal static options (constant) init ("1"b),
     INPUT bit (1) aligned internal static options (constant) init ("1"b),
     OUTPUT bit (1) aligned internal static options (constant) init ("0"b);

dcl  pipe_$initiate entry (ptr),
     pipe_$copy entry (ptr, ptr, fixed bin (35)),
     pipe_$attach_pipe entry (char (*) aligned, bit (1) aligned, bit (1) aligned, ptr, fixed bin (35)),
     pipe_$open_pipe entry (ptr, bit (1) aligned, fixed bin (35)),
     pipe_$get_return_string_nnl entry (ptr, ptr, fixed bin (21), fixed bin (35)),
     pipe_$get_return_string entry (ptr, ptr, fixed bin (21), fixed bin (35));

		pipe_control_ptr = p_pipe_control_ptr;
		command_entry_ptr = null;
		Satds_match = FALSE;

		if pipe_control.current_pipe_len = 0 then return;

		if substr (command_name, 1, length (VERTICAL_BAR)) = VERTICAL_BAR then
		     code = error_table_$bad_file_name;
		else call check_star_name_ (command_name,
		   CHECK_STAR_PROCESS_PATH |
		   CHECK_STAR_REJECT_WILD  |
		   CHECK_STAR_IGNORE_ENTRYPOINT, (0), code);

		if code ^= 0 then do;
		     error_message = command_name;
		     return;
		end;

		if pipe_control.Sevaluate_pipe then do;
		     if pipe_control.Sbuild_return_string then return_ptr = null;
		     call setup_return_string ();
		end;

/* only the command name needs to be checked to see if it is an atd */

	          aligned_command_name = command_name;
		if element_is_an_atd (aligned_command_name, command_entry_ptr, Sdefault_curr_to_vfile, code) then do;

/* This call builds a complete attach description for the current section of
   the command line.  The usage of the value next_pipe is discussed in
   make_list label PROCESS_CHARACTER (2) above.  Because the value may not be
   complete, it is necessary to build the attachment from the argument list. */

		     attach_description = make_command_line_attach ();
		     call process_attach_description (return_ptr, return_len, code);
		end;
		else call process_pipe_command (command_entry_ptr, command_name, return_ptr, return_len, code);

		return;
%page;
/* Internal to process_pipe: processes the current section of the command
   line if it is an attach description. */

process_attach_description:
		proc (af_return_str_ptr, af_return_str_len, code);

dcl  af_return_str_ptr ptr,				/* (input/output) ptr to return str */
     af_return_str_len fixed bin (21),			/* (input/output) len of return str */
     code fixed bin (35);				/* (output)       error status     */

		     code = 0;

/* If the element before the ";|" is an attach description, copy its
   contents to this attach description. */

		     if pipe_control.previous_pipe_ptr ^= null then do;
			call copy_thru_pipe (previous_pipe, attach_description, code);
			if code ^= 0 then return;

/* if the previous attach is the same as this one, the data was placed in a
   temp file.  Now copy the data from the temp file to the original */

			if Satds_match then do;
			     call copy_thru_pipe (pipe_control.pipe_output_path, attach_description, code);
			     if code ^= 0 then return;
			end;
		     end;

/* next_pipe_ptr is null when the attach description is the last element in an
   input command line. */
		     if pipe_control.next_pipe_ptr = null then return;

/* build the active function return string when this attach description
   preceeds the string ";|]" or ";||]". */

		     if pipe_control.Sbuild_return_string then do;
			if (pipe_control.niters < pipe_control.Niters) then
			     ;
			else call build_pipe_return_string (attach_description, af_return_str_ptr,
				af_return_str_len, code);
		     end;

/* If this attach description is the last thing in the line except ";|",
   use a default output file of "[wd]>pipeout". */

		     else if next_pipe = "" then do;
			pipeout_file_path =  rtrim (get_wdir_ ()) || ">pipeout";
			call copy_thru_pipe (attach_description, pipeout_file_path, code);
			end;
		       

/* if this element is an attach description that does not use any active
   functions, quotes or parens, do nothing.  Otherwise, copy its contents to
   the next element in the line.  This is because when the next pipe element
   is processed, this value will be the previous pipe value and because it
   has special characrters in it, the next element will expect a temp file. */

		     else if element_is_an_atd (current_pipe, null, Sdefault_curr_to_vfile, ignore_code) then ;

		     else do;

			call copy_thru_pipe (attach_description, ltrim (next_pipe), code);
			if code ^= 0 then return;

			if (pipe_control.niters < pipe_control.Niters) then
			     ;
			else do;

/* switch the pathnames of the input and output pipe work files so that
   the current output file will be used as input to the next element in
   the command line. */
			     sv_pipe_path = pipe_control.pipe_input_path;
			     pipe_control.pipe_input_path = pipe_control.pipe_output_path;
			     pipe_control.pipe_output_path = sv_pipe_path;
			end;
		     end;

		     return;
		end process_attach_description;
%page;
/* Internal to process_pipe: processes the current section of the command
   line if it is a command. */

process_pipe_command:
		proc (command_entry_ptr, command_name, af_return_str_ptr, af_return_str_len, code);

dcl  command_entry_ptr ptr,				/* (input) - ptr to entry to execute */
     command_name char (*),			/* (input) - name of command        */
     af_return_str_ptr ptr,				/* (input/output) ptr to return str */
     af_return_str_len fixed bin (21),			/* (input/output) len of return str */
     code fixed bin (35);				/* (output)- error status           */

		     code = 0;

		     call attach_input (previous_pipe, pipe_control.input_ptr, code);
		     if code ^= 0 then return;

		     if pipe_control.next_pipe_ptr ^= null then do;
			if next_pipe = "" then do;
			     pipeout_file_path =  rtrim (get_wdir_ ()) || ">pipeout";
			     call attach_output (previous_pipe, pipeout_file_path,
				pipe_control.output_ptr, Satds_match, code);
			     end;
			else call attach_output (previous_pipe, next_pipe, pipe_control.output_ptr, Satds_match,
				code);
			if code ^= 0 then return;
		     end;

		     call process_command (command_entry_ptr, code);
		     call process_pipe_cleanup (p_pipe_control_ptr);

		     if (pipe_control.niters < pipe_control.Niters) then
			;
		     else do;
			if pipe_control.Sbuild_return_string then
			     call build_pipe_return_string (pipe_control.pipe_output_path, af_return_str_ptr,
				af_return_str_len, code);

			sv_pipe_path = pipe_control.pipe_input_path;
			pipe_control.pipe_input_path = pipe_control.pipe_output_path;
			pipe_control.pipe_output_path = sv_pipe_path;
		     end;

		     return;
		end process_pipe_command;
%page;
/* Internal to process_pipe: compares two attach descriptions. */

atds_match:
		proc (attach_description_1, attach_description_2, Sdefault2) returns (bit (1) aligned);

dcl  attach_description_1 char (*) aligned,		/* (input) attach descrip. 1. */
     attach_description_2 char (*) aligned,		/* (input) attach descrip. 2. */
     Sdefault2 bit (1) aligned;			/* (input) atd2 is a vfile_ */

dcl  Sdefault1 bit (1) aligned,
     full_path1 char (1024),
     full_path2 char (1024),
     match_word1 char (32) varying,
     match_word2 char (32) varying,
     word_cnt1 fixed bin,
     word_cnt2 fixed bin,
     uid1 bit (36) aligned,
     uid2 bit (36) aligned;


		     word_cnt1 = 1;
		     word_cnt2 = 1;

/* if one of the attach descriptions is blank, they do not match. */

		     if attach_description_1 = SPACE | attach_description_2 = SPACE then return (FALSE);

/* If the first attach is defaulted to a vfile, set the match word to
   "vfile_".  Otherwise, set the match word to the first word in the
   attach description. */

		     if element_is_an_atd (attach_description_1, null, Sdefault1, ignore_code) then
			match_word1 = "vfile_";
		     else do;
			match_word1 = get_word (attach_description_1, word_cnt1);
			word_cnt1 = word_cnt1 + 1;
		     end;

/* If the secord attach is defaulted to a vfile, set the match word to
   "vfile_".  Otherwise, set the match word to the first word in the
   attach description. */

		     if Sdefault2 then
			match_word2 = "vfile_";
		     else do;
			match_word2 = get_word (attach_description_2, word_cnt2);
			word_cnt2 = word_cnt2 + 1;
		     end;

/* Here, the first words will always be the name of the I/O module used.
   If they do not match, the attach descriptions do not match. */

		     if match_word1 ^= match_word2 then return (FALSE);

/* If using vfile_, get the uid of the file begin attached to.   The uid
   is the only accurate means of determining if the two paths point to
   the same file. */

		     if match_word1 = "vfile_" then do;
			match_word1 = get_word (attach_description_1, word_cnt1);
			match_word2 = get_word (attach_description_2, word_cnt2);

			call absolute_pathname_ ((match_word1), full_path1, ignore_code);
			call hcs_$get_uid_file (full_path1, "", uid1, code);
			if code ^= 0 then do;
			     code = 0;
			     uid1 = TRUE;
			end;

			call absolute_pathname_ ((match_word2), full_path2, ignore_code);
			call hcs_$get_uid_file (full_path2, "", uid2, code);
			if code ^= 0 then do;
			     code = 0;
			     uid2 = FALSE;
			end;

			if uid1 = uid2 then return (TRUE);
			return (FALSE);
		     end;

/* Here, all I/O modules that are not vfile_ are checked.  If the first
   arguments to the I/O modules are the same, then return true. */

		     match_word1 = get_word (attach_description_1, word_cnt1);
		     match_word2 = get_word (attach_description_2, word_cnt2);

		     if match_word1 = match_word2 then return (TRUE);

/* Cases that are not handled by this routine include:

   1) mtape_ attach descriptions where the volume name is placed into the
   default arguments value within a value segment.  In this case,
   the attach description is incomplete.  Omitting the positional
   argument is a violation of the standard for I/O modules and mtape_
   should be changed to conform. */

		     return (FALSE);

get_word:
		     proc (word_list, word_to_return) returns (char (32) varying);

dcl  word_list char (*) aligned;
dcl  word_to_return fixed bin;
dcl  work_list char (1024) varying;
dcl  word char (32) varying;
dcl  i fixed bin;

/* If the attach description has a target attach, use only the target. */

			work_list = ltrim (after (word_list, "-target "));
			if work_list = "" then work_list = ltrim (word_list);

			do i = 1 to word_to_return;
			     word = before (work_list, SPACE);
			     work_list = after (work_list, SPACE);
			     work_list = ltrim (work_list);
			end;

			return (word);
		     end get_word;

		end atds_match;
%page;
/* Internal to process_pipe: attaches and opens user_input for use by
   the caller using the input attachment. */

attach_input:
		proc (input_atd, input_ptr, code);

dcl  input_atd char (*) aligned;			/* (input) - attach descipt/command */
dcl  input_ptr ptr;					/* (input/output) - ptr to input pipe info */
dcl  code fixed bin (35);				/* (output) - error status          */

dcl  Sdefault_to_vfile bit (1) aligned;

/* Attach and open the input based on type */

		     code = 0;
		     input_ptr = null;

		     if input_atd = "" then return;

		     input_atd = ltrim (input_atd);

/* If the input attachment is an attach description, attach and open it.
   Otherwise, attach and open the pipe input file. If there is no pipe input,
   there is an error. */

		     if element_is_an_atd (input_atd, null, Sdefault_to_vfile, ignore_code) then
			call pipe_$attach_pipe (input_atd, Sdefault_to_vfile, FALSE, input_ptr, code);

		     else do;			/* previous entry is a command */
			if pipe_control.pipe_input_path = "" then do;
			     code = error_table_$no_file;
			     return;
			end;

			else call pipe_$attach_pipe (pipe_control.pipe_input_path, TRUE, FALSE, input_ptr, code);
		     end;


		     if code ^= 0 then do;
			error_message = "While attaching " || rtrim (input_atd) || ".";
			return;
		     end;

		     call pipe_$open_pipe (input_ptr, INPUT, code);
		     if code ^= 0 then do;
			if code = error_table_$noentry then
			     error_message = "Unknown command or file " || input_atd || ".";
			else error_message = "While opening " || input_atd || " for input.";
			call process_pipe_cleanup (p_pipe_control_ptr);
			return;
		     end;
		     return;
		end attach_input;
%page;
/* Internal to process_pipe: attaches and opens user_output for use by
   the caller using the output attachment. */

attach_output:
		proc (input_atd, output_atd, output_ptr, Satds_match, code);

dcl  input_atd char (*) aligned;			/* (input) - input attachment       */
dcl  output_atd char (*) aligned;			/* (input) - output to be attached  */
dcl  output_ptr ptr;				/* (input/output) - ptr to output pipe info */
dcl  Satds_match bit (1) aligned;			/* (output) - ON = input matchs output */
dcl  code fixed bin (35);				/* (output) - error status          */

dcl  Sdefault_to_vfile bit (1) aligned;

		     code = 0;
		     output_ptr = null;

		     input_atd = ltrim (input_atd);
		     output_atd = ltrim (output_atd);

/* If the output attachment is an attach description and does not conflict
   with the input attachment, attach and open it.  Otherwise, attach and
   open the pipe output file. */

		     if element_is_an_atd (output_atd, null, Sdefault_to_vfile, ignore_code) then do;
			if atds_match (input_atd, output_atd, Sdefault_to_vfile) then
			     Satds_match = "1"b;
			else do;
			     call pipe_$attach_pipe (output_atd, Sdefault_to_vfile, TRUE, output_ptr, code);
			     Satds_match = "0"b;
			end;
		     end;

		     if output_ptr = null & code = 0 then do;
			if pipe_control.pipe_output_path = "" then
			     call pipe_$initiate (addr (pipe_control.pipe_output_path));

			call pipe_$attach_pipe (pipe_control.pipe_output_path, TRUE, TRUE, output_ptr, code);
		     end;

		     if code ^= 0 then do;
			error_message = "While attaching " || output_atd || ".";
			return;
		     end;

		     call pipe_$open_pipe (output_ptr, OUTPUT, code);
		     if code ^= 0 then do;
			error_message = "While opening " || output_atd || " for output.";
			call process_pipe_cleanup (p_pipe_control_ptr);
			return;
		     end;

		     return;
		end attach_output;
%page;
/* Internal to process_pipe: adds the information from the file given in
   the input_atd to the active function return string. */

build_pipe_return_string:
		proc (input_atd, pipe_return_string_ptr, pipe_return_string_len, code);

dcl  input_atd char (*) aligned,			/* (input) - return string file    */
     pipe_return_string_ptr ptr,			/* (input) - ptr to return string  */
     pipe_return_string_len fixed bin (21),		/* (input) - len of return string */
     code fixed bin (35);				/* (output) - error status         */

		     call attach_input (input_atd, pipe_control.input_ptr, code);
		     if code ^= 0 then return;

		     if pipe_control.Sinclude_NL_in_af_ret_str then
			call pipe_$get_return_string (pipe_control.input_ptr, pipe_return_string_ptr,
			     pipe_return_string_len, code);
		     else call pipe_$get_return_string_nnl (pipe_control.input_ptr, pipe_return_string_ptr,
			     pipe_return_string_len, code);

		     call process_pipe_cleanup (p_pipe_control_ptr);
		     return;
		end build_pipe_return_string;
%page;
/* Internal to process_pipe: copies the information from the file given in
   the input atd to the file given in the output atd. */

copy_thru_pipe:
		proc (copy_input_atd, copy_output_atd, code);

dcl  copy_input_atd aligned char (*),			/* (input) - input attach descript. */
     copy_output_atd aligned char (*),			/* (input) - output attach descript. */
     code fixed bin (35);				/* (output)- error status           */

		     call attach_input (copy_input_atd, pipe_control.input_ptr, code);

		     if code = error_table_$no_file then do;
			code = 0;
			return;
		     end;

		     if code = 0 then do;
			call attach_output (copy_input_atd, copy_output_atd, pipe_control.output_ptr, Satds_match,
			     code);
			if code = 0 then do;

			     call pipe_$copy (pipe_control.input_ptr, pipe_control.output_ptr, code);

			     if code ^= 0 then
				error_message =
				     "While copying data from " || ltrim (copy_input_atd) || " to "
				     || ltrim (copy_output_atd) || ".";
			end;
		     end;

		     call process_pipe_cleanup (p_pipe_control_ptr);

		     return;
		end copy_thru_pipe;
%page;
/* Internal to process_pipe: determines if the input pipe element is a valid
   attach description or command. */

element_is_an_atd:
		proc (pipe_element, p_command_entry_ptr, Sdefault_to_vfile, code) returns (bit (1) aligned);

dcl  pipe_element char (*) aligned,			/* (input) - element who type is to be determined */
     p_command_entry_ptr ptr,				/* (output)- if a command points to its entrypoint */
     Sdefault_to_vfile bit (1) aligned,			/* (output)- if an atd on = file name use vfile_  */
     code fixed bin (35);				/* (output)- error status                         */

dcl  dirname char (168),
     entryname char (32),
     io_module_attach_entry char (200);

dcl  command_entry_ptr ptr;

dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));

		     Sdefault_to_vfile = FALSE;
		     p_command_entry_ptr = null;

		     if ^multics_cp then return (FALSE);

		     pipe_element = ltrim (pipe_element);

		     if search (pipe_element, NON_SIMPLE_BREAKS) > 0 then return (FALSE);
				/* If entry already is an entry, it */
				/* is not an atd.		      */
		     if search (pipe_element, "$") > 0 then return (FALSE);
		     call find_command_$fc_no_message (addr (before (pipe_element, SPACE)),
			length (before (pipe_element, SPACE)), command_entry_ptr, code);
		     if code = 0 then do;
			p_command_entry_ptr = command_entry_ptr;
			return (FALSE);
		     end;

		     call expand_pathname_ (before (pipe_element, SPACE), dirname, entryname, code);

/* set the io module name to the entryname portion of the pipe element. If
   there is a pathname in the line, it is possible that a personal version
   of an i/o module is being used. */

		     io_module_attach_entry =
			before (ltrim (pipe_element), rtrim (entryname)) || rtrim (entryname) || "$"
			|| rtrim (entryname) || "attach";

		     call find_command_$fc_no_message (addr (io_module_attach_entry), length (io_module_attach_entry),
			command_entry_ptr, code);

		     if code = 0 then return (TRUE);


		     Sdefault_to_vfile = TRUE;
		     code = 0;
		     return (TRUE);

		end element_is_an_atd;
%page;
/* Internal to process_pipe: builds and returns an attach description and
   arguments using the argument list. */

make_command_line_attach:
		proc () returns (char (1024) varying);

dcl  command_line_attach char (1024) varying;

		     command_line_attach = "";
		     do argument_idx = 0 to count - 1;

			if (argument_idx ^= count - 1) then
			     suffix = " ";		/* more to come */
			else suffix = "";

			if argument_idx = 0 then
			     object_ptr = command_name_ptr;
			else object_ptr = arg_list.arg_ptr (argument_idx);
			object_lth = arg_len (argument_idx);

			if length (command_line_attach) + object_lth + length (suffix)
			     > maxlength (command_line_attach) then
			     code = error_table_$command_line_overflow;

			command_line_attach = command_line_attach || object;
						/* two statements generates better code */
			command_line_attach = command_line_attach || suffix;

			if code ^= 0 then go to SILENTLY_RETURN_FROM_CP;
						/* failure to fit */
		     end;
		     return (command_line_attach);
		end make_command_line_attach;

	     end process_pipe;

%page;

/* Internal to process_pipe:  closes and detaches user_input and user_output. */

process_pipe_cleanup:
	     proc (p_pipe_control_ptr);

dcl  p_pipe_control_ptr ptr;				/* (input) - ptr 2 pipe control info */

dcl  1 pipe_control aligned like command_pipe_control based (p_pipe_control_ptr);
dcl  pipe_$close_pipe entry (ptr, bit (1) aligned, fixed bin (35)),
     pipe_$detach_pipe entry (ptr, fixed bin (35));

		if pipe_control.input_ptr ^= null then do;
		     call pipe_$close_pipe (pipe_control.input_ptr, pipe_control.niters = pipe_control.Niters,
			ignore_code);
		     call pipe_$detach_pipe (pipe_control.input_ptr, ignore_code);
		end;

		if pipe_control.output_ptr ^= null then do;
		     call pipe_$close_pipe (pipe_control.output_ptr, "0"b, ignore_code);
		     call pipe_$detach_pipe (pipe_control.output_ptr, ignore_code);
		end;
		return;
	     end process_pipe_cleanup;

	end produce_argument_list;
%page;
/* Initialize scratch segment management */

initialize_scratch_segments:
	procedure (p_first_call);

dcl  p_first_call bit (1) aligned parameter;

	     if p_first_call then do;			/* only do the following stuff once per invocation ... */
		permanent_scratch_segment_list_ptr = addr (cp_data_$permanent_scratch_segment_list);
		cp_data_$scratch_lock_id = cp_data_$scratch_lock_id + 1;
		scratch_lock_id = bit (fixed (cp_data_$scratch_lock_id, 36, 0), 36);
	     end;

	     temporary_scratch_segment_list_ptr = addr (local_temporary_scratch_segment_list);
	     temporary_scratch_segment_list.n_allocated =
		dimension (local_temporary_scratch_segment_list.segment_ptrs, 1);
	     temporary_scratch_segment_list.n_used = 0;	/* not using any temporary scratch segments just yet */
	     temporary_scratch_segment_list.segment_ptrs (*) = null ();

	     return;

	end initialize_scratch_segments;



/* Select the next available scratch segment giving preference to the "permanent" segments */

select_scratch_segment:
	procedure () returns (pointer);

dcl  1 permanent_scratch_segment like permanent_scratch_segment_list.scratch_segments aligned
	based (permanent_scratch_segment_ptr);
dcl  (permanent_scratch_segment_ptr, old_temporary_scratch_segment_list_ptr, new_temporary_scratch_segment_list_ptr,
     segment_ptr) pointer;
dcl  idx fixed binary;

	     segment_ptr = null ();			/* haven't found one yet */

	     do idx = 1 to permanent_scratch_segment_list.n_scratch_segments while (segment_ptr = null ());
		permanent_scratch_segment_ptr = addr (permanent_scratch_segment_list.scratch_segments (idx));
		if stacq (permanent_scratch_segment.lock, scratch_lock_id, (36)"0"b) then do;
		     if permanent_scratch_segment.segment_ptr = null () then do;
			call get_temp_segment_ (COMMAND_PROCESSOR_, permanent_scratch_segment.segment_ptr, code);
			if code ^= 0 then go to RETURN_FROM_CP;
		     end;
		     permanent_scratch_segment.usage_count = permanent_scratch_segment.usage_count + 1;
		     segment_ptr = permanent_scratch_segment.segment_ptr;
		end;
	     end;

	     if segment_ptr = null () then do;		/* no permanent segments available */
		if temporary_scratch_segment_list.n_used = temporary_scratch_segment_list.n_allocated then do;
		     temporary_scratch_segment_list_n_allocated = 2 * temporary_scratch_segment_list.n_allocated;
		     old_temporary_scratch_segment_list_ptr = temporary_scratch_segment_list_ptr;
		     allocate temporary_scratch_segment_list in (system_area)
			set (new_temporary_scratch_segment_list_ptr);
		     new_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used =
			old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used;
		     new_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.segment_ptrs (*) =
			null ();
		     do idx = 1 to old_temporary_scratch_segment_list_ptr -> temporary_scratch_segment_list.n_used;
			new_temporary_scratch_segment_list_ptr
			     -> temporary_scratch_segment_list.segment_ptrs (idx) =
			     old_temporary_scratch_segment_list_ptr
			     -> temporary_scratch_segment_list.segment_ptrs (idx);
		     end;
		     temporary_scratch_segment_list_ptr = new_temporary_scratch_segment_list_ptr;
		     if old_temporary_scratch_segment_list_ptr ^= addr (local_temporary_scratch_segment_list) then
			free old_temporary_scratch_segment_list_ptr
			     -> temporary_scratch_segment_list in (system_area);
		end;
		temporary_scratch_segment_list.n_used, idx = temporary_scratch_segment_list.n_used + 1;
		call get_temp_segment_ (COMMAND_PROCESSOR_, temporary_scratch_segment_list.segment_ptrs (idx), code);
		if code ^= 0 then go to RETURN_FROM_CP;
		segment_ptr = temporary_scratch_segment_list.segment_ptrs (idx);
	     end;

	     return (segment_ptr);

	end select_scratch_segment;



/* Release any temporary scratch segments and mark all "permanent" segments selected by this invocation as available */

release_scratch_segments:
	procedure (p_last_call);

dcl  p_last_call bit (1) aligned parameter;

dcl  1 permanent_scratch_segment like permanent_scratch_segment_list.scratch_segments aligned
	based (permanent_scratch_segment_ptr);
dcl  permanent_scratch_segment_ptr pointer;
dcl  idx fixed binary;

	     do idx = 1 to permanent_scratch_segment_list.n_scratch_segments;
		permanent_scratch_segment_ptr = addr (permanent_scratch_segment_list.scratch_segments (idx));
		if permanent_scratch_segment.lock = scratch_lock_id then do;
		     if mod (permanent_scratch_segment.usage_count, cp_data_$scratch_release_factor) = 0 then do;
			call release_temp_segment_ (COMMAND_PROCESSOR_, permanent_scratch_segment.segment_ptr,
			     ignore_code);
			permanent_scratch_segment.usage_count = 0;
		     end;
		     if stacq (permanent_scratch_segment.lock, (36)"0"b, scratch_lock_id) then ;
		end;				/* mark it as available */
	     end;

	     if temporary_scratch_segment_list_ptr ^= null () then
		if temporary_scratch_segment_list.n_used > 0 then do;
		     call release_temp_segments_ (COMMAND_PROCESSOR_, temporary_scratch_segment_list.segment_ptrs (*),
			ignore_code);
		     temporary_scratch_segment_list.n_used = 0;
		     if temporary_scratch_segment_list_ptr ^= addr (local_temporary_scratch_segment_list) then do;
			free temporary_scratch_segment_list in (system_area);
			temporary_scratch_segment_list_ptr = null ();
		     end;
		end;

	     if ^p_last_call then			/* setup for the next top-level command/request */
		call initialize_scratch_segments ("0"b);

	     return;

	end release_scratch_segments;
%page;
/* Free all allocated node_blocks */

free_nodes:
	procedure (p_last_call);

dcl  p_last_call bit (1) aligned parameter;

	     last_block_ptr = addr (stack_space) -> node_block.next;
	     if last_block_ptr ^= null () then do;
		do block_ptr = last_block_ptr -> node_block.next repeat (block_ptr -> node_block.next)
		     while (block_ptr ^= null ());
		     free last_block_ptr -> node_block in (system_area);
		     last_block_ptr = block_ptr;
		end;
		free last_block_ptr -> node_block in (system_area);
	     end;

	     if p_last_call then			/* prevent attempts to free when nothing to free */
		addr (stack_space) -> node_block.next = null ();
	     else do;				/* still have work to do */
		block_ptr = addr (stack_space);
		unspec (node_block) = "0"b;
		node_block.next = null ();
		node_index = 0;
		addr (dummy_node) -> node.next = null ();
	     end;

	end free_nodes;

     end complex_command_processor;
%page;
/* Validates a subsystem's request language definition and builds the necessary TCT tables used in make_list above */

validate_cp_subsys_info:
     entry (P_cp_subsys_info_ptr, P_code);

	call validate_request_language (P_cp_subsys_info_ptr, P_code);
						/* use an internal procedure to avoid wasting stack space */
	return;


/* Internal procedure that does the actual work */

validate_request_language:
     procedure (p_cp_subsys_info_ptr, p_code) options (non_quick);

dcl  p_cp_subsys_info_ptr pointer parameter;
dcl  p_code fixed binary (35) parameter;

dcl  1 full_language like cp_data_$standard_language aligned based (addr (cp_subsys_info.full_tct_table));
dcl  1 token_language like cp_data_$standard_language aligned based (addr (cp_subsys_info.tokens_only_tct_table));

dcl  (begin_iterations, end_iterations, begin_active_strings, end_active_strings) bit (8);
dcl  (processing_type, idx) fixed binary;

	cp_subsys_info_ptr = p_cp_subsys_info_ptr;

	if cp_subsys_info.version ^= CP_SUBSYS_INFO_VERSION_1 then do;
	     p_code = error_table_$unimplemented_version;
	     return;
	end;

	if ^cp_subsys_info.non_standard_language then do;
	     p_code = 0;				/* subsystem uses the standard language which is always OK */
	     return;
	end;

	if unspec (cp_subsys_info.full_tct_table) = unspec (cp_data_$standard_language) then do;
	     cp_subsys_info.non_standard_language = "0"b;
	     p_code = 0;				/* it is the standard language after all */
	     return;
	end;

	begin_iterations, end_iterations, begin_active_strings, end_active_strings = ""b;

	do idx = lbound (full_language.character_types, 1) to hbound (full_language.character_types, 1);
	     processing_type = full_language.character_types (idx);

	     if (processing_type < NORMAL_CHARACTER)
		| ((processing_type > ACTIVE_STRING_MODIFIER) & (processing_type < BEGIN_ITERATION_1))
		| (processing_type > END_ACTIVE_STRING_8) then do;
		p_code = error_table_$bad_subr_arg;
		return;				/* unknown processing type specified */
	     end;

	     if (processing_type = WHITESPACE) | (processing_type = QUOTE_CHARACTER) then
		token_language.character_types (idx) = processing_type;
	     else if (processing_type = COMMAND_SEPARATOR_OR_WHITESPACE) then
		token_language.character_types (idx) = WHITESPACE;
	     else token_language.character_types (idx) = NORMAL_CHARACTER;

	     if (processing_type >= BEGIN_ITERATION_1) & (processing_type <= BEGIN_ITERATION_8) then
		substr (begin_iterations, (processing_type - BEGIN_ITERATION_1 + 1), 1) = "1"b;
	     if (processing_type >= END_ITERATION_1) & (processing_type <= END_ITERATION_8) then
		substr (end_iterations, (processing_type - END_ITERATION_1 + 1), 1) = "1"b;

	     if (processing_type >= BEGIN_ACTIVE_STRING_1) & (processing_type <= BEGIN_ACTIVE_STRING_8) then
		substr (begin_active_strings, (processing_type - BEGIN_ACTIVE_STRING_1 + 1), 1) = "1"b;
	     if (processing_type >= END_ACTIVE_STRING_1) & (processing_type <= END_ACTIVE_STRING_8) then
		substr (end_active_strings, (processing_type - END_ACTIVE_STRING_1 + 1), 1) = "1"b;
	end;

	if begin_iterations ^= end_iterations then p_code = error_table_$unbalanced_parentheses;

	else if begin_active_strings ^= end_active_strings then p_code = error_table_$unbalanced_brackets;

	else p_code = 0;				/* every begin/end iteration/active string has a match */

	return;

     end validate_request_language;
%page;
/* Enable the Limited Service Subsystem */

setup_lss:
     entry (P_table_ptr);

dcl  P_table_ptr pointer parameter;

	cp_data_$under_lss = "1"b;
	cp_data_$command_table_ptr = P_table_ptr;
	return;



/* Disable the Limited Service Subsystem */

reset_lss:
     entry ();

	cp_data_$under_lss = "0"b;
	return;



/* Obsolete entry points */

set_line:
     entry (P_newsize);

dcl  P_newsize fixed binary (21) parameter;

	call com_err_ (0, "command_processor_$set_line",
	     "There is no restriction on command line expansion.  Call ignored.");

	return;


get_line:
     entry (P_newsize);

	call com_err_ (0, "command_processor_$get_line", "There is no restriction on command line expansion.");

	P_newsize = MIN_AF_RETURN_LTH;

	return;
%page;
%include check_star_name;
%page;
%include cp_data_;
%page;
%include cp_character_types;

%include cp_active_string_types;

%include "_cp_subsys_info";
%page;
%include sub_err_flags;
     end command_processor_;




		    config_deck_data_.cds           11/11/89  1103.4r w 11/11/89  0803.5       95310



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

config_deck_data_: proc (); 

/* Written August/September of 1984 by Allen Ball to replace old, hard-to-read version. */
/* Modified March 1985 to no longer need bce/Multics versions! Keith Loepere */

/* format: style4,initcol1,indattr,declareind8,dclind4,idind33,ifthenstmt,ifthen,^indproc,delnl,insnl */

dcl Me			       char (17) static options (constant) init ("config_deck_data_");
dcl PAD			       (1) char (32) int static options (constant) init ("pad*");

dcl addr			       builtin;
dcl before		       builtin;
dcl card_number		       fixed bin;
dcl code			       fixed bin (35);
dcl com_err_		       entry () options (variable);
dcl create_data_segment_	       entry (ptr, fixed bin (35));
dcl cv_dec_check_		       entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl dimension		       builtin;
dcl field			       char (12);
dcl field_counter		       fixed bin;
dcl field_pos		       fixed bin;
dcl i			       fixed bin;
dcl ioa_			       entry () options (variable);
dcl j			       fixed bin;
dcl last			       bit (1) init ("0"b);
dcl length		       builtin;
dcl ltrim			       builtin;
dcl number_of_cards		       fixed bin;
dcl number_of_repeats	       fixed bin;
dcl 1 repeating_group	       (14) aligned,
      2 field_name		       char (12) varying,
      2 field_type		       bit (2);
dcl repeating_group_length	       fixed bin;
dcl rtrim			       builtin;
dcl size			       builtin;
dcl substr		       builtin;
dcl test_number		       fixed bin (35);
dcl unspec		       builtin;
dcl valid_deck		       bit (1) init ("1"b);
dcl valid_field		       bit (1) init ("0"b);

	/*** First check to see if there are valid types of fields. ***/
	number_of_cards = dimension (config_deck_cards, 1);
	do card_number = 1 to number_of_cards;
	     field_pos = 0;
	     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
	     /*** Check and see if this is a valid card name. ***/
	     do i = 1 to dimension (Card_names, 1);
		if field = Card_names (i) then valid_field = "1"b;
	     end;
	     if ^valid_field | last then call bad_card;
	     valid_field = "0"b;			/* Reset the signal now. */
	     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
	     /*** Check and see if the second field is a valid subname. ***/
	     do i = 1 to dimension (Card_subnames, 1);
		if field = Card_subnames (i) then valid_field = "1"b;
	     end;
	     if ^valid_field then call bad_card;
	     valid_field = "0"b;
	     if ^last then do;
		do while (^last);
		     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
		     do i = 1 to dimension (Card_field_names, 1);
			if field = Card_field_names (i) then valid_field = "1"b;
		     end;
		     if ^valid_field | last then call bad_card;
						/* At this point there must be an even number of fields. */
		     valid_field = "0"b;		/* Reset before we forget. */
		     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
		     do i = 1 to dimension (Card_data_types, 1);
			if field = Card_data_types (i) then valid_field = "1"b;
		     end;
		     if ^valid_field then do;
			test_number = cv_dec_check_ (field, code);
			if code ^= 0 then call bad_card;
						/* Not a chance of being valid. */
		     end;
		     valid_field = "0"b;
		end;
	     end;
	end;
	if ^valid_deck then
	     return;
	else call ioa_ ("^a: (First pass) This seems to be a valid deck.", Me);

%page;	/*** Now that we have a seemingly reasonable deck let's fill in the blanks. ***/
	begin;

dcl 1 cds_data		       aligned like cds_args;
dcl 1 config_deck_data_	       aligned,
	     2 num_described_cards fixed bin aligned init (number_of_cards),
		2 Config_card_field_name (number_of_cards, 14) char (12) varying aligned,
		2 Config_card_field_type (number_of_cards, 14) bit (2) unaligned,
		2 Config_card_group_length (number_of_cards) fixed bin aligned,
		2 Config_card_min_specifiable_fields (number_of_cards) fixed bin aligned,
		2 Config_card_name (number_of_cards) char (4) aligned,
		2 Config_card_num_described_fields (number_of_cards) fixed bin aligned,
		2 Config_card_subname (number_of_cards) char (4) varying aligned;

	     unspec (Config_card_field_name) = "0"b;
	     unspec (Config_card_field_type) = "0"b;
	     unspec (Config_card_group_length) = "0"b;
	     unspec (Config_card_min_specifiable_fields) = "0"b;
	     unspec (Config_card_name) = "0"b;
	     unspec (Config_card_num_described_fields) = "0"b;
	     unspec (Config_card_subname) = "0"b;
	     unspec (repeating_group) = "0"b;
	     do card_number = 1 to number_of_cards;
		field_pos = 0;
		call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
		Config_card_name (card_number) = rtrim (field);
		call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
		if field = "emp" then
		     Config_card_subname (card_number) = "";
		else Config_card_subname (card_number) = rtrim (field);
		if ^last then do;
		     do field_counter = 1 repeat field_counter + 1 while (^last);
			call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos, last);
			if field = "repeat" then do;
			     field_counter = field_counter - 1;
			     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos,
				last);
			     if last then do;
serious_error:
				call ioa_ ("^a: Serious error in:^/^a", Me, config_deck_cards (card_number));
				return;
			     end;
			     number_of_repeats = (cv_dec_check_ (field, code));
			     if code ^= 0 then goto serious_error;
			     do repeating_group_length = 1 repeat repeating_group_length + 1 while (^last);
				call get_next_field (config_deck_cards (card_number), (field_pos), field,
				     field_pos, last);
				if field = "minimum" | field = "repeat" then goto serious_error;
				repeating_group (repeating_group_length).field_name = field;
				call get_next_field (config_deck_cards (card_number), (field_pos), field,
				     field_pos, last);
				repeating_group (repeating_group_length).field_type =
				     determine_field_type (field, code);
				if code ^= 0 then goto serious_error;
			     end;
			     Config_card_group_length (card_number) = repeating_group_length - 1;
			     if (Config_card_group_length (card_number) * number_of_repeats) + field_counter > 14
				then
				goto serious_error;
			     do i = 1 to number_of_repeats;
				do j = 1 to Config_card_group_length (card_number);
				     Config_card_field_name (card_number,
					field_counter + j + (i - 1) * Config_card_group_length (card_number)) =
					rtrim (repeating_group (j).field_name);
				     Config_card_field_type (card_number,
					field_counter + j + (i - 1) * Config_card_group_length (card_number)) =
					repeating_group (j).field_type;
				end;
			     end;
			end;
			else if field = "minimum" then do;
			     field_counter = field_counter - 1;
			     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos,
				last);
			     Config_card_min_specifiable_fields (card_number) = (cv_dec_check_ (field, code));
			     if code ^= 0 then goto serious_error;
			end;
			else do;
			     Config_card_field_name (card_number, field_counter) = rtrim (field);
			     call get_next_field (config_deck_cards (card_number), (field_pos), field, field_pos,
				last);
			     Config_card_field_type (card_number, field_counter) =
				determine_field_type (field, code);
			     if code ^= 0 then goto serious_error;
			end;
		     end;
		     Config_card_num_described_fields (card_number) =
			field_counter + Config_card_group_length (card_number) * number_of_repeats - 1;
		end;
	     end;
	     /*** Seems to be completely valid. ***/
	     call ioa_ ("^a: (Second pass) This is a valid config deck.", Me);

	     cds_data.sections (1).p = addr (config_deck_data_);
	     cds_data.sections (1).len = size (config_deck_data_);

	     cds_data.sections (1).struct_name = Me;

	     cds_data.seg_name = Me;

	     cds_data.num_exclude_names = 1;
	     cds_data.exclude_array_ptr = addr (PAD);
	     string (cds_data.switches) = "0"b;
	     cds_data.switches.have_text = "1"b;

	     call create_data_segment_ (addr (cds_data), code);

	     if code ^= 0 then call com_err_ (code, Me);
	     return;
	end;

%page;
bad_card:
     proc ();
	call ioa_ ("^a: Bad card.  Check '^a' in:", Me, field);
	call ioa_ ("^a", config_deck_cards (card_number));
	valid_deck = "0"b;
	return;
     end;
%page;
determine_field_type:
     proc (p_string, p_code) returns (bit (2) unaligned);

dcl i			       fixed bin;
dcl p_code		       fixed bin (35) parameter;
dcl p_string		       char (12) parameter;

	do i = 1 to dimension (Card_data_types, 1);
	     if Card_data_types (i) = p_string then do;
		p_code = 0;
		return (Card_data_bit_strings (i));
	     end;
	end;
	p_code = -1;
	return ("00"b);
     end;

%page;
get_next_field:
     proc (card, previous_field_pos, p_field, new_field_pos, p_last);

dcl card			       char (210) parameter;
dcl test_field		       char (210) init ("");
dcl new_field_pos		       fixed bin parameter;
dcl p_last		       bit (1) parameter;
dcl left_over_card		       char (210);
dcl p_field		       char (12) parameter;
dcl previous_field_pos	       fixed bin parameter;

	if previous_field_pos = 0 then
	     new_field_pos = 1;			/* First field is what he wants. */
	else new_field_pos = index (substr (rtrim (card), previous_field_pos), " ") + previous_field_pos;
	/*** Skip over whitespace. ***/
	do new_field_pos = new_field_pos repeat new_field_pos + 1 while (substr (rtrim (card), new_field_pos, 1) = " ");
	end;
	left_over_card = substr (rtrim (card), new_field_pos);
	test_field = before (left_over_card, " ");
	if index (rtrim (left_over_card), " ") = 0 then
	     p_last = "1"b;
	else p_last = "0"b;
	if length (rtrim (test_field)) > 12 then
	     p_field = "";
	else p_field = ltrim (test_field);
	return;
     end;

/* format: off */
%page;%include cds_args;
%page;%include config_deck_cards_;
%page;%include config_deck_keywords_;

     end /* config_deck_data_ */;




		    config_deck_parse_.pl1          11/11/89  1103.4r   11/11/89  0803.5      226098



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
config_deck_parse_: proc; return;

/* Routine to convert from ascii to binary forms of config cards with labels.
Extracted from config_deck_edit_, February 1984 by Keith Loepere.
Modified to handle negative numeric fields, December 1984, Keith Loepere. */

/* format: style4,indattr,ifthenstmt,ifthen,idind35,^indcomtxt */

dcl  Bad_decimal_value_a	        fixed bin static options (constant) init (1);
dcl  Bad_decimal_value_a_text	        char (36) static options (constant) init ("^[""^a""^/^;Bad decimal value ""^a""^/^]");
dcl  Bad_octal_value_a	        fixed bin static options (constant) init (2);
dcl  Bad_octal_value_a_text	        char (34) static options (constant) init ("^[""^a""^/^;Bad octal value ""^a""^/^]");
dcl  Card_name_too_long	        fixed bin static options (constant) init (3);
dcl  Card_name_too_long_text	        char (26) static options (constant) init ("^[^;Card name too long^/^]");
dcl  Config_card_name	        (64) char (4);	/* local copy of config_deck_data_$Config_card_name so we can patch last name */
dcl  Field_a_not_defined_or_too_many_supplied_for_card fixed bin static options (constant) init (4);
dcl  Field_a_not_defined_or_too_many_supplied_for_card_text char (66) static options (constant) init ("^[""^a""^/^;Field ""^a"" not defined or too many supplied for card^/^]");
dcl  No_card_type_specified	        fixed bin static options (constant) init (5);
dcl  No_card_type_specified_text      char (30) static options (constant) init ("^[^;No card type specified^/^]");
dcl  No_name_follows_dot	        fixed bin static options (constant) init (6);
dcl  No_name_follows_dot_text	        char (27) static options (constant) init ("^[^;No name follows dot^/^]");
dcl  No_value_for_a		        fixed bin static options (constant) init (7);
dcl  No_value_for_a_text	        char (31) static options (constant) init ("^[""^a""^/^;No value for ""^a""^/^]");
dcl  Some_fields_were_skipped_in_the_card fixed bin static options (constant) init (8);
dcl  Some_fields_were_skipped_in_the_card_text char (44) static options (constant) init ("^[^;Some fields were skipped in the card^/^]");
dcl  Some_required_fields_were_not_supplied fixed bin static options (constant) init (9);
dcl  Some_required_fields_were_not_supplied_text char (46) static options (constant) init ("^[^;Some required fields were not supplied^/^]");
dcl  String_is_more_than_4_characters_a fixed bin static options (constant) init (10);
dcl  String_is_more_than_4_characters_a_text char (51) static options (constant) init ("^[""^a""^/^;String is more than 4 characters ""^a""^/^]");
dcl  Too_many_values_specified_for_card fixed bin static options (constant) init (11);
dcl  Too_many_values_specified_for_card_text char (42) static options (constant) init ("^[^;Too many values specified for card^/^]");
dcl  Value_is_not_a_valid_single_character_a fixed bin static options (constant) init (12);
dcl  Value_is_not_a_valid_single_character_a_text char (56) static options (constant) init ("^[""^a""^/^;Value is not a valid single character ""^a""^/^]");
dcl  Whitespace		        char (5) static options (constant) init ("
	 ");						/* NL HT FF SP VT */
dcl  addcharno		        builtin;
dcl  addr			        builtin;
dcl  ascii_config_card	        char (256) var parameter; /* work area to develop a card */
dcl  1 binary_card		        aligned like config_card;
dcl  card_subname		        char (4);		/* first data field - tells apart prph cards */
dcl  card_type		        fixed bin;
dcl  config_card_field	        fixed bin;		/* loop index into data fields */
dcl  config_card_type	        fixed bin;		/* loop index into types */
dcl  cu_$arg_list_ptr	        entry (ptr);
dcl  cv_dec_check_		        entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_		        entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dimension		        builtin;
dcl  error_detected		        bit (1) aligned;	/* error flagged by conversion routines */
dcl  error_flagged		        (12) bit (1) aligned; /* error message n has been flagged and printed before */
dcl  index		        builtin;
dcl  ioa_			        entry () options (variable);
dcl  ioa_$general_rs	        entry (ptr, fixed bin, fixed bin, char (*), fixed bin (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$nnl		        entry () options (variable);
dcl  ioa_$rsnnl		        entry () options (variable);
dcl  length		        builtin;
dcl  ltrim		        builtin;
dcl  mod			        builtin;
dcl  output_card_num	        fixed bin parameter;	/* used for error messages */
dcl  p_cardp		        ptr parameter;
dcl  rtrim		        builtin;
dcl  search		        builtin;
dcl  silent		        bit (1) aligned;	/* don' print errors */
dcl  substr		        builtin;
dcl  unspec		        builtin;
dcl  verify		        builtin;
%page;
binary_to_ascii: entry (p_cardp, ascii_config_card);

	cardp = p_cardp;
	silent = "1"b;
	error_flagged (*) = "0"b;

/* Make a local copy of names.  Patch the last one to be the
current card to guarantee a match. */

	do card_type = 1 to config_deck_data_$num_described_cards - 1;
	     Config_card_name = config_deck_data_$Config_card_name;
	end;
	Config_card_name (config_deck_data_$num_described_cards) = config_card.word;

	unspec (card_subname) = unspec (config_card.data_field (1));
	do config_card_type = 1 to config_deck_data_$num_described_cards while (^card_matches ());
	end;

	call convert_to_type (config_card_type);

/* arriving here, the card seems to be of a known type and in good form
but the rules may have changed on us.  See what we think of the ascii form.  
If not good, reconvert card as a user format. */

	call config_card_major_parse (ascii_config_card, binary_card, 0, error_detected);
	if error_detected then do;

/* aha, not in format we really like - bad values or number of fields or 
something.  To keep us quiet later, lets make this a user card */

	     call convert_to_type (config_deck_data_$num_described_cards);
	     ascii_config_card = "." || ascii_config_card;
	end;
	return;
%page;
ascii_to_binary: entry (ascii_config_card, p_cardp, output_card_num);

	cardp = p_cardp;
	unspec (config_card) = "0"b;
	silent = "0"b;
	error_flagged (*) = "0"b;

	do card_type = 1 to config_deck_data_$num_described_cards;
	     Config_card_name = config_deck_data_$Config_card_name;
	end;

/* We now have local copy of names.  Later, we patch the last one to be the
current card to guarantee a match. */

	call config_card_major_parse (ascii_config_card, config_card, output_card_num, error_detected);
	return;
%page;
config_card_major_parse: proc (ascii_config_card, binary_card, output_card_num, error_detected);

/* this proc does the major work of parsing the fields into a binary version
of a config card.  It decides which card this is and uses the descriptions
to figure out field names.  The idea here is:
we grab the labeled fields and find the first place in the card that has
such a label (that we haven't filled in with some other value) and place it
there.  The unlabeled values are then added, in order, to the missing
(unfilled) spaces.  Thus, an old style card gets parsed as always and a new
card gets parsed correctly also without having to be able to tell the
difference. */

dcl  NO_TYPE		        bit (2) static options (constant) init ("11"b);
						/* means no type known for field - we use CONFIG_DECIMAL_TYPE 
						since octal type is used for all generic numeric */
dcl  ascii_config_card	        char (256) var parameter;
dcl  1 binary_card		        aligned like config_card parameter; /* output binary version */
dcl  binary_field_num	        fixed bin;		/* which field in binary config_card we are considering */
dcl  card_name		        char (4);		/* as in mem, iom, etc */
dcl  card_type		        fixed bin;		/* index into card descriptions */
dcl  dont_interpret		        bit (1) aligned;	/* => pretend card is of type USER */
dcl  error_detected		        bit (1) aligned parameter;
dcl  filled_field		        (14) bit (1);	/* => we found a value for corresponding field */
dcl  labeled_field_num	        fixed bin;		/* which we are adding now */
dcl  1 labeled_fields	        aligned,		/* list of the fields that had -labels and their values */
       2 number		        fixed bin,
       2 field		        (16),		/* 14 is really the max */
         3 label		        char (16) var,
         3 value		        char (16) var;
dcl  output_card_num	        fixed bin parameter;	/* for error messages */
dcl  unlabeled_field_num	        fixed bin;		/* which we are adding now */
dcl  1 unlabeled_fields	        aligned,		/* list of fields that had no value */
       2 number		        fixed bin,
       2 value		        (16) char (16) var;

	error_detected = "0"b;
	call separate_config_card_fields (ascii_config_card, unlabeled_fields, labeled_fields);
	if unlabeled_fields.number = 0 then do;
	     call error (No_card_type_specified, No_card_type_specified_text, error_flagged (No_card_type_specified));
	     return;
	end;
	if substr (unlabeled_fields.value (1), 1, 1) = "." then do;
	     dont_interpret = "1"b;			/* .name becomes a user formatted name card */
	     unlabeled_fields.value (1) = substr (unlabeled_fields.value (1), 2);
	     if length (unlabeled_fields.value (1)) < 1 then call error (No_name_follows_dot, No_name_follows_dot_text, error_flagged (No_name_follows_dot));
	end;
	else dont_interpret = "0"b;
	if length (unlabeled_fields.value (1)) > 4 then call error (Card_name_too_long, Card_name_too_long_text, error_flagged (Card_name_too_long));
	card_name = unlabeled_fields.value (1);
	Config_card_name (config_deck_data_$num_described_cards) = card_name;
						/* synthesize, as a last hope, a card type of what the user said */
	if dont_interpret then card_type = config_deck_data_$num_described_cards;
	else
	     do card_type = 1 to config_deck_data_$num_described_cards while (^card_matches ());
	end;
%page;

/* now we actually convert the fields as appropriate */

	binary_card.word = card_name;
	binary_card.data_field (*) = EMPTY_FIELD;
	filled_field (*) = "0"b;
	binary_card.pad1 = "0"b;

	do labeled_field_num = 1 to labeled_fields.number;/* for labeled fields */
	     do binary_field_num = 1 to config_deck_data_$Config_card_num_described_fields (card_type); /* pick up those that are described */
		if ^filled_field (binary_field_num) then
		     if config_deck_data_$Config_card_field_name (card_type, binary_field_num) = labeled_fields.label (labeled_field_num) then do;
						/* we found an unfilled field of desired name */
			call cv_value (labeled_fields.value (labeled_field_num), config_deck_data_$Config_card_field_type (card_type, binary_field_num));
			filled_field (binary_field_num) = "1"b;
			go to next_labeled;
		     end;
	     end;
	     call error (Field_a_not_defined_or_too_many_supplied_for_card, Field_a_not_defined_or_too_many_supplied_for_card_text, error_flagged (Field_a_not_defined_or_too_many_supplied_for_card), labeled_fields.label (labeled_field_num)); /* ran out of fields with known labels */
next_labeled:
	end;

/* consider now the unlabeled fields - fill in missing spaces */
	binary_field_num = 1;
	do unlabeled_field_num = 2 to unlabeled_fields.number;
	     do binary_field_num = binary_field_num to 14 while (filled_field (binary_field_num)); end; /* find an unfilled field */
	     if binary_field_num > 14 then do;
		call error (Too_many_values_specified_for_card, Too_many_values_specified_for_card_text, error_flagged (Too_many_values_specified_for_card)); /* ran off end */
		go to validate_card;
	     end;
	     if binary_field_num <= config_deck_data_$Config_card_num_described_fields (card_type) then
		call cv_value (unlabeled_fields.value (unlabeled_field_num), config_deck_data_$Config_card_field_type (card_type, binary_field_num)); /* known type */
	     else call cv_value (unlabeled_fields.value (unlabeled_field_num), NO_TYPE); /* user supplied type */
	     filled_field (binary_field_num) = "1"b;
	end;
%page;
validate_card:

/* now we know that those fields that were are described have good types
and values are in order.  labeled fields, though, may have skipped a value.
Let's see. */

	do binary_field_num = 1 to 14 while (filled_field (binary_field_num));
	end;					/* field number past last contiguous field in */
	binary_card.n_fields = binary_field_num - 1;
	do binary_field_num = binary_field_num + 1 to 14 while (^filled_field (binary_field_num));
	end;
	if binary_field_num <= 14 then		/* we found a filled field after unfilled fields */
	     call error (Some_fields_were_skipped_in_the_card, Some_fields_were_skipped_in_the_card_text, error_flagged (Some_fields_were_skipped_in_the_card));
	if binary_card.n_fields < config_deck_data_$Config_card_min_specifiable_fields (card_type) then
	     call error (Some_required_fields_were_not_supplied, Some_required_fields_were_not_supplied_text, error_flagged (Some_required_fields_were_not_supplied));
	else if config_deck_data_$Config_card_group_length (card_type) > 0 then
	     if mod (binary_card.n_fields - config_deck_data_$Config_card_min_specifiable_fields (card_type), config_deck_data_$Config_card_group_length (card_type)) ^= 0 then /* card ends in repeating groups but last group was not filled */
		call error (Some_required_fields_were_not_supplied, Some_required_fields_were_not_supplied_text, error_flagged (Some_required_fields_were_not_supplied));

/* we can now perform specific to card validations */
	return;
%page;
card_matches: proc () returns (bit (1) aligned);

/* determine if this card_type describes the given card */

dcl  field		        fixed bin;

	     if card_name ^= Config_card_name (card_type) then return ("0"b);
	     if length (config_deck_data_$Config_card_subname (card_type)) = 0 then return ("1"b); /* card name alone describes */
	     do field = 1 to labeled_fields.number;	/* see if a labeled field is of type and value for this card type's subname */
		if labeled_fields.label (field) = config_deck_data_$Config_card_field_name (card_type, 1) then /* right label */
		     if index (labeled_fields.value (field), config_deck_data_$Config_card_subname (card_type)) = 1 then return ("1"b);
						/* value of labeled field is begun by desired card subname */
		     else return ("0"b);
	     end;
						/* no labeled field matches subname - maybe the second unlabeled one does */
	     if unlabeled_fields.number > 1 then
		if index (unlabeled_fields.value (2), config_deck_data_$Config_card_subname (card_type)) = 1 then return ("1"b);
						/* labeled field does start as desired */
		else return ("0"b);
	     else return ("0"b);
	end;
%page;
cv_value: proc (value, type);

/* we convert the char string to a config card field value, using the type
suggested or guessing one if type = NO_TYPE */
dcl  code			        fixed bin (35);
dcl  numeric		        fixed bin (35) aligned; /* area to form numeric types */
dcl  string		        char (4) aligned;	/* area to form string type */
dcl  type			        bit (2) parameter;	/* type expected */
dcl  value		        char (16) var parameter; /* value to convert */

	     if type = CONFIG_OCTAL_TYPE | type = NO_TYPE then do; /* any numeric value */
		if substr (value, length (value), 1) = "." then do; /* looks like decimal numeric */
		     numeric = cv_dec_check_ (substr (value, 1, length (value) - 1), code);
		     if code ^= 0 then do;
			if type = NO_TYPE then go to is_it_octal; /* give another chance */
			call error (Bad_decimal_value_a, Bad_decimal_value_a_text, error_flagged (Bad_decimal_value_a), value);
			call cv_value (value, NO_TYPE); /* use type it seems to be */
		     end;
		     else do;
			unspec (binary_card.data_field (binary_field_num)) = unspec (numeric);
			binary_card.field_type (binary_field_num) = CONFIG_DECIMAL_TYPE;
		     end;
		end;
		else do;				/* numeric but not decimal => octal */
is_it_octal:
		     numeric = cv_oct_check_ ((value), code);
		     if code ^= 0 then do;
			if type = NO_TYPE then go to is_it_a_char;
			call error (Bad_octal_value_a, Bad_octal_value_a_text, error_flagged (Bad_octal_value_a), value);
			call cv_value (value, NO_TYPE); /* believe user format */
		     end;
		     else do;
			unspec (binary_card.data_field (binary_field_num)) = unspec (numeric);
			binary_card.field_type (binary_field_num) = CONFIG_OCTAL_TYPE;
		     end;
		end;
	     end;
	     else if type = CONFIG_SINGLE_CHAR_TYPE then do;
is_it_a_char:					/* maybe it's a single char field */
		numeric = index ("abcdefgh", value);
		if length (value) ^= 1 | numeric = 0 then do;
		     if type = NO_TYPE then go to is_it_a_string;
		     call error (Value_is_not_a_valid_single_character_a, Value_is_not_a_valid_single_character_a_text, error_flagged (Value_is_not_a_valid_single_character_a), value);
		     call cv_value (value, NO_TYPE);
		end;
		else do;
		     unspec (binary_card.data_field (binary_field_num)) = unspec (numeric);
		     binary_card.field_type (binary_field_num) = CONFIG_SINGLE_CHAR_TYPE;
		end;
	     end;
	     else if type = CONFIG_STRING_TYPE then do;
is_it_a_string:					/* last hope, a char string */
		if length (value) > 4 then
		     call error (String_is_more_than_4_characters_a, String_is_more_than_4_characters_a_text, error_flagged (String_is_more_than_4_characters_a), value);
		string = value;
		unspec (binary_card.data_field (binary_field_num)) = unspec (string);
		binary_card.field_type (binary_field_num) = CONFIG_STRING_TYPE;
	     end;
	     return;
	end;
%page;
error:	proc options (variable);

dcl  arg_list_ptr		        ptr;
dcl  arg1_ptr		        ptr;
dcl  arg3_ptr		        ptr;
dcl  error_flagged		        bit (1) aligned based (arg3_ptr);
dcl  error_num		        fixed bin based (arg1_ptr);
dcl  message_buffer		        char (256);
dcl  message_len		        fixed bin (21);
dcl  message_to_print	        char (message_len) based (addr (message_buffer));

	     call cu_$arg_list_ptr (arg_list_ptr);
	     arg1_ptr = arg_list_ptr -> arg_list.arg_ptrs (1);
	     arg3_ptr = arg_list_ptr -> arg_list.arg_ptrs (3);
	     if ^silent then do;
		call ioa_ ("^/WARNING ^d ON LINE ^d", error_num, output_card_num);
		call ioa_$general_rs (arg_list_ptr, 2, 3, message_buffer, message_len, "0"b, "0"b);
		call ioa_$nnl (message_to_print);
		if ^error_detected then call ioa_ ("SOURCE: ^a", ascii_config_card);
	     end;
	     error_flagged = "1"b;
	     error_detected = "1"b;
	     return;
	end;
%page;
separate_config_card_fields: proc (input_card, a_unlabeled_fields, a_labeled_fields);

/* this proc separates out the fields in the card.  It makes a list of all
fields that had no -label, and separately those that did.  -labels with no
following value are tossed away.  */

dcl  1 a_labeled_fields	        aligned like labeled_fields parameter;
dcl  1 a_unlabeled_fields	        aligned like unlabeled_fields parameter;
dcl  card_pos		        fixed bin;		/* position to end of field we are surveying */
dcl  input_card		        char (256) var parameter;
dcl  label		        char (16) var;	/* extracted from card */
dcl  temp_card		        char (256) init (input_card); /* work area */
dcl  work_card		        char (work_card_len) based (work_card_ptr); /* rest of card to look at */
dcl  work_card_len		        fixed bin;
dcl  work_card_ptr		        ptr;

	     work_card_len = length (input_card);
	     work_card_ptr = addr (temp_card);		/* start looking at whole card */
	     a_unlabeled_fields.number = 0;
	     a_labeled_fields.number = 0;
	     call pass_whitespace;
	     do while (work_card_len > 0);

/* loop, grabbing each field (or pair if labeled) and add to appropriate list */
		card_pos = search (work_card, Whitespace) - 1; /* length of field */
		if card_pos < 0 then card_pos = work_card_len;
		if substr (work_card, 1, 1) = "-" then do; /* labeled field */
		     label = substr (work_card, 1, card_pos);
		     if verify (label, "-0123456789.") = 0 then go to unlabeled;
		     work_card_len = work_card_len - card_pos;
		     work_card_ptr = addcharno (work_card_ptr, card_pos);
		     call pass_whitespace;
		     if work_card_len = 0 then	/* last field on card and no value follows */
			call error (No_value_for_a, No_value_for_a_text, error_flagged (No_value_for_a), label);
		     else do;			/* valid labeled field */
			card_pos = search (work_card, Whitespace) - 1;
			if card_pos < 0 then card_pos = work_card_len;
			if a_labeled_fields.number < dimension (a_labeled_fields.field, 1) then do;
			     a_labeled_fields.number = a_labeled_fields.number + 1;
			     a_labeled_fields.field (a_labeled_fields.number).label = label;
			     a_labeled_fields.field (a_labeled_fields.number).value = substr (work_card, 1, card_pos);
			end;
			else ;			/* no need for error on too many fields - we already
	have too many and someone will notice */
		     end;
		end;
		else do;				/* unlabeled field */
unlabeled:	     if a_unlabeled_fields.number < dimension (a_unlabeled_fields.value, 1) then do;
			a_unlabeled_fields.number = a_unlabeled_fields.number + 1;
			a_unlabeled_fields.value (a_unlabeled_fields.number) = substr (work_card, 1, card_pos);
		     end;
		     else ;			/* no error like above.  By the way, we also don't need to check
	for strings too long for a similar reason */
		end;
		work_card_len = work_card_len - card_pos; /* advance past fields */
		work_card_ptr = addcharno (work_card_ptr, card_pos);
		call pass_whitespace;
	     end;
	     return;

pass_whitespace: proc;

		card_pos = verify (work_card, Whitespace) - 1;
		if card_pos < 0 then card_pos = work_card_len;
		work_card_len = work_card_len - card_pos;
		work_card_ptr = addcharno (work_card_ptr, card_pos);
		card_pos = 0;
		return;
	     end;
	end;
     end;
%page;
card_matches: proc () returns (bit (1) aligned);

/* does card_type describe this card */
	if Config_card_name (config_card_type) ^= config_card.word then return ("0"b); /* card name doesn't even match */
	if config_deck_data_$Config_card_subname (config_card_type) = "" then return ("1"b); /* no subname match needed */
	if index (card_subname, config_deck_data_$Config_card_subname (config_card_type)) = 1 then return ("1"b); /* subname matches desired */
	return ("0"b);
     end;
%page;
convert_to_type: proc (config_card_type);

/* we convert the current config card into ascii_config_card for the given type */
dcl  config_card_type	        fixed bin parameter;	/* index into descriptions */
	ascii_config_card = rtrim (config_card.word) || " ";
	do config_card_field = 1 to config_deck_data_$Config_card_min_specifiable_fields (config_card_type); /* grab these many no matter what they say */
	     ascii_config_card = ascii_config_card || config_deck_data_$Config_card_field_name (config_card_type, config_card_field) || " ";
	     call add_value;
	end;

	do config_card_field = config_deck_data_$Config_card_min_specifiable_fields (config_card_type) + 1 to 14 while (config_card.data_field (config_card_field) ^= EMPTY_FIELD);
						/* convert the rest of the fields until we run out */
	     if config_card_field <= config_deck_data_$Config_card_num_described_fields (config_card_type) then /* we know the name for this field */
		ascii_config_card = ascii_config_card || config_deck_data_$Config_card_field_name (config_card_type, config_card_field) || " ";
						/* unknown field name */
	     call add_value;
	end;
%page;
add_value: proc;

/* convert the value to ascii and add to ascii_config_card */
dcl  numeric		        fixed bin (35) aligned; /* overlay for numeric types */
dcl  string		        char (4) aligned;	/* overlay for string type */
dcl  value		        char (16) var;	/* converted result */
	     if config_card.field_type (config_card_field) = CONFIG_OCTAL_TYPE then do;
		unspec (numeric) = unspec (config_card.data_field (config_card_field));
		call ioa_$rsnnl ("^o", value, (0), numeric);
	     end;
	     else if config_card.field_type (config_card_field) = CONFIG_DECIMAL_TYPE then do;
		unspec (numeric) = unspec (config_card.data_field (config_card_field));
		call ioa_$rsnnl ("^d.", value, (0), numeric);
	     end;
	     else if config_card.field_type (config_card_field) = CONFIG_STRING_TYPE then do;
		unspec (string) = unspec (config_card.data_field (config_card_field));
		value = ltrim (rtrim (string));
	     end;
	     else /* CONFIG_SINGLE_CHAR_TYPE */ do;
		unspec (numeric) = unspec (config_card.data_field (config_card_field));
		if numeric < 1 | numeric > 8 then value = "*";
		else value = substr ("abcdefgh", numeric, 1);
	     end;
	     ascii_config_card = ascii_config_card || value || " ";
	end;
     end;
%page; %include arg_list;
%page; %include config_deck;
%page; %include config_deck_data_;
     end;




		    cp_data_.cds                    11/11/89  1103.4r   11/11/89  0803.7       44109



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

						/* format: off */

/* Static and constant data used by the Multics command processor */

/* Created:  January 1981 by Ellie Donner */
/* Modified: June 1982 by G. Palter to add standard command language definition */
/* Modified: July 1984 by G. Palter to add the permanent scratch segment list */
/* Modified: March 1985 by Keith Loepere so that it can reside within bound_multics_bce_. */

/* format: on,style4,delnl,insnl,ifthenstmt,ifthen */
%page;

cp_data_:
     procedure () options (variable);

dcl  1 cp_constants aligned,				/* constant data: see cp_data_.incl.pl1 for details */
       2 standard_language (0:511) fixed binary (9) unaligned unsigned;

dcl  1 cp_static aligned,				/* static data: see cp_data_.incl.pl1 for details */
       2 command_table_ptr pointer,
       2 under_lss bit (1) aligned,
       2 scratch_lock_id fixed binary (35),
       2 scratch_release_factor fixed binary,
       2 permanent_scratch_segment_list,
         3 n_scratch_segments fixed binary,
         3 scratch_segments (4),
	 4 segment_ptr pointer,
	 4 lock bit (36) aligned,
	 4 usage_count fixed binary;

dcl  1 cds_arguments aligned like cds_args;

dcl  code fixed binary (35);

dcl  CP_DATA_ character (8) static options (constant) initial ("cp_data_");

/* format: off */
dcl (SPACE	initial (" "),
     HT		initial ("	"),		/* horizontal tab */
     VT		initial (""),			/* veritcal tab */
     FF		initial (""),						/* form feed */
     NL		initial ("
"))						/* new line */
	character (1) static options (constant);
/* format: on */

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

dcl  (addr, currentsize, null, rank, string) builtin;
%page;

/* Define the standard command language */

	cp_constants.standard_language (*) = NORMAL_CHARACTER;
						/* start out by declaring all characters to be normal */

	cp_constants.standard_language (rank (SPACE)) = WHITESPACE;
	cp_constants.standard_language (rank (HT)) = WHITESPACE;
	cp_constants.standard_language (rank (VT)) = WHITESPACE;
	cp_constants.standard_language (rank (FF)) = WHITESPACE;

	cp_constants.standard_language (rank (";")) = COMMAND_SEPARATOR;

	cp_constants.standard_language (rank (NL)) = COMMAND_SEPARATOR_OR_WHITESPACE;

	cp_constants.standard_language (rank ("""")) = QUOTE_CHARACTER;

	cp_constants.standard_language (rank ("(")) = BEGIN_ITERATION_1;
	cp_constants.standard_language (rank (")")) = END_ITERATION_1;

	cp_constants.standard_language (rank ("[")) = BEGIN_ACTIVE_STRING_1;
	cp_constants.standard_language (rank ("]")) = END_ACTIVE_STRING_1;
	cp_constants.standard_language (rank ("|")) = ACTIVE_STRING_MODIFIER;


/* Setup constants and static data related to scratch segment management */

	cp_static.scratch_release_factor = 1000;	/* release "permanement" scratch segments every 1000 uses */

	cp_static.scratch_lock_id = 0;

	cp_static.permanent_scratch_segment_list.n_scratch_segments = 4;
	cp_static.permanent_scratch_segment_list.scratch_segments (*).segment_ptr = null ();
	cp_static.permanent_scratch_segment_list.scratch_segments (*).lock = ""b;
	cp_static.permanent_scratch_segment_list.scratch_segments (*).usage_count = 0;


/* Supply initial values for the remaining static data */

	cp_static.under_lss = "0"b;			/* no restriction on commands that may be executed */
	cp_static.command_table_ptr = null ();


/* Fill in CDS description and create the data segment */

	cds_arguments.sections (1).p = addr (cp_constants);
	cds_arguments.sections (1).len = currentsize (cp_constants);
	cds_arguments.sections (1).struct_name = "cp_constants";

	cds_arguments.sections (2).p = addr (cp_static);
	cds_arguments.sections (2).len = currentsize (cp_static);
	cds_arguments.sections (2).struct_name = "cp_static";

	cds_arguments.seg_name = CP_DATA_;
	cds_arguments.num_exclude_names = 0;
	cds_arguments.exclude_array_ptr = null ();

	string (cds_arguments.switches) = "0"b;
	cds_arguments.switches.have_text = "1"b;
	cds_arguments.switches.have_static = "1"b;

	cds_arguments.switches.separate_static = "1"b;

	call create_data_segment_ (addr (cds_arguments), code);
	if code ^= 0 then call com_err_ (CP_DATA_, code);

	return;
%page;
%include cp_character_types;
%page;
%include cds_args;

     end;




		    display_disk_label_.pl1         11/11/89  1103.4rew 11/11/89  0803.7       51831



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

display_disk_label_:
     proc (p_labelp);

/* format: style4,initcol1,indattr,declareind8,dclind4,idind35,ifthenstmt,ifthen,^indproc,delnl,insnl */

/**** Written August of 1984 by Allen Ball to display a valid disk label in readable format for display_disk_label and
      bce_display_disk_label. ****/

/****^  HISTORY COMMENTS:
  1) change(86-01-16,Fawcett), approve(86-04-11,MCR7383),
     audit(86-05-14,Farley), install(86-07-17,MR12.0-1097):
     Add support for subvolumes, and 512_WORD_IO, 3380 and 3390.
  2) change(88-04-12,GWMay), approve(88-04-12,MCR7867),
     audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061):
     Changed to display in octal and decminal.  Changed to interpret access
     class.
  3) change(88-05-27,GWMay), approve(88-05-27,MCR7883),
     audit(88-06-14,Beattie), install(88-07-19,MR12.2-1061):
     Changed to display the status of volume dumper bit maps.
                                                   END HISTORY COMMENTS */

	labelp = p_labelp;
	call ioa_ ("PVID^-^-^oo", label.pvid);
	call ioa_ ("Serial^-^-^a", label.mfg_serial);
	call ioa_ ("Logical Volume^-^a", label.lv_name);
	call ioa_ ("LVID^-^-^oo^/", label.lvid);
	if label.number_of_sv ^= 0 then
	     call ioa_ ("Subvolume ^a ^d of ^d", label.sub_vol_name, label.this_sv + 1, label.number_of_sv);
	call ioa_ ("Registered^-^a", cv_time (label.time_registered));
	call ioa_ ("Dismounted^-^a", cv_time (label.time_unmounted));
	call ioa_ ("Map Updated^-^a", cv_time (label.time_map_updated));
	call ioa_ ("Salvaged^-^-^a", cv_time (label.time_salvaged));
	call ioa_ ("Bootload^-^-^a", cv_time (label.time_of_boot));
	call ioa_ ("Reloaded^-^-^a", cv_time (label.time_last_reloaded));
	call ioa_ ("
Dumped
  Incremental^-^[^a^;Never Been Dumped^s^]
  Consolidated^-^[^a^;Never Been Dumped^s^]
  Complete^-^[^a^;Never Been Dumped^s^]", label.time_last_dmp (Incremental) ^= 0,
	     cv_time (label.time_last_dmp (Incremental)), label.time_last_dmp (Consolidated) ^= 0,
	     cv_time (label.time_last_dmp (Consolidated)), label.time_last_dmp (Complete) ^= 0,
	     cv_time (label.time_last_dmp (Complete)));

	call ioa_ ("
The volume dumper bit maps located in the label are ^[NOT ^]consistent.", label.inconsistent_dbm);

	call ioa_ ("^/Inconsistencies^-^-^d", label.vol_trouble_count);

	if sys_info$service_system then do;
	     call convert_access_class_$to_string_short (label.min_access_class, access_string, code);
	     call ioa_ ("^/Minimum AIM^-^-^a (^[^[system_low^s^;<UNNAMED>^s^]^;^s^a^])",
		display_access_class_ (label.min_access_class), access_string = "", code = 0, access_string);
	     call convert_access_class_$to_string_short (label.max_access_class, access_string, code);
	     call ioa_ ("Maximum AIM^-^-^a (^[^[system_low^s^;<UNNAMED>^s^]^;^s^a^])",
		display_access_class_ (label.max_access_class), access_string = "", code = 0, access_string);
	end;
	else do;
	     call ioa_ ("^/Minimum AIM^-^-^a", display_access_class_ (label.min_access_class));
	     call ioa_ ("Maximum AIM^-^-^a", display_access_class_ (label.max_access_class));
	end;

	if label.root.here then do;
	     call ioa_ ("^/Volume contains root (>) at vtocx ^d (^oo)", label.root_vtocx, label.root_vtocx);
	     call ioa_ ("  disk_table_ at vtocx ^d (^oo) (uid ^wo)", label.root.disk_table_vtocx,
		label.root.disk_table_vtocx, label.root.disk_table_uid);
	end;
	if label.nparts > 0 then do;
	     call ioa_ ("^/Volume Map from Label");
	     call ioa_ ("
   First Record             Size");
	     do parts_index = 1 to label.nparts;
		call ioa_ ("^8d (^oo)^22t^8d (^oo)^51t^4a Partition", label.parts (parts_index).frec,
		     label.parts (parts_index).frec, label.parts (parts_index).nrec, label.parts (parts_index).nrec,
		     label.parts (parts_index).part);
	     end;
	end;
	return;

%page;
cv_time:
     proc (date_time) returns (char (*));

dcl date_time		         fixed bin (71);
dcl date_time_string	         char (24);
dcl length		         builtin;
dcl substr		         builtin;

	if date_time = 0 then
	     return ("");
	else do;
	     date_time_string = date_time_$format ("date_time", date_time, "", "");
	     if substr (date_time_string, 1, length (Null_date_time)) = Null_date_time then
		return ("");
	     else return (date_time_string);
	end;
     end;
%page;

dcl access_string		         char (32);

dcl code			         fixed bin (35);

dcl Consolidated		         fixed bin static options (constant) init (2);
dcl Complete		         fixed bin static options (constant) init (3);
dcl Incremental		         fixed bin static options (constant) init (1);
dcl Null_date_time		         char (16) static options (constant) init ("01/01/01  0000.0");
dcl sys_info$service_system	         bit (1) aligned ext static;

dcl convert_access_class_$to_string_short
			         entry (bit (72) aligned, char (*), fixed bin (35));
dcl date_time_$format	         entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl display_access_class_	         entry (bit (72) aligned) returns (char (32) aligned);
dcl ioa_			         entry () options (variable);
dcl p_labelp		         pointer parameter;
dcl parts_index		         fixed bin;		/* format: ^insnl */
%page; %include aim_template;
%page; %include fs_vol_label;

     end display_disk_label_;




		    equal.pl1                       11/11/89  1103.4r   11/11/89  0803.7       63333



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


equal: proc;

/* Comparison and boolean active functions.

   The following functions compare arbitrary strings by collating sequence:

	equal A B		"true" if A = B, "false" otherwise.
	less A B		"true" if A < B, "false" otherwise.
	greater A B	"true" if A > B, "false" otherwise.

   The following compare numbers; an error is reported if both arguments are
   not character string representations of valid PL/I real constants.
   Comparisons are done using float dec (59) arithmetic.

	nequal A B	"true" if A = B, "false" otherwise.
	nless A B		"true" if A < B, "false" otherwise.
	ngreater A B	"true" if A > B, "false" otherwise.

   The following perform logical operations on arguments having the
   values true and false:

	not A		"true" if A = "false", "false" if A = "true".
	and A1 A2 ... An	"true" if all Ai are "true", "false" otherwise.
	or A1 A2 ... An	"true" if any Ai is "true", "false" otherwise.

   All of these active functions print their result when called as commands.

 Initial version 3/4/74 by Barry L. Wolman */
/* Time comparison functions added 11/28/78 by Jim Homan */
/* Rewritten 01/18/80 by S. Herbst */
/* Bug fixed in time comparisons 04/14/80 S. Herbst */
/* Changed and, or to accept 0 args or 1 arg 09/16/82 S. Herbst */
/* Added -date to date_time comparison commands 10/26/82 S. Herbst */
/* Fixed dteq and friends to not reject negative times 11/23/82 S. Herbst */
/* Added the date_time_valid function 11/23/82 J. A. Bush */
/* removed a portion, creating date_time_equal.pl1 02/07/84 J A Falksen */

	dcl     arg1		 char (arg_len (1)) based (arg_ptr (1));
	dcl     arg2		 char (arg_len (2)) based (arg_ptr (2));

	dcl     return_arg		 char (return_len) varying based (return_ptr);

	dcl     (bad_arg, usage)	 char (168);
	dcl     myname		 char (32);

	dcl     arg_ptr		 (2) ptr;
	dcl     return_ptr		 ptr;

	dcl     (af_sw, bool_value)	 bit (1);

	dcl     (number1, number2)	 float dec (59);

	dcl     arg_len		 (2) fixed bin;
	dcl     (arg_count, i, return_len) fixed bin;
	dcl     code		 fixed bin (35);

	dcl     error_table_$not_act_fnc fixed bin (35) ext;

	dcl     get_arg		 entry (fixed bin, ptr, fixed bin, fixed bin (35))automatic;
	dcl     complain		 entry variable options (variable);

	dcl     (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
	dcl     (com_err_, com_err_$suppress_name) entry options (variable);
	dcl     cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     cu_$af_arg_ptr	 entry (fixed bin, ptr, fixed bin, fixed bin (35));
	dcl     ioa_		 entry options (variable);

	dcl     convert		 builtin;

	dcl     conversion		 condition;
						/**/
	myname = "equal";
	usage = "string1 string2";

	call get_args;

	if arg1 = arg2 then go to TRUE;
	else go to FALSE;


TRUE:	if af_sw then return_arg = "true";
	else call ioa_ ("true");
	return;

FALSE:	if af_sw then return_arg = "false";
	else call ioa_ ("false");
	return;

USAGE:	if af_sw then call active_fnc_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);
	else call com_err_$suppress_name (0, myname, "Usage:  ^a ^a", myname, usage);

RETURN:	return;


less: entry;

	myname = "less";
	usage = "string1 string2";

	call get_args;

	if arg1 < arg2 then go to TRUE;
	else go to FALSE;


greater: entry;

	myname = "greater";
	usage = "string1 string2";

	call get_args;

	if arg1 > arg2 then go to TRUE;
	else go to FALSE;


nequal: entry;

	myname = "nequal";
	usage = "num1 num2";

	call get_args;
	call convert_numbers;

	if number1 = number2 then go to TRUE;
	else go to FALSE;


nless: entry;

	myname = "nless";
	usage = "num1 num2";

	call get_args;
	call convert_numbers;

	if number1 < number2 then go to TRUE;
	else go to FALSE;


ngreater: entry;

	myname = "ngreater";
	usage = "num1 num2";

	call get_args;
	call convert_numbers;

	if number1 > number2 then go to TRUE;
	else go to FALSE;

and: entry;

	myname = "and";
	usage = "true_false_args";

	call get_count;
	if arg_count = 0 then bool_value = "1"b;	/* and-identity */
	else bool_value = get_boolean (1);
	do i = 2 to arg_count;
	     bool_value = bool_value & get_boolean (i);
	end;

	if bool_value then go to TRUE;
	else go to FALSE;


or:  entry;

	myname = "or";
	usage = "true_false_args";

	call get_count;
	if arg_count = 0 then bool_value = "0"b;	/* or-identity */
	else bool_value = get_boolean (1);
	do i = 2 to arg_count;
	     bool_value = bool_value | get_boolean (i);
	end;

	if bool_value then go to TRUE;
	else go to FALSE;


not: entry;

	myname = "not";
	usage = "true_or_false";

	call get_count;
	if arg_count ^= 1 then go to USAGE;
	if get_boolean (1) then go to FALSE;
	else go to TRUE;
						/**/
get_count: proc;

/* This internal procedure tests for af invocation and gets argument count. */

	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);

	if code = error_table_$not_act_fnc then do;
		af_sw = "0"b;
		complain = com_err_;
		get_arg = cu_$arg_ptr;
	     end;
	else do;
		af_sw = "1"b;
		complain = active_fnc_err_;
		get_arg = cu_$af_arg_ptr;
	     end;

     end get_count;



get_args: proc;

/* This internal procedure gets two arguments. */

	dcl     j			 fixed bin;

	call get_count;

	j = 0;

	if arg_count ^= 2 then go to USAGE;
	call get_arg (1, arg_ptr (1), arg_len (1), code);
	call get_arg (2, arg_ptr (2), arg_len (2), code);

     end get_args;



get_boolean: proc (arg_index) returns (bit (1) aligned);

/* This internal procedure gets a single true or false argument. */

	dcl  arg_index		 fixed bin;

	call get_arg (arg_index, arg_ptr (1), arg_len (1), code);

	if arg1 = "true" then return ("1"b);
	else if arg1 = "false" then return ("0"b);
	else do;
		call complain (0, myname, "Must be true or false, not ""^a""", arg1);
		go to RETURN;
	     end;

     end get_boolean;
						/**/
convert_numbers: proc;

/* This internal procedure converts both arguments to real numbers. */

	on conversion begin;
		bad_arg = arg1;
		go to BAD;
	     end;
	number1 = convert (number1, arg1);
	revert conversion;

	on conversion begin;
		bad_arg = arg2;
		go to BAD;
	     end;
	number2 = convert (number2, arg2);
	revert conversion;

	return;

BAD:	call complain (0, myname, "Invalid number ^a", bad_arg);
	go to RETURN;

     end convert_numbers;



     end equal;




		    find_command_.pl1               11/11/89  1103.4rew 11/11/89  0803.7      156420



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */





/****^  HISTORY COMMENTS:
  1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
     audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
     Modified to call object_lib_$initiate to initiate segments and object MSFs
     when executing commands specified by pathname.
                                                   END HISTORY COMMENTS */


/* This subroutine interprets a character string as the name of an entrypoint and returns a pointer to that entry.  It is
   intended to be called by command processors to find commands and active functions.

   An associative memory of recently used commands is maintained in order to avoid using the linker when possible */

/* Initial coding:  December 1969 by R. C. Daley */
/* Rewritten:  August 1978 by G. Palter to eliminate past changes made for fast command loop */
/* Modified:  8 May 1980 by G. Palter to fix metering to avoid calling hcs_$make_ptr if metering is not enabled when first
   invoked */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
find_command_:
     procedure (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code);


/* Parameters */

dcl  a_input_name_ptr pointer;			/* -> input string to interpret */
dcl  a_input_name_lth fixed binary (21);		/* length of same */
dcl  a_entrypoint_ptr pointer;			/* -> entrypoint found (Output) */
dcl  a_code fixed binary (35);

dcl  a_input_name character (a_input_name_lth) based (a_input_name_ptr);


/* Remaining declarations */

dcl  input_name character (input_name_lth) based (input_name_ptr);
dcl  input_name_ptr pointer;
dcl  input_name_lth fixed binary (21);

dcl  (
     pathname_sw,					/* ON if pathname used */
     entrypoint_sw,					/* ON if entrypoint given */
     print_sw
     ) bit (1) aligned;				/* ON if should prin errors */

dcl  full_name character (256) varying;			/* complete name given */
dcl  1 full_name_value aligned based (addr (full_name)),
       2 lth fixed binary (21),
       2 str character (0 refer (full_name_value.lth)) unaligned;

dcl  directory_name character (168);			/* directory supplied (if any) */
dcl  segment_name character (32);			/* segment name given */
dcl  entrypoint_name character (32);			/* entrypoint suplied or "segment_name" */

dcl  code fixed binary (35);
dcl  segment_ptr pointer;
dcl  (am_idx, idx) fixed binary;


/* The associative memory */

dcl  1 memory aligned internal static,
       2 e (0:15),					/* 16 entries */
         3 name character (32) initial ((16) ("")),
         3 entrypoint_ptr pointer initial ((16) null ()),	/* -> entry for this name */
         3 usage fixed binary initial ((16) 0);		/* least-recently used counter */

dcl  HIT fixed binary static options (constant) initial (16);
						/* usage counter of just used entry */


dcl  SPACES character (2) static options (constant) initial (" 	");
						/* SP HT */
dcl  BREAKS character (3) static options (constant) initial ("<>$");

dcl  NAME character (18) static options (constant) initial ("command_processor_");
dcl  BlankCommand character (19) static options (constant) initial ("Blank command name.");
dcl  SegNotFound character (21) static options (constant) initial ("Segment ^a not found.");
dcl  NoEntryPoint character (39) static options (constant) initial ("Entry point ^a not found in segment ^a.");

dcl  (
     error_table_$bad_command_name,
     error_table_$badpath,
     error_table_$dirseg,
     error_table_$entlong,
     error_table_$namedup,
     error_table_$no_ext_sym,
     error_table_$noentry,
     error_table_$seg_not_found
     ) fixed binary (35) external;

dcl  (
     com_err_,
     com_err_$suppress_name
     ) entry () options (variable);
dcl  continue_to_signal_ entry (fixed binary (35));
dcl  find_condition_info_ entry (pointer, pointer, fixed binary (35));
dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
dcl  get_group_id_$tag_star entry () returns (character (32) aligned);
dcl  hcs_$initiate
	entry (character (*), character (*), character (*), fixed binary (1), fixed binary (2), pointer,
	fixed binary (35));
dcl  hcs_$make_ptr entry (pointer, character (*), character (*), pointer, fixed binary (35));
dcl  hcs_$terminate_noname entry (pointer, fixed binary (35));
dcl  object_lib_$init_no_clear entry (char(*), char(*), char(*), bit(1), ptr, fixed bin(24), bit(1), fixed bin(35));

dcl  any_other condition;

dcl  (addr, hbound, lbound, length, null, reverse, rtrim, search, substr) builtin;
%page;
/* find_command_: procedure (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code); */

	print_sw = "1"b;

	go to COMMON;


/* This entry is identical to find_command_, but does not print error messages */

fc_no_message:
     entry (a_input_name_ptr, a_input_name_lth, a_entrypoint_ptr, a_code);

	print_sw = "0"b;


COMMON:
	a_code = 0;				/* initialize it sometime */

	input_name_ptr = a_input_name_ptr;		/* get input arguments */

	input_name_lth = length (rtrim (a_input_name, SPACES));
						/* strip trailing whitespace right away */
	if input_name_lth = 0 then do;		/* blank command name */
	     if print_sw then call com_err_ (0, NAME, BlankCommand);
	     a_code = error_table_$seg_not_found;	/* for lack of something better */
	     return;
	     end;


/* Parse input name into segment name, entrypoint (optional), and pathname (optional) */

	if search (input_name, BREAKS) = 0 then do;	/* simple case, a segment name only */
	     if input_name_lth > length (segment_name) then call abort (error_table_$entlong, input_name);
	     pathname_sw, entrypoint_sw = "0"b;
	     segment_name = input_name;		/* make compiler generate better code */
	     entrypoint_name = input_name;
	     full_name = input_name;			/* for error messages later on */
	     end;

	else call parse_complex_name ();		/* out of main path for efficiency */
%page;
	call meter_usage (segment_name);		/* meter its usage whether or not it works */


	if ^pathname_sw
	then					/* No pathname was supplied:  This is the simple case and is handled completely by the internal
						   procedure search_entry */
	     call search_entry ();


	else do;

/* A pathname was supplied:  It may be necessary to terminate some other segment if the reference
   name "segment_name" is already in use.  In addition, it may be necessary to clear the associative
   memory to reflect this termination. */

	     call object_lib_$init_no_clear (directory_name, segment_name, segment_name, ""b, segment_ptr, 0, (""b), code);
	     if code ^= 0
	     then if code ^= error_table_$namedup then call abort (code, full_name_value.str);

		else if search_am (segment_name, am_idx) then call set_am (am_idx, "", null (), 0);
						/* clear this entry */
	     call search_entry ();			/* now try to find the entrypoint */
	     end;


/* Here only if the entrypoint was found */

	a_code = 0;				/* a_entrypoint_ptr already set */

RETURN:
	return;
%page;
/* Clear the associative memory:  It should be called after changes are made to the address space */

clear:
     entry ();

	do idx = lbound (memory.e, 1) to hbound (memory.e, 1);
	     call set_am (idx, "", null (), 0);
	end;

	return;
%page;
/* This internal procedure parses a command name containing pathnames and entrypoints */

parse_complex_name:
     procedure ();

dcl  (entry_idx, segment_lth, entrypoint_idx, entrypoint_lth) fixed binary (21);
dcl  pathname character (entry_idx + segment_lth - 1) unaligned based (input_name_ptr);


	entry_idx = search (reverse (input_name), "<>");	/* find end of pathname */

	if entry_idx = 0 then do;			/* no pathname */
	     entry_idx = 1;
	     pathname_sw = "0"b;
	     entrypoint_sw = "1"b;			/* tentatively must have an entrypoint */
	     end;

	else do;					/* pathname given */
	     if entry_idx = 1
	     then if input_name = ">"
		then				/* trap the root right here */
		     call abort (error_table_$dirseg, input_name);
		else call abort (error_table_$badpath, input_name);
	     pathname_sw = "1"b;
	     entry_idx = input_name_lth + 2 - entry_idx;	/* index of first char after > */
	     entrypoint_sw = (search (substr (input_name, entry_idx), "$") ^= 0);
	     end;


/* Check validity of syntax of entrypoint and pathname now that it is known
   what was supplied */

	if entrypoint_sw then do;
	     segment_lth = search (substr (input_name, entry_idx), "$") - 1;
	     entrypoint_idx = entry_idx + segment_lth + 1;
	     entrypoint_lth = input_name_lth - entrypoint_idx + 1;
	     if (segment_lth = 0) | (entrypoint_lth = 0) then call abort (error_table_$bad_command_name, input_name);
	     if entrypoint_lth > length (entrypoint_name)
	     then call abort (error_table_$entlong, substr (input_name, (entrypoint_idx - 1)));
	     end;

	else segment_lth = input_name_lth - entry_idx + 1;


	if pathname_sw then do;
	     call expand_pathname_ (pathname, directory_name, segment_name, code);
						/* expand, but exclude entrypoint */
	     if code ^= 0 then call abort (code, input_name);
	     end;

	else do;
	     if segment_lth > length (segment_name)
	     then call abort (error_table_$entlong, substr (input_name, 1, segment_lth));
	     segment_name = substr (input_name, entry_idx, segment_lth);
	     end;


/* Fill in the entrypoint name, defaulting to the segment name if necessary */

	if entrypoint_sw then do;
	     entrypoint_name = substr (input_name, entrypoint_idx);
	     if search (entrypoint_name, "$") ^= 0 then call abort (error_table_$bad_command_name, input_name);
	     end;
	else entrypoint_name = segment_name;

	if entrypoint_name = segment_name then entrypoint_sw = "0"b;
						/* insure off in case he said foo$foo */


/* Set full name to include the pathname only if pathname explicitly given */

	if pathname_sw
	then if directory_name = ">"
	     then full_name = ">";
	     else do;
		full_name = rtrim (directory_name);	/* separate for better code */
		full_name = full_name || ">";
		end;
	else full_name = "";

	if entrypoint_sw then do;			/* separate statements for better code */
	     full_name = full_name || rtrim (segment_name);
	     full_name = full_name || "$";
	     full_name = full_name || entrypoint_name;
	     end;
	else full_name = full_name || segment_name;

	return;

     end parse_complex_name;
%page;
/* This internal procedure does the main work of find_command_.  It attempts to find the specified entrypoint, first
   searching the associative memory, if possible */

search_entry:
     procedure ();

dcl  am_idx fixed binary;


/* Try the assocate memory first */

	if ^entrypoint_sw
	then if search_am (segment_name, am_idx) then do;
		a_entrypoint_ptr = memory.e (am_idx).entrypoint_ptr;
		return;
		end;


/* Must call the linker */

	call hcs_$make_ptr (null (), segment_name, entrypoint_name, a_entrypoint_ptr, code);
	if code ^= 0 then call abort (code, full_name_value.str);


/* Place entry into associative memory if no entrypoint was given */

	if ^entrypoint_sw then call set_am (am_idx, segment_name, a_entrypoint_ptr, HIT);

	return;

     end search_entry;
%page;
/* These two internal procedures manage the associative memory */

/* This internal procedure searches the associative memory, returning "1"b if the given name is in the memory.  In all
   cases it returns an index, which when the entry is not found, is the index of the least-recently used entry */

search_am:
     procedure (name, am_idx) returns (bit (1) aligned);

dcl  name character (32);
dcl  am_idx fixed binary;
dcl  (oldest, idx, jdx) fixed binary;

	oldest = hbound (memory.e, 1) + 1;

	do idx = lbound (memory.e, 1) to hbound (memory.e, 1);

	     if memory.e (idx).name = name then do;
		am_idx = idx;
		memory.e (idx).usage = HIT;
		do jdx = idx + 1 to hbound (memory.e, 1);
		     memory.e (jdx).usage = memory.e (jdx).usage - 1;
		end;				/* decrement usage of rest */
		return ("1"b);			/* success */
		end;

	     memory.e (idx).usage = memory.e (idx).usage - 1;
						/* miss */
	     if memory.e (idx).usage < oldest then do;
		oldest = memory.e (idx).usage;
		am_idx = idx;
		end;
	end;

	return ("0"b);				/* not found */

     end search_am;



/* This internal procedure sets an entry in the associative memory */

set_am:
     procedure (am_idx, name, entrypoint_ptr, usage);

dcl  (am_idx, usage) fixed binary;
dcl  name character (32);
dcl  entrypoint_ptr pointer;

	memory.e (am_idx).name = name;
	memory.e (am_idx).entrypoint_ptr = entrypoint_ptr;
	memory.e (am_idx).usage = usage;

	return;

     end set_am;
%page;
/* This internal procedure aborts find_command_, printing an error message if print_sw is ON */

abort:
     procedure (code, text);

dcl  code fixed binary (35);
dcl  text character (*);

	a_entrypoint_ptr = null ();
	a_code = code;

	if print_sw
	then if (code = error_table_$seg_not_found) | (code = error_table_$noentry)
	     then call com_err_$suppress_name (0, NAME, SegNotFound, segment_name);
	     else if code = error_table_$no_ext_sym
	     then call com_err_$suppress_name (0, NAME, NoEntryPoint, entrypoint_name, segment_name);
	     else call com_err_ (code, NAME, "^a", text);

	go to RETURN;

     end abort;
%page;
/* This internal procedure enters the current segment name into the command usage metering information */

meter_usage:
     procedure (command_name);

dcl  command_name character (32);

dcl  first_call bit (1) aligned internal static initial ("1"b);
dcl  metering bit (1) aligned internal static initial ("1"b);
						/* ON => metering still in operation */

dcl  user_name character (32) internal static;

dcl  (usage_list_ptr, usage_totals_ptr) pointer internal static;
dcl  user_list_ptr pointer;

dcl  UsageList character (19) static options (constant) initial ("command_usage_list_");
dcl  UsageTotals character (21) static options (constant) initial ("command_usage_totals_");

dcl  code fixed binary (35);
dcl  idx fixed binary;
dcl  found bit (1) aligned;

%include command_usage;


	if ^metering then return;			/* metering was turned off */


	if first_call then do;			/* must initialize */

	     call hcs_$make_ptr (null (), UsageList, "", usage_list_ptr, code);
	     if code ^= 0 then do;
disable_metering:
		metering = "0"b;			/* shut off metering on an error */
		return;
		end;

	     call hcs_$make_ptr (null (), UsageTotals, "", usage_totals_ptr, code);
	     if code ^= 0 then go to disable_metering;

	     user_name = get_group_id_$tag_star ();	/* if metering by user name */
	     first_call = "0"b;			/* initialized */
	     end;


/* Search command/alias list to see if this name is being metered */

	on any_other call check_for_error ();		/* disable metering on faults */

	found = "0"b;

	do idx = 1 to usage_list.n_commands while (^found);
	     if usage_list.commands (idx).name = command_name then found = "1"b;
	end;

	if found
	then idx = idx - 1;				/* will be one too large from loop */
	else return;				/* not being metered */


/* This name is being metered */

	if ^usage_list.commands (idx).primary then idx = usage_list.commands (idx).slot;
						/* this is an alias */

	usage_totals (usage_list.commands (idx).slot) = usage_totals (usage_list.commands (idx).slot) + 1;
						/* count it */

	if ^usage_list.commands (idx).count_users then return;
						/* recording finished */

	call hcs_$initiate (usage_list.directory, (usage_list.commands (idx).name || ".usage"), "", 0b, 01b,
	     user_list_ptr, (0));
	if user_list_ptr = null () then return;

	found = "0"b;

	do idx = 1 to user_list_size while (^found);
	     if user_list (idx).name = user_name then found = "1"b;
	     else if user_list (idx).count = 0 then do;	/* not in list, add in new slot */
		user_list (idx).name = user_name;
		found = "1"b;
		end;
	end;

	if found then user_list (idx - 1).count = user_list (idx - 1).count + 1;

	call hcs_$terminate_noname (user_list_ptr, (0));

	return;


/* This internal procedure of meter_usage is called on an error to decide
   if metering should be disabled */

check_for_error:
	procedure ();

dcl  code fixed binary (35);

dcl  1 info aligned,
%include cond_info;


	     info.version = 1;

	     call find_condition_info_ (null (), addr (info), code);
	     if code ^= 0 then go to disable_metering;	/* can't get info, bad error */

	     if (info.condition_name = "alrm") | (info.condition_name = "cput") | (info.condition_name = "finish")
		| (info.condition_name = "mme2") | (info.condition_name = "program_interrupt")
		| (info.condition_name = "quit") | (info.condition_name = "trm_") | (info.condition_name = "sus_")
	     then call continue_to_signal_ ((0));	/* these conditions are allright */

	     go to disable_metering;			/* fault: turn of metering */

	end check_for_error;

     end meter_usage;

     end find_command_;




		    move_r_or_t_.alm                11/11/89  1103.4r   11/11/89  0803.8       15993



" ***********************************************************
" *                                                         *
" * 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.      *
" *                                                         *
" ***********************************************************

" This procedure is called by numeric_to_ascii_ to move a float dec(59)
" value with rounding or truncation to specified number of digits
"
" Usage:
"		dcl move_r_or_t_ entry(float dec(59),float dec(59),fixed bin)
"		call move_r_or_t_(target,source,precision)
"
" precision = 0	straight move
"	  < 0	truncate
"	  > 0	round
"
" This routine runs in the stack frame of its caller.
"
" Initial Version: 29 January 1974 by Barry L. Wolman
"
	segdef	move_r_or_t_
"
	equ	target,2
	equ	source,4
	equ	precision,6
"
move_r_or_t_:
	epp1	ap|target,*	get target ptr
	epp2	ap|source,*	get source ptr
	eax0	0		assume rounding
	lda	ap|precision,*	get desired precision
	tze	dont_care		easy if zero
	tpl	3,ic		skip if rounding
	eax0	1		set truncate
	neg	0		and get abs value
	cmpa	59,dl		easy if greater than 59 wanted
	tpl	dont_care
	ada	2,dl		get length for descriptor
	xec	mvn,0		move with round|truncate
	desc9fl	2|0,61		source
	desc9fl	1|0,al		target
	mvn	(pr,rl),(pr)	move back to full length
	desc9fl	1|0,al
	desc9fl	1|0,61
	short_return
"
dont_care:
	mvn	(pr),(pr)
	desc9fl	2|0,61
	desc9fl	1|0,61
	short_return
"
mvn:	mvn	(pr),(pr,rl),round
	mvn	(pr),(pr,rl)
	end




		    numeric_to_ascii_.pl1           11/11/89  1103.4r   11/11/89  0803.8       30528



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* General number formatter.

   This routine returns the ASCII string representation of its input
   argument, which is float dec(59).  The returned varying string has
   no blanks in it.  The returned string is in I-format, F-format, or
   E-format depending on value of input.  The precision argument controls
   rounding or truncating of input value
	0	no action, as many digits as are necessary
		will appear in final string
	< 0	truncate to specified number of digits
	> 0	round to specified number of digits

   Initial Version: 28 January 1974 by Barry L. Wolman */

numeric_to_ascii_: proc(val,precision,ans);

dcl	val float dec(59),
	precision fixed bin,
	ans char(72) varying;

dcl	value float dec(59);

dcl	1 value_overlay	aligned based(addr(value)),
	2 sign		char(1) unaligned,
	2 digits		char(59) unaligned,
	2 skip		bit(1) unaligned,
	2 exponent	fixed bin(7) unaligned;

dcl	fixed_dec fixed dec(3);

dcl	1 fixed_overlay	aligned based(addr(fixed_dec)),
	2 sign		char(1) unaligned,
	2 dig		char(3) unaligned;

dcl	(p,exp,n,nzeros,ndigits) fixed bin;

dcl	move_r_or_t_ entry(float dec(59),float dec(59),fixed bin);

dcl	(abs,substr,convert) builtin;

	p = precision;

	if p ^= 0
	then do;
	     call move_r_or_t_(value,val,p);
	     p = abs(p);
	     end;
	else do;
	     value = val;
	     p = 59;
	     end;

	if value = 0 then ans = "0";
	else do;

	     if value > 0 then ans = "";
	     else do;
		value = abs(value);
		ans = "-";
		end;

	     n = verify(digits,"0");
	     nzeros = verify(reverse(digits),"0");
	     ndigits = 61 - n - nzeros;

	     exp = exponent + nzeros - 1;

	     if exp >= 0
	     then if exp + ndigits > p then call e_format;
		else do;
		     ans = ans || substr(digits,n,ndigits);
		     if exp > 0 then ans = ans || substr((64)"0",1,exp);
		     end;
	     else do;
		nzeros = ndigits + exp;

		if nzeros <= 0
		then if ndigits - nzeros > p
		     then call e_format;
		     else do;
			ans = ans || "0.";
			if nzeros ^= 0 then ans = ans || substr((64)"0",1,abs(nzeros));
			ans = ans || substr(digits,n,ndigits);
			end;
		else do;
		     ans = ans || substr(digits,n,nzeros);
		     ans = ans || ".";
		     ans = ans || substr(digits,nzeros+n,ndigits-nzeros);
		     end;
		end;
	     end;

e_format:	     proc;

	     ans = ans || substr(digits,n,1);
	     ans = ans || ".";
	     ans = ans || substr(digits,n+1,ndigits-1);
	     ans = ans || "e";

	     exp = exp + ndigits - 1;

	     fixed_dec = convert(fixed_dec,exp);

	     if abs(exp) < 10 then ndigits = 1;
	     else if abs(exp) < 100 then ndigits = 2;
		else ndigits = 3;

	     if exp < 0 then ans = ans || "-";
	     ans = ans || substr(fixed_overlay.dig,4-ndigits,ndigits);
	     end;

	end;




		    numeric_to_ascii_base_.pl1      11/11/89  1103.4r   11/11/89  0803.8       48168



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */
numeric_to_ascii_base_: proc (Aval, Aprec, Base, ans);

dcl  Aval float dec (59),				/* value to be converted. (In)		*/
     Aprec fixed bin,				/* precision of result. (In)			*/
						/*      0 ==> as many digits as a required will	*/
						/*            appear in final result.		*/
						/*     <0 ==> truncate to specified no of digits	*/
						/*     >0 ==> round to specified number of digits	*/
						/*   see numeric_to_ascii_ for description of	*/
						/*   allowed values.			*/
     Base fixed bin,				/* base to which conversion is to be done */
     ans char (72) varying;				/* resulting number. (Out)		*/

/* This is copied from numeric_to_ascii_ */
/* Modified: 10/24/83 by C Spitzer. phx15636, replace out_of_bounds condition
	   with call to sub_err_ */

dcl (new_quotient, product, quotient, saved_val, val)
     float dec (59),
    (Isignificant, exp, n, nzeros, ndigits, prec)
     fixed bin (17),
     char1 char (1),
     chars char (200) varying,
     char_exp pic "999";
dcl  sub_err_ entry() options(variable);
dcl  dig_ch (0:15) char (1) int static init (
     "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f");
dcl  base float dec (3);

dcl 1 val_overlay aligned based (addr (val)),
    2 sign char (1) unal,
    2 digits char (59) unal,
    2 skip bit (1) unal,
    2 exponent fixed bin (7) unal;

dcl (abs, divide, index, length, mod, null, reverse, substr, trunc, verify) builtin;

dcl  move_r_or_t_ entry (float dec (59), float dec (59), fixed bin);

%include sub_err_flags;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	if (Base < 2)
	| (Base > 16)
	then do;
	     call sub_err_ (0, "numeric_to_ascii_base_", ACTION_CANT_RESTART, null, 0,
		"The base ""^d"" is outside of the range 2 to 16.", Base);
	end;
	base = convert (base, Base);
	prec = Aprec;
	if prec ^= 0 then do;
	     call move_r_or_t_ (val, Aval, prec);
	     prec = abs (prec);
	end;
	else do;
	     val = Aval;
	     prec = 59;
	end;

	if val = 0 then ans = "0";
	else do;

	     if val > 0 then ans = "";
	     else do;
		val = abs (val);
		ans = "-";
	     end;

	     n = verify (digits, "0");
	     nzeros = verify (reverse (digits), "0");
	     ndigits = 61 - n - nzeros;
	     exp = exponent + nzeros - 1;

	     if exp >= 0 then do;			/*	 integer value			*/
		quotient = val;
		chars = "";
		do while (quotient >= 1);		/* use method of dividing successive		*/
						/*     quotients by radix, using remainders as	*/
						/*     digits of result (low-order first).	*/
		     new_quotient = trunc (divide (quotient, base, 59));
		     char1 = dig_ch (quotient - (base * new_quotient));
		     chars = chars || char1;
		     quotient = new_quotient;
		end;
		chars = reverse (chars);

		if length (chars) > prec then call e_format ();
		else ans = ans || chars;
	     end;

	     else do;				/*	integer/fractional value		*/
		nzeros = ndigits + exp;

		if nzeros <= 0 then do;		/*	fraction only value			*/
		     product = val;
		     ans = ans || "0.";
		     do n = 1 to prec;
			product = base * product;
			char1 = dig_ch (trunc (product));
			product = product - trunc (product);
			ans = ans || char1;
		     end;
		     n = verify (reverse (ans), "0");
		     if n > 1 then ans = substr (ans, 1, length (ans) - (n-1));
		end;

		else do;				/*	both integer and fraction parts	*/
		     saved_val = val;

		     substr (val_overlay.digits, nzeros+n) = (59)"0";
		     quotient = val;
		     chars = "";
		     do while (quotient >= 1);
			new_quotient = trunc (divide (quotient, base, 59));
			char1 = dig_ch (quotient - (base * new_quotient));
			chars = chars || char1;
			quotient = new_quotient;
		     end;
		     chars = reverse (chars);
		     chars = chars || ".";

		     val = saved_val;
		     substr (val_overlay.digits, 1, nzeros+n-1) = (59)"0";
		     product = val;
		     do n = 1 to prec - (length (chars)-1);
			product = base * product;
			char1 = dig_ch (trunc (product));
			product = product - trunc (product);
			chars = chars || char1;
		     end;
		     n = verify (reverse (chars), "0");
		     if n > 1 then chars = substr (chars, 1, length (chars) - (n-1));

		     if length (chars)-1 > prec then call e_format ();
		     else ans = ans || chars;
		end;
	     end;
	end;
	return;

e_format:	procedure;

	     exp = index (chars, ".") - 1;
	     if exp = -1 then exp = length (chars);
	     else chars = substr (chars, 1, exp) || substr (chars, exp+2);

	     ans = ans || substr (chars, 1, 1);
	     ans = ans || ".";
	     ans = ans || substr (chars, 2, prec-1);

	     ans = ans || "e";
	     if exp-1 < 0 then
		ans = ans || "-";
	     else ans = ans || "+";
	     char_exp = exp-1;
	     Isignificant = verify (char_exp, "0");
	     ans = ans || substr (char_exp, Isignificant);

	end e_format;

     end numeric_to_ascii_base_;




		    op_mnemonic_.cds                11/11/89  1103.4r   11/11/89  0803.8      229725



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

/* op_mnemonic_.cds -- successor to the illegible op_mnemonic.alm */

/* format: style2 */

op_mnemonic_:
     procedure;

/* BIM 12/82 */
/* Modified to not need the bce/Multics versions! March 1985 by Keith Loepere. */

declare create_data_segment_ entry (pointer, fixed binary (35));
declare com_err_ entry() options(variable);
declare code fixed bin (35);

%include cds_args;
%include op_mnemonic_dcl_;

          declare 1 CDSA                 aligned like cds_args;
	declare 1 OI		 aligned,
		2 op_mnemonic	 bit (0) aligned,	/* programs reference this ... */
		2 op_mnemonic_	 (0:1023) aligned like op_mnemonic;

	declare 1 unused		 aligned like op_mnemonic;


	unspec (unused) = ""b;
	unused.name = "....  ";
	unused.num_words = 1;
	OI.op_mnemonic_ (*) = unused;

	call set_opcode (2, "mme1  ", 0, 0, 1);
	call set_opcode (4, "drl   ", 0, 0, 1);
	call set_opcode (8, "mme2  ", 0, 0, 1);
	call set_opcode (10, "mme3  ", 0, 0, 1);
	call set_opcode (14, "mme4  ", 0, 0, 1);
	call set_opcode (18, "nop   ", 0, 0, 1);
	call set_opcode (20, "puls1 ", 0, 0, 1);
	call set_opcode (22, "puls2 ", 0, 0, 1);
	call set_opcode (26, "cioc  ", 0, 0, 1);
	call set_opcode (32, "adlx0 ", 0, 0, 1);
	call set_opcode (33, "mve   ", 0, 3, 4);
	call set_opcode (34, "adlx1 ", 0, 0, 1);
	call set_opcode (36, "adlx2 ", 0, 0, 1);
	call set_opcode (38, "adlx3 ", 0, 0, 1);
	call set_opcode (40, "adlx4 ", 0, 0, 1);
	call set_opcode (41, "mvne  ", 2, 3, 4);
	call set_opcode (42, "adlx5 ", 0, 0, 1);
	call set_opcode (44, "adlx6 ", 0, 0, 1);
	call set_opcode (46, "adlx7 ", 0, 0, 1);
	call set_opcode (52, "ldqc  ", 0, 0, 1);
	call set_opcode (54, "adl   ", 0, 0, 1);
	call set_opcode (56, "ldac  ", 0, 0, 1);
	call set_opcode (58, "adla  ", 0, 0, 1);
	call set_opcode (60, "adlq  ", 0, 0, 1);
	call set_opcode (62, "adlaq ", 0, 0, 1);
	call set_opcode (64, "asx0  ", 0, 0, 1);
	call set_opcode (66, "asx1  ", 0, 0, 1);
	call set_opcode (68, "asx2  ", 0, 0, 1);
	call set_opcode (70, "asx3  ", 0, 0, 1);
	call set_opcode (72, "asx4  ", 0, 0, 1);
	call set_opcode (74, "asx5  ", 0, 0, 1);
	call set_opcode (76, "asx6  ", 0, 0, 1);
	call set_opcode (78, "asx7  ", 0, 0, 1);
	call set_opcode (80, "adwp0 ", 0, 0, 1);
	call set_opcode (82, "adwp1 ", 0, 0, 1);
	call set_opcode (84, "adwp2 ", 0, 0, 1);
	call set_opcode (86, "adwp3 ", 0, 0, 1);
	call set_opcode (88, "aos   ", 0, 0, 1);
	call set_opcode (90, "asa   ", 0, 0, 1);
	call set_opcode (92, "asq   ", 0, 0, 1);
	call set_opcode (94, "sscr  ", 0, 0, 1);
	call set_opcode (96, "adx0  ", 0, 0, 1);
	call set_opcode (97, "csl   ", 1, 2, 3);
	call set_opcode (98, "adx1  ", 0, 0, 1);
	call set_opcode (99, "csr   ", 1, 2, 3);
	call set_opcode (100, "adx2  ", 0, 0, 1);
	call set_opcode (102, "adx3  ", 0, 0, 1);
	call set_opcode (104, "adx4  ", 0, 0, 1);
	call set_opcode (105, "sztl  ", 1, 2, 3);
	call set_opcode (106, "adx5  ", 0, 0, 1);
	call set_opcode (107, "sztr  ", 1, 2, 3);
	call set_opcode (108, "adx6  ", 0, 0, 1);
	call set_opcode (109, "cmpb  ", 1, 2, 3);
	call set_opcode (110, "adx7  ", 0, 0, 1);
	call set_opcode (114, "awca  ", 0, 0, 1);
	call set_opcode (116, "awcq  ", 0, 0, 1);
	call set_opcode (118, "lreg  ", 0, 0, 1);
	call set_opcode (122, "ada   ", 0, 0, 1);
	call set_opcode (124, "adq   ", 0, 0, 1);
	call set_opcode (126, "adaq  ", 0, 0, 1);
	call set_opcode (128, "cmpx0 ", 0, 0, 1);
	call set_opcode (129, "mlr   ", 0, 2, 3);
	call set_opcode (130, "cmpx1 ", 0, 0, 1);
	call set_opcode (131, "mrl   ", 0, 2, 3);
	call set_opcode (132, "cmpx2 ", 0, 0, 1);
	call set_opcode (134, "cmpx3 ", 0, 0, 1);
	call set_opcode (136, "cmpx4 ", 0, 0, 1);
	call set_opcode (138, "cmpx5 ", 0, 0, 1);
	call set_opcode (140, "cmpx6 ", 0, 0, 1);
	call set_opcode (141, "cmpc  ", 0, 2, 3);
	call set_opcode (142, "cmpx7 ", 0, 0, 1);
	call set_opcode (146, "cwl   ", 0, 0, 1);
	call set_opcode (154, "cmpa  ", 0, 0, 1);
	call set_opcode (156, "cmpq  ", 0, 0, 1);
	call set_opcode (158, "cmpaq ", 0, 0, 1);
	call set_opcode (160, "sblx0 ", 0, 0, 1);
	call set_opcode (161, "scd   ", 0, 2, 4);
	call set_opcode (162, "sblx1 ", 0, 0, 1);
	call set_opcode (163, "scdr  ", 0, 2, 4);
	call set_opcode (164, "sblx2 ", 0, 0, 1);
	call set_opcode (166, "sblx3 ", 0, 0, 1);
	call set_opcode (168, "sblx4 ", 0, 0, 1);
	call set_opcode (169, "scm   ", 0, 2, 4);
	call set_opcode (170, "sblx5 ", 0, 0, 1);
	call set_opcode (171, "scmr  ", 0, 2, 4);
	call set_opcode (172, "sblx6 ", 0, 0, 1);
	call set_opcode (174, "sblx7 ", 0, 0, 1);
	call set_opcode (186, "sbla  ", 0, 0, 1);
	call set_opcode (188, "sblq  ", 0, 0, 1);
	call set_opcode (190, "sblaq ", 0, 0, 1);
	call set_opcode (192, "ssx0  ", 0, 0, 1);
	call set_opcode (194, "ssx1  ", 0, 0, 1);
	call set_opcode (196, "ssx2  ", 0, 0, 1);
	call set_opcode (198, "ssx3  ", 0, 0, 1);
	call set_opcode (200, "ssx4  ", 0, 0, 1);
	call set_opcode (202, "ssx5  ", 0, 0, 1);
	call set_opcode (204, "ssx6  ", 0, 0, 1);
	call set_opcode (206, "ssx7  ", 0, 0, 1);
	call set_opcode (208, "adwp4 ", 0, 0, 1);
	call set_opcode (210, "adwp5 ", 0, 0, 1);
	call set_opcode (212, "adwp6 ", 0, 0, 1);
	call set_opcode (214, "adwp7 ", 0, 0, 1);
	call set_opcode (216, "sdbr  ", 0, 0, 1);
	call set_opcode (217, "sptr  ", 0, 0, 1);
	call set_opcode (218, "ssa   ", 0, 0, 1);
	call set_opcode (220, "ssq   ", 0, 0, 1);
	call set_opcode (224, "sbx0  ", 0, 0, 1);
	call set_opcode (225, "mvt   ", 0, 2, 4);
	call set_opcode (226, "sbx1  ", 0, 0, 1);
	call set_opcode (228, "sbx2  ", 0, 0, 1);
	call set_opcode (230, "sbx3  ", 0, 0, 1);
	call set_opcode (232, "sbx4  ", 0, 0, 1);
	call set_opcode (233, "tct   ", 0, 1, 4);
	call set_opcode (234, "sbx5  ", 0, 0, 1);
	call set_opcode (235, "tctr  ", 0, 1, 4);
	call set_opcode (236, "sbx6  ", 0, 0, 1);
	call set_opcode (238, "sbx7  ", 0, 0, 1);
	call set_opcode (242, "swca  ", 0, 0, 1);
	call set_opcode (244, "swcq  ", 0, 0, 1);
	call set_opcode (246, "lpri  ", 0, 0, 1);
	call set_opcode (247, "lptr  ", 0, 0, 1);
	call set_opcode (250, "sba   ", 0, 0, 1);
	call set_opcode (252, "sbq   ", 0, 0, 1);
	call set_opcode (254, "sbaq  ", 0, 0, 1);
	call set_opcode (256, "cnax0 ", 0, 0, 1);
	call set_opcode (258, "cnax1 ", 0, 0, 1);
	call set_opcode (260, "cnax2 ", 0, 0, 1);
	call set_opcode (261, "ad2d  ", 2, 2, 3);
	call set_opcode (262, "cnax3 ", 0, 0, 1);
	call set_opcode (263, "sb2d  ", 2, 2, 3);
	call set_opcode (264, "cnax4 ", 0, 0, 1);
	call set_opcode (266, "cnax5 ", 0, 0, 1);
	call set_opcode (268, "cnax6 ", 0, 0, 1);
	call set_opcode (269, "mp2d  ", 2, 2, 3);
	call set_opcode (270, "cnax7 ", 0, 0, 1);
	call set_opcode (271, "dv2d  ", 2, 2, 3);
	call set_opcode (274, "cmk   ", 0, 0, 1);
	call set_opcode (276, "absa  ", 0, 0, 1);
	call set_opcode (278, "epaq  ", 0, 0, 1);
	call set_opcode (280, "sznc  ", 0, 0, 1);
	call set_opcode (282, "cnaa  ", 0, 0, 1);
	call set_opcode (284, "cnaq  ", 0, 0, 1);
	call set_opcode (286, "cnaaq ", 0, 0, 1);
	call set_opcode (288, "ldx0  ", 0, 0, 1);
	call set_opcode (290, "ldx1  ", 0, 0, 1);
	call set_opcode (292, "ldx2  ", 0, 0, 1);
	call set_opcode (293, "ad3d  ", 2, 3, 4);
	call set_opcode (294, "ldx3  ", 0, 0, 1);
	call set_opcode (295, "sb3d  ", 2, 3, 4);
	call set_opcode (296, "ldx4  ", 0, 0, 1);
	call set_opcode (298, "ldx5  ", 0, 0, 1);
	call set_opcode (300, "ldx6  ", 0, 0, 1);
	call set_opcode (301, "mp3d  ", 2, 3, 4);
	call set_opcode (302, "ldx7  ", 0, 0, 1);
	call set_opcode (303, "dv3d  ", 2, 3, 4);
	call set_opcode (304, "lbar  ", 0, 0, 1);
	call set_opcode (306, "rsw   ", 0, 0, 1);
	call set_opcode (308, "ldbr  ", 0, 0, 1);
	call set_opcode (309, "lsdr  ", 0, 0, 1);
	call set_opcode (310, "rmcm  ", 0, 0, 1);
	call set_opcode (312, "szn   ", 0, 0, 1);
	call set_opcode (314, "lda   ", 0, 0, 1);
	call set_opcode (316, "ldq   ", 0, 0, 1);
	call set_opcode (318, "ldaq  ", 0, 0, 1);
	call set_opcode (320, "orsx0 ", 0, 0, 1);
	call set_opcode (322, "orsx1 ", 0, 0, 1);
	call set_opcode (324, "orsx2 ", 0, 0, 1);
	call set_opcode (326, "orsx3 ", 0, 0, 1);
	call set_opcode (328, "orsx4 ", 0, 0, 1);
	call set_opcode (330, "orsx5 ", 0, 0, 1);
	call set_opcode (332, "orsx6 ", 0, 0, 1);
	call set_opcode (334, "orsx7 ", 0, 0, 1);
	call set_opcode (336, "spri0 ", 0, 0, 1);
	call set_opcode (337, "spbp0 ", 0, 0, 1);
	call set_opcode (338, "spbp1 ", 0, 0, 1);
	call set_opcode (339, "spri1 ", 0, 0, 1);
	call set_opcode (340, "spri2 ", 0, 0, 1);
	call set_opcode (341, "spbp2 ", 0, 0, 1);
	call set_opcode (342, "spbp3 ", 0, 0, 1);
	call set_opcode (343, "spri3 ", 0, 0, 1);
	call set_opcode (344, "spri  ", 0, 0, 1);
	call set_opcode (345, "ssdr  ", 0, 0, 1);
	call set_opcode (346, "orsa  ", 0, 0, 1);
	call set_opcode (348, "orsq  ", 0, 0, 1);
	call set_opcode (350, "lsdp  ", 0, 0, 1);
	call set_opcode (351, "lptp  ", 0, 0, 1);
	call set_opcode (352, "orx0  ", 0, 0, 1);
	call set_opcode (354, "orx1  ", 0, 0, 1);
	call set_opcode (356, "orx2  ", 0, 0, 1);
	call set_opcode (358, "orx3  ", 0, 0, 1);
	call set_opcode (360, "orx4  ", 0, 0, 1);
	call set_opcode (362, "orx5  ", 0, 0, 1);
	call set_opcode (364, "orx6  ", 0, 0, 1);
	call set_opcode (366, "orx7  ", 0, 0, 1);
	call set_opcode (368, "tsp0  ", 0, 0, 1);
	call set_opcode (370, "tsp1  ", 0, 0, 1);
	call set_opcode (372, "tsp2  ", 0, 0, 1);
	call set_opcode (374, "tsp3  ", 0, 0, 1);
	call set_opcode (378, "ora   ", 0, 0, 1);
	call set_opcode (380, "orq   ", 0, 0, 1);
	call set_opcode (382, "oraq  ", 0, 0, 1);
	call set_opcode (384, "canx0 ", 0, 0, 1);
	call set_opcode (385, "mvn   ", 2, 2, 3);
	call set_opcode (386, "canx1 ", 0, 0, 1);
	call set_opcode (387, "btd   ", 2, 2, 3);
	call set_opcode (388, "canx2 ", 0, 0, 1);
	call set_opcode (390, "canx3 ", 0, 0, 1);
	call set_opcode (391, "cmpn  ", 2, 2, 3);
	call set_opcode (392, "canx4 ", 0, 0, 1);
	call set_opcode (394, "canx5 ", 0, 0, 1);
	call set_opcode (395, "dtb   ", 2, 2, 3);
	call set_opcode (396, "canx6 ", 0, 0, 1);
	call set_opcode (398, "canx7 ", 0, 0, 1);
	call set_opcode (400, "eawp0 ", 0, 0, 1);
	call set_opcode (401, "easp1 ", 0, 0, 1);
	call set_opcode (402, "easp0 ", 0, 0, 1);
	call set_opcode (403, "eawp1 ", 0, 0, 1);
	call set_opcode (404, "eawp2 ", 0, 0, 1);
	call set_opcode (405, "easp3 ", 0, 0, 1);
	call set_opcode (406, "easp2 ", 0, 0, 1);
	call set_opcode (407, "eawp3 ", 0, 0, 1);
	call set_opcode (410, "cana  ", 0, 0, 1);
	call set_opcode (412, "canq  ", 0, 0, 1);
	call set_opcode (414, "canaq ", 0, 0, 1);
	call set_opcode (416, "lcx0  ", 0, 0, 1);
	call set_opcode (418, "lcx1  ", 0, 0, 1);
	call set_opcode (420, "lcx2  ", 0, 0, 1);
	call set_opcode (422, "lcx3  ", 0, 0, 1);
	call set_opcode (424, "lcx4  ", 0, 0, 1);
	call set_opcode (426, "lcx5  ", 0, 0, 1);
	call set_opcode (428, "lcx6  ", 0, 0, 1);
	call set_opcode (430, "lcx7  ", 0, 0, 1);
	call set_opcode (432, "eawp4 ", 0, 0, 1);
	call set_opcode (433, "easp5 ", 0, 0, 1);
	call set_opcode (434, "easp4 ", 0, 0, 1);
	call set_opcode (435, "eawp5 ", 0, 0, 1);
	call set_opcode (436, "eawp6 ", 0, 0, 1);
	call set_opcode (437, "easp7 ", 0, 0, 1);
	call set_opcode (438, "easp6 ", 0, 0, 1);
	call set_opcode (439, "eawp7 ", 0, 0, 1);
	call set_opcode (442, "lca   ", 0, 0, 1);
	call set_opcode (444, "lcq   ", 0, 0, 1);
	call set_opcode (446, "lcaq  ", 0, 0, 1);
	call set_opcode (448, "ansx0 ", 0, 0, 1);
	call set_opcode (450, "ansx1 ", 0, 0, 1);
	call set_opcode (452, "ansx2 ", 0, 0, 1);
	call set_opcode (454, "ansx3 ", 0, 0, 1);
	call set_opcode (456, "ansx4 ", 0, 0, 1);
	call set_opcode (458, "ansx5 ", 0, 0, 1);
	call set_opcode (460, "ansx6 ", 0, 0, 1);
	call set_opcode (462, "ansx7 ", 0, 0, 1);
	call set_opcode (464, "epp0  ", 0, 0, 1);
	call set_opcode (465, "epbp0 ", 0, 0, 1);
	call set_opcode (466, "epbp1 ", 0, 0, 1);
	call set_opcode (467, "epp1  ", 0, 0, 1);
	call set_opcode (468, "epp2  ", 0, 0, 1);
	call set_opcode (469, "epbp2 ", 0, 0, 1);
	call set_opcode (470, "epbp3 ", 0, 0, 1);
	call set_opcode (471, "epp3  ", 0, 0, 1);
	call set_opcode (472, "stac  ", 0, 0, 1);
	call set_opcode (474, "ansa  ", 0, 0, 1);
	call set_opcode (476, "ansq  ", 0, 0, 1);
	call set_opcode (478, "stcd  ", 0, 0, 1);
	call set_opcode (480, "anx0  ", 0, 0, 1);
	call set_opcode (482, "anx1  ", 0, 0, 1);
	call set_opcode (484, "anx2  ", 0, 0, 1);
	call set_opcode (486, "anx3  ", 0, 0, 1);
	call set_opcode (488, "anx4  ", 0, 0, 1);
	call set_opcode (490, "anx5  ", 0, 0, 1);
	call set_opcode (492, "anx6  ", 0, 0, 1);
	call set_opcode (494, "anx7  ", 0, 0, 1);
	call set_opcode (496, "epp4  ", 0, 0, 1);
	call set_opcode (497, "epbp4 ", 0, 0, 1);
	call set_opcode (498, "epbp5 ", 0, 0, 1);
	call set_opcode (499, "epp5  ", 0, 0, 1);
	call set_opcode (500, "epp6  ", 0, 0, 1);
	call set_opcode (501, "epbp6 ", 0, 0, 1);
	call set_opcode (502, "epbp7 ", 0, 0, 1);
	call set_opcode (503, "epp7  ", 0, 0, 1);
	call set_opcode (506, "ana   ", 0, 0, 1);
	call set_opcode (508, "anq   ", 0, 0, 1);
	call set_opcode (510, "anaq  ", 0, 0, 1);
	call set_opcode (514, "mpf   ", 0, 0, 1);
	call set_opcode (516, "mpy   ", 0, 0, 1);
	call set_opcode (522, "cmg   ", 0, 0, 1);
	call set_opcode (530, "lde   ", 0, 0, 1);
	call set_opcode (534, "rscr  ", 0, 0, 1);
	call set_opcode (538, "ade   ", 0, 0, 1);
	call set_opcode (546, "ufm   ", 0, 0, 1);
	call set_opcode (550, "dufm  ", 0, 0, 1);
	call set_opcode (554, "fcmg  ", 0, 0, 1);
	call set_opcode (558, "dfcmg ", 0, 0, 1);
	call set_opcode (560, "fszn  ", 0, 0, 1);
	call set_opcode (562, "fld   ", 0, 0, 1);
	call set_opcode (566, "dfld  ", 0, 0, 1);
	call set_opcode (570, "ufa   ", 0, 0, 1);
	call set_opcode (574, "dufa  ", 0, 0, 1);
	call set_opcode (576, "sxl0  ", 0, 0, 1);
	call set_opcode (578, "sxl1  ", 0, 0, 1);
	call set_opcode (580, "sxl2  ", 0, 0, 1);
	call set_opcode (582, "sxl3  ", 0, 0, 1);
	call set_opcode (583, "sareg ", 0, 0, 1);
	call set_opcode (584, "sxl4  ", 0, 0, 1);
	call set_opcode (586, "sxl5  ", 0, 0, 1);
	call set_opcode (588, "sxl6  ", 0, 0, 1);
	call set_opcode (590, "sxl7  ", 0, 0, 1);
	call set_opcode (591, "spl   ", 0, 0, 1);
	call set_opcode (592, "stz   ", 0, 0, 1);
	call set_opcode (594, "smic  ", 0, 0, 1);
	call set_opcode (596, "scpr  ", 0, 0, 1);
	call set_opcode (600, "stt   ", 0, 0, 1);
	call set_opcode (602, "fst   ", 0, 0, 1);
	call set_opcode (604, "ste   ", 0, 0, 1);
	call set_opcode (606, "dfst  ", 0, 0, 1);
	call set_opcode (610, "fmp   ", 0, 0, 1);
	call set_opcode (614, "dfmp  ", 0, 0, 1);
	call set_opcode (615, "lareg ", 0, 0, 1);
	call set_opcode (623, "lpl   ", 0, 0, 1);
	call set_opcode (624, "fstr  ", 0, 0, 1);
	call set_opcode (626, "frd   ", 0, 0, 1);
	call set_opcode (628, "dfstr ", 0, 0, 1);
	call set_opcode (630, "dfrd  ", 0, 0, 1);
	call set_opcode (634, "fad   ", 0, 0, 1);
	call set_opcode (638, "dfad  ", 0, 0, 1);
	call set_opcode (640, "rpl   ", 0, 1, 1);
	call set_opcode (641, "a9bd  ", 1, 0, 1);
	call set_opcode (643, "a6bd  ", 1, 0, 1);
	call set_opcode (645, "a4bd  ", 1, 0, 1);
	call set_opcode (647, "abd   ", 1, 0, 1);
	call set_opcode (650, "bcd   ", 0, 0, 1);
	call set_opcode (652, "div   ", 0, 0, 1);
	call set_opcode (654, "dvf   ", 0, 0, 1);
	call set_opcode (655, "awd   ", 1, 0, 1);
	call set_opcode (662, "fneg  ", 0, 0, 1);
	call set_opcode (666, "fcmp  ", 0, 0, 1);
	call set_opcode (670, "dfcmp ", 0, 0, 1);
	call set_opcode (672, "rpt   ", 0, 1, 1);
	call set_opcode (673, "s9bd  ", 1, 0, 1);
	call set_opcode (675, "s6bd  ", 1, 0, 1);
	call set_opcode (677, "s4bd  ", 1, 0, 1);
	call set_opcode (679, "sbd   ", 1, 0, 1);
	call set_opcode (682, "fdi   ", 0, 0, 1);
	call set_opcode (686, "dfdi  ", 0, 0, 1);
	call set_opcode (687, "swd   ", 1, 0, 1);
	call set_opcode (690, "neg   ", 0, 0, 1);
	call set_opcode (692, "cams  ", 0, 0, 1);
	call set_opcode (693, "camp  ", 0, 0, 1);
	call set_opcode (694, "negl  ", 0, 0, 1);
	call set_opcode (698, "ufs   ", 0, 0, 1);
	call set_opcode (702, "dufs  ", 0, 0, 1);
	call set_opcode (704, "sprp0 ", 0, 0, 1);
	call set_opcode (705, "ara0  ", 0, 0, 1);
	call set_opcode (706, "sprp1 ", 0, 0, 1);
	call set_opcode (707, "ara1  ", 0, 0, 1);
	call set_opcode (708, "sprp2 ", 0, 0, 1);
	call set_opcode (709, "ara2  ", 0, 0, 1);
	call set_opcode (710, "sprp3 ", 0, 0, 1);
	call set_opcode (711, "ara3  ", 0, 0, 1);
	call set_opcode (712, "sprp4 ", 0, 0, 1);
	call set_opcode (713, "ara4  ", 0, 0, 1);
	call set_opcode (714, "sprp5 ", 0, 0, 1);
	call set_opcode (715, "ara5  ", 0, 0, 1);
	call set_opcode (716, "sprp6 ", 0, 0, 1);
	call set_opcode (717, "ara6  ", 0, 0, 1);
	call set_opcode (718, "sprp7 ", 0, 0, 1);
	call set_opcode (719, "ara7  ", 0, 0, 1);
	call set_opcode (720, "sbar  ", 0, 0, 1);
	call set_opcode (722, "stba  ", 0, 1, 1);
	call set_opcode (724, "stbq  ", 0, 1, 1);
	call set_opcode (726, "smcm  ", 0, 0, 1);
	call set_opcode (728, "stc1  ", 0, 0, 1);
	call set_opcode (734, "ssdp  ", 0, 0, 1);
	call set_opcode (735, "sptp  ", 0, 0, 1);
	call set_opcode (736, "rpd   ", 0, 1, 1);
	call set_opcode (737, "aar0  ", 0, 0, 1);
	call set_opcode (739, "aar1  ", 0, 0, 1);
	call set_opcode (741, "aar2  ", 0, 0, 1);
	call set_opcode (743, "aar3  ", 0, 0, 1);
	call set_opcode (745, "aar4  ", 0, 0, 1);
	call set_opcode (746, "fdv   ", 0, 0, 1);
	call set_opcode (747, "aar5  ", 0, 0, 1);
	call set_opcode (749, "aar6  ", 0, 0, 1);
	call set_opcode (750, "dfdv  ", 0, 0, 1);
	call set_opcode (751, "aar7  ", 0, 0, 1);
	call set_opcode (758, "fno   ", 0, 0, 1);
	call set_opcode (762, "fsb   ", 0, 0, 1);
	call set_opcode (766, "dfsb  ", 0, 0, 1);
	call set_opcode (768, "tze   ", 0, 0, 1);
	call set_opcode (769, "trtn  ", 0, 0, 1);
	call set_opcode (770, "tnz   ", 0, 0, 1);
	call set_opcode (771, "trtf  ", 0, 0, 1);
	call set_opcode (772, "tnc   ", 0, 0, 1);
	call set_opcode (774, "trc   ", 0, 0, 1);
	call set_opcode (776, "tmi   ", 0, 0, 1);
	call set_opcode (777, "tmoz  ", 0, 0, 1);
	call set_opcode (778, "tpl   ", 0, 0, 1);
	call set_opcode (779, "tpnz  ", 0, 0, 1);
	call set_opcode (781, "ttn   ", 0, 0, 1);
	call set_opcode (782, "ttf   ", 0, 0, 1);
	call set_opcode (784, "rtcd  ", 0, 0, 1);
	call set_opcode (790, "rcu   ", 0, 0, 1);
	call set_opcode (792, "teo   ", 0, 0, 1);
	call set_opcode (794, "teu   ", 0, 0, 1);
	call set_opcode (796, "dis   ", 0, 0, 1);
	call set_opcode (798, "tov   ", 0, 0, 1);
	call set_opcode (800, "eax0  ", 0, 0, 1);
	call set_opcode (802, "eax1  ", 0, 0, 1);
	call set_opcode (804, "eax2  ", 0, 0, 1);
	call set_opcode (806, "eax3  ", 0, 0, 1);
	call set_opcode (808, "eax4  ", 0, 0, 1);
	call set_opcode (810, "eax5  ", 0, 0, 1);
	call set_opcode (812, "eax6  ", 0, 0, 1);
	call set_opcode (814, "eax7  ", 0, 0, 1);
	call set_opcode (816, "ret   ", 0, 0, 1);
	call set_opcode (822, "rccl  ", 0, 0, 1);
	call set_opcode (824, "ldi   ", 0, 0, 1);
	call set_opcode (826, "eaa   ", 0, 0, 1);
	call set_opcode (828, "eaq   ", 0, 0, 1);
	call set_opcode (830, "ldt   ", 0, 0, 1);
	call set_opcode (832, "ersx0 ", 0, 0, 1);
	call set_opcode (833, "arn0  ", 0, 0, 1);
	call set_opcode (834, "ersx1 ", 0, 0, 1);
	call set_opcode (835, "arn1  ", 0, 0, 1);
	call set_opcode (836, "ersx2 ", 0, 0, 1);
	call set_opcode (837, "arn2  ", 0, 0, 1);
	call set_opcode (838, "ersx3 ", 0, 0, 1);
	call set_opcode (839, "arn3  ", 0, 0, 1);
	call set_opcode (840, "ersx4 ", 0, 0, 1);
	call set_opcode (841, "arn4  ", 0, 0, 1);
	call set_opcode (842, "ersx5 ", 0, 0, 1);
	call set_opcode (843, "arn5  ", 0, 0, 1);
	call set_opcode (844, "ersx6 ", 0, 0, 1);
	call set_opcode (845, "arn6  ", 0, 0, 1);
	call set_opcode (846, "ersx7 ", 0, 0, 1);
	call set_opcode (847, "arn7  ", 0, 0, 1);
	call set_opcode (848, "spri4 ", 0, 0, 1);
	call set_opcode (849, "spbp4 ", 0, 0, 1);
	call set_opcode (850, "spbp5 ", 0, 0, 1);
	call set_opcode (851, "spri5 ", 0, 0, 1);
	call set_opcode (852, "spri6 ", 0, 0, 1);
	call set_opcode (853, "spbp6 ", 0, 0, 1);
	call set_opcode (854, "spbp7 ", 0, 0, 1);
	call set_opcode (855, "spri7 ", 0, 0, 1);
	call set_opcode (856, "stacq ", 0, 0, 1);
	call set_opcode (858, "ersa  ", 0, 0, 1);
	call set_opcode (860, "ersq  ", 0, 0, 1);
	call set_opcode (862, "scu   ", 0, 0, 1);
	call set_opcode (864, "erx0  ", 0, 0, 1);
	call set_opcode (865, "nar0  ", 0, 0, 1);
	call set_opcode (866, "erx1  ", 0, 0, 1);
	call set_opcode (867, "nar1  ", 0, 0, 1);
	call set_opcode (868, "erx2  ", 0, 0, 1);
	call set_opcode (869, "nar2  ", 0, 0, 1);
	call set_opcode (870, "erx3  ", 0, 0, 1);
	call set_opcode (871, "nar3  ", 0, 0, 1);
	call set_opcode (872, "erx4  ", 0, 0, 1);
	call set_opcode (873, "nar4  ", 0, 0, 1);
	call set_opcode (874, "erx5  ", 0, 0, 1);
	call set_opcode (875, "nar5  ", 0, 0, 1);
	call set_opcode (876, "erx6  ", 0, 0, 1);
	call set_opcode (877, "nar6  ", 0, 0, 1);
	call set_opcode (878, "erx7  ", 0, 0, 1);
	call set_opcode (879, "nar7  ", 0, 0, 1);
	call set_opcode (880, "tsp4  ", 0, 0, 1);
	call set_opcode (882, "tsp5  ", 0, 0, 1);
	call set_opcode (884, "tsp6  ", 0, 0, 1);
	call set_opcode (886, "tsp7  ", 0, 0, 1);
	call set_opcode (888, "lcpr  ", 0, 0, 1);
	call set_opcode (890, "era   ", 0, 0, 1);
	call set_opcode (892, "erq   ", 0, 0, 1);
	call set_opcode (894, "eraq  ", 0, 0, 1);
	call set_opcode (896, "tsx0  ", 0, 0, 1);
	call set_opcode (898, "tsx1  ", 0, 0, 1);
	call set_opcode (900, "tsx2  ", 0, 0, 1);
	call set_opcode (902, "tsx3  ", 0, 0, 1);
	call set_opcode (904, "tsx4  ", 0, 0, 1);
	call set_opcode (906, "tsx5  ", 0, 0, 1);
	call set_opcode (908, "tsx6  ", 0, 0, 1);
	call set_opcode (910, "tsx7  ", 0, 0, 1);
	call set_opcode (912, "tra   ", 0, 0, 1);
	call set_opcode (918, "call6 ", 0, 0, 1);
	call set_opcode (922, "tss   ", 0, 0, 1);
	call set_opcode (924, "xec   ", 0, 0, 1);
	call set_opcode (926, "xed   ", 0, 0, 1);
	call set_opcode (928, "lxl0  ", 0, 0, 1);
	call set_opcode (930, "lxl1  ", 0, 0, 1);
	call set_opcode (932, "lxl2  ", 0, 0, 1);
	call set_opcode (934, "lxl3  ", 0, 0, 1);
	call set_opcode (936, "lxl4  ", 0, 0, 1);
	call set_opcode (938, "lxl5  ", 0, 0, 1);
	call set_opcode (940, "lxl6  ", 0, 0, 1);
	call set_opcode (942, "lxl7  ", 0, 0, 1);
	call set_opcode (946, "ars   ", 0, 0, 1);
	call set_opcode (948, "qrs   ", 0, 0, 1);
	call set_opcode (950, "lrs   ", 0, 0, 1);
	call set_opcode (954, "als   ", 0, 0, 1);
	call set_opcode (956, "qls   ", 0, 0, 1);
	call set_opcode (958, "lls   ", 0, 0, 1);
	call set_opcode (960, "stx0  ", 0, 0, 1);
	call set_opcode (961, "sar0  ", 0, 0, 1);
	call set_opcode (962, "stx1  ", 0, 0, 1);
	call set_opcode (963, "sar1  ", 0, 0, 1);
	call set_opcode (964, "stx2  ", 0, 0, 1);
	call set_opcode (965, "sar2  ", 0, 0, 1);
	call set_opcode (966, "stx3  ", 0, 0, 1);
	call set_opcode (967, "sar3  ", 0, 0, 1);
	call set_opcode (968, "stx4  ", 0, 0, 1);
	call set_opcode (969, "sar4  ", 0, 0, 1);
	call set_opcode (970, "stx5  ", 0, 0, 1);
	call set_opcode (971, "sar5  ", 0, 0, 1);
	call set_opcode (972, "stx6  ", 0, 0, 1);
	call set_opcode (973, "sar6  ", 0, 0, 1);
	call set_opcode (974, "stx7  ", 0, 0, 1);
	call set_opcode (975, "sar7  ", 0, 0, 1);
	call set_opcode (976, "stc2  ", 0, 0, 1);
	call set_opcode (978, "stca  ", 0, 1, 1);
	call set_opcode (980, "stcq  ", 0, 1, 1);
	call set_opcode (982, "sreg  ", 0, 0, 1);
	call set_opcode (984, "sti   ", 0, 0, 1);
	call set_opcode (985, "sra   ", 0, 0, 1);
	call set_opcode (986, "sta   ", 0, 0, 1);
	call set_opcode (988, "stq   ", 0, 0, 1);
	call set_opcode (990, "staq  ", 0, 0, 1);
	call set_opcode (992, "lprp0 ", 0, 0, 1);
	call set_opcode (993, "lar0  ", 0, 0, 1);
	call set_opcode (994, "lprp1 ", 0, 0, 1);
	call set_opcode (995, "lar1  ", 0, 0, 1);
	call set_opcode (996, "lprp2 ", 0, 0, 1);
	call set_opcode (997, "lar2  ", 0, 0, 1);
	call set_opcode (998, "lprp3 ", 0, 0, 1);
	call set_opcode (999, "lar3  ", 0, 0, 1);
	call set_opcode (1000, "lprp4 ", 0, 0, 1);
	call set_opcode (1001, "lar4  ", 0, 0, 1);
	call set_opcode (1002, "lprp5 ", 0, 0, 1);
	call set_opcode (1003, "lar5  ", 0, 0, 1);
	call set_opcode (1004, "lprp6 ", 0, 0, 1);
	call set_opcode (1005, "lar6  ", 0, 0, 1);
	call set_opcode (1006, "lprp7 ", 0, 0, 1);
	call set_opcode (1007, "lar7  ", 0, 0, 1);
	call set_opcode (1010, "arl   ", 0, 0, 1);
	call set_opcode (1012, "qrl   ", 0, 0, 1);
	call set_opcode (1014, "lrl   ", 0, 0, 1);
	call set_opcode (1016, "gtb   ", 0, 0, 1);
	call set_opcode (1017, "lra   ", 0, 0, 1);
	call set_opcode (1018, "alr   ", 0, 0, 1);
	call set_opcode (1020, "qlr   ", 0, 0, 1);
	call set_opcode (1022, "llr   ", 0, 0, 1);

	CDSA.sections (1).p = addr (OI);
	CDSA.sections (1).len = size (OI);
	CDSA.sections (1).struct_name = "OI";
	CDSA.seg_name = "op_mnemonic_";
	CDSA.num_exclude_names = 0;
	CDSA.exclude_array_ptr = null ();
	string (CDSA.switches) = ""b;
	CDSA.switches.have_text = "1"b;

	call create_data_segment_ (addr (CDSA), code);
	if code ^= 0
	then call com_err_ (code, "op_mnemonic_");
	return;

set_opcode:
     procedure (Opx, Name, Dtype, Num_descs, Num_words);
	declare Opx		 fixed bin;
	declare Name		 char (6);
	declare Dtype		 fixed bin (2);
	declare Num_descs		 fixed bin (5);
	declare Num_words		 fixed bin (8);

	op_mnemonic_ptr = addr (OI.op_mnemonic_ (Opx));
	op_mnemonic.name = Name;
	op_mnemonic.dtype = Dtype;
	op_mnemonic.num_desc = Num_descs;
	op_mnemonic.num_words = Num_words;
     end set_opcode;
     end;




		    pl1_decat_char_.pl1             11/11/89  1103.4r   11/11/89  0803.8       11520



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

pl1_decat_char_:	proc(s,c,t) returns(char(*));

dcl	(s,c) char(*),
	t bit(3),
	(i,l) fixed bin(15),
	(bin,index,length,substr) builtin;

	l = length(c);
	if l=0
	then	if substr(t,3,1)
		 then	goto case(7);
		 else	goto case(0);

	i = index(s,c);
	if i = 0
	then	if substr(t,1,1)
		 then	goto case(7);
		 else	goto case(0);

	goto case(bin(t));

case(0):	return("");
case(1):	return(substr(s,i+l));
case(2):	return(c);
case(3):	return(substr(s,i));
case(4):	return(substr(s,1,i-1));
case(5):	return(substr(s,1,i-1) || substr(s,i+l));
case(6):	return(substr(s,1,i+l-1));
case(7):	return(s);

	end;




		    plus.pl1                        11/11/89  1103.4r   11/11/89  0803.9       53415



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* Arithmetic active functions

	FUNCTION			VALUE
	plus A1 A2 ... An		0 + A1 + A2 + ... + An
	minus A1 A2		A1 - A2  or  -A1 if A2 is not specified
	times A1 A2 ... An		1 * A1 * A2 * ... * An
	divide A1 A2		trunc(A1 / A2)
	quotient A1 A2		A1 / A2
	mod A1 A2			mod(A1,A2)
	max A1 A2 ... An		max(A1,A2, ..., An)
	min A1 A2 ... An		min(A1,A2, ..., An)
	trunc A1			trunc(A1)
	floor A1			floor(A1)
	ceil A1			ceil(A1)

   Each Ai is the character string representation of a valid PL/I decimal number,
   either fixed or float.  Calculations are performed internally using float dec(59)
   arithmetic.  The result is in I-, F-, or E-format depending on its value.  All of
   these active functions can be called as functions or as commands, in which case
   they print the result.

   Initial Version: 27 January 1974 by Barry L. Wolman */

/* Modified 7/8/76 by S. Herbst */
/* Fixed min and others with no args 07/07/81 S. Herbst */

plus:	proc;

dcl	op char(8) aligned,
	(number1,number2) float dec(59),
	result char(72) varying,
	code fixed bin(35),
	not_active_function bit(1),
	(i,count) fixed bin,
	get_arg variable entry(fixed bin,ptr,fixed bin,fixed bin(35)),
	(ap,ap1) ptr,
	(al,al1) fixed bin,
	answer char(al1) varying based(ap1),
	arg char(al) based(ap),
	(mod,max,min,fixed,convert,string,trunc,floor,ceil) builtin,
	(conversion, overflow, underflow, zerodivide) condition;

dcl	(cu_$arg_ptr,cu_$af_arg_ptr,cu_$af_return_arg) entry(fixed bin,ptr,fixed bin,fixed bin(35)),
	cu_$arg_count entry returns(fixed bin),
	numeric_to_ascii_ entry(float dec(59),fixed bin,char(72) varying),
	(ioa_,com_err_,active_fnc_err_) options(variable);

dcl	(error_table_$not_act_fnc,
	 error_table_$wrong_no_of_args) fixed bin(35) ext static;

dcl	1 op_type,
	2 multi	bit(1) unaligned,
	2 unary	bit(1) unaligned;

	op = "plus";
	string(op_type) = "11"b;
	goto join;

minus:	entry;

	op = "minus";
	string(op_type) = "00"b;
	goto join;

times:	entry;

	op = "times";
	string(op_type) = "11"b;
	goto join;

divide:	entry;

	op = "divide";
	string(op_type) = "00"b;
	goto join;

quotient: entry;

	op = "quotient";
	string(op_type) = "00"b;
	goto join;

mod:	entry;

	op = "mod";
	string(op_type) = "00"b;
	goto join;

max:	entry;

	op = "max";
	string(op_type) = "10"b;
	goto join;

min:	entry;

	op = "min";
	string(op_type) = "10"b;
	goto join;

trunc:	entry;

	op = "trunc";
	string(op_type) = "01"b;
	goto join;

floor:	entry;

	op = "floor";
	string(op_type) = "01"b;
	goto join;

ceil:	entry;

	op = "ceil";
	string(op_type) = "01"b;
	goto join;

join:	call cu_$af_return_arg(count,ap1,al1,code);

	not_active_function = code = error_table_$not_act_fnc;

	if not_active_function
	then do;
	     count = cu_$arg_count();
	     get_arg = cu_$arg_ptr;
	     code = 0;
	     end;
	else do;
	     if code ^= 0 then go to simple_err;

	     get_arg = cu_$af_arg_ptr;
	     end;

	if count = 0 then do;
	     if op = "plus" | op = "minus" then number1 = 0;
	     else if op = "times" then number1 = 1;
	     else go to wrong_args;
	     go to output;
	end;

	if (count ^= 1 & unary & ^ multi)
	 | (count < 2 & ^ unary & op ^= "minus")
	 | (count > 2 & ^ multi)
	then do;
wrong_args:    code = error_table_$wrong_no_of_args;
simple_err:    if not_active_function then call com_err_ (code, op);
	     else call active_fnc_err_ (code, op);
	     go to exit;
	     end;

	on conversion goto not_numeric;
	on overflow goto too_big;
	on underflow goto too_small;
	on zerodivide goto zero_divide;

	call get_arg(1,ap,al,code);

	if code ^= 0 then call gripe("");

	number1 = convert(number1,arg);

	if count = 1 & op = "minus" then number1 = -number1;

	if unary
	then do;
	     if op = "trunc" then number1 = trunc(number1);
	     if op = "floor" then number1 = floor(number1);
	     if op = "ceil" then number1 = ceil(number1);
	     end;

	do i = 2 to count;
	     call get_arg(i,ap,al,code);

	     if code ^= 0 then call gripe("");

	     number2 = convert(number2,arg);

	     if op = "plus" then number1 = number1 + number2;
	     if op = "minus" then number1 = number1 - number2;
	     if op = "times" then number1 = number1 * number2;
	     if op = "divide" then number1 = trunc (number1 / number2);
	     if op = "quotient" then number1 = number1 / number2;
	     if op = "mod" then number1 = mod(number1, number2);
	     if op = "max" then number1 = max(number1, number2);
	     if op = "min" then number1 = min(number1, number2);

	     end;

output:
	call numeric_to_ascii_(number1,0,result);
	if substr (result, 1, 1) = "0" & length (result) > 60 then do;	/* trim it so it will work better */
	     result = substr (result, 1, length (result) - 1);
	     end;

	if not_active_function then call ioa_(result);
	else answer = result;

	return;

zero_divide:
	if not_active_function then call com_err_(0,op,"Attempt to divide by zero.");
	else call active_fnc_err_(0,op,"Attempt to divide by zero.");
	return;

not_numeric:
	call gripe("""^a"" is non-numeric");
	return;

too_big:
	call gripe("overflow");
	return;

too_small:
	call gripe("underflow");
	return;

gripe:	     proc(s);

dcl	     s char(*);

	     if not_active_function then call com_err_(code,op,s,arg);
	     else call active_fnc_err_(code,op,s,arg);

	     goto exit;
	     end;

exit:	end;




		    relocate_instruction_.pl1       11/11/89  1103.4r   11/11/89  0803.8       67995



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


relocate_instruction_: procedure (from, to, code);

/* Fixed to relocate tsxN and tspN instructions properly 04/25/84 S. Herbst */
/* Removed above fix, since it causes some after breaks after calls to be ignored 12/04/84 Steve Herbst */
/* Modified to move code into hardcore for bce, Keith Loepere, March 1985. */

dcl (from pointer,					/* to instruction to be relocated */
     to pointer,					/* location to relocate it to */
     p_delta fixed bin (17),				/* what to add to instr offset */
     p_instruction_len fixed bin,			/* length, with eis descr */
     p_special fixed bin,				/* eis descrs */
     code fixed bin (35)) parameter;			/* error code */

dcl  (op_index, tra_index, tra_target) fixed bin;
dcl  tra_modifier bit (6) unaligned;
dcl  (op_name, new_op_name) char (6);
dcl  delta fixed bin (17);				/* offset from "from" to "to" */
dcl  relocate_sw bit (1);
dcl  instruction_len fixed bin;
dcl  special fixed bin;
dcl  new_operand bit (36) aligned based (addr (operand));
dcl  i fixed bin;
dcl  (high_bound, low_bound) fixed bin;
dcl  word bit (36) aligned based;

dcl 1 instruction aligned,				/* overlay for normal instruction */
    2 address fixed bin (17) unaligned,
    2 opcode bit (10) unaligned,
    2 inst_pad bit (2) unaligned,
    2 modifier bit (6) unaligned;

dcl 1 eis_mod aligned,				/* format of the modifier */
    2 mod_pad bit (2) unaligned,
    2 indirect bit (1) unaligned,
    2 register bit (4) unaligned;

dcl 1 operand aligned,				/* overlay for descriptor or indirect word */
    2 operand_addr fixed bin (17) unaligned,
    2 op_pad bit (14) unaligned,
    2 operand_reg bit (4) unaligned;

dcl  mod_offset (3) fixed bin internal static options (constant) init
    (30, 12, 3);					/* offset of modifier fields in an EIS inst */

dcl  inst_length_ entry (ptr, fixed bin) returns (fixed bin);

dcl  error_table_$action_not_performed fixed bin (35) external static;

dcl (addr, addrel, bin, bit, fixed, hbound, lbound, rel, string, substr, unspec) builtin;

	delta = fixed (rel (from), 18, 0) - fixed (rel (to), 18, 0); /* compute for later */
	instruction_len = inst_length_ (from, special);
	if instruction_len = 0 then goto arrgh;

common:	unspec (instruction) = from -> word;
	op_index = fixed (instruction.opcode, 10, 0);
	op_name = op_mnemonic_$op_mnemonic (op_index).opcode;

	if instruction_len = 1 then do;		/* normal instruction, check for ic and ic* modifiers */
	     relocate_sw = "0"b;
	     if special = 0 then do;
		if instruction.modifier = "110100"b then  /* *ic, cannot relocate target */
		     goto arrgh;
		if instruction.modifier = "000100"b | instruction.modifier = "010100"b then do;
		     relocate_sw = "1"b;
		     instruction.address = instruction.address + delta;
		end;
	     end;

/* The following code is commented out because it causes breaks after call
   statements to be ignored. It was originally put here to prevent the
   following bug: Suppose you -
	1. Set a break after a call statement.
	2. Execute the call statement and stop in the called program.
	3. Reset the break.
	4. Return from the call.
   You return to the instruction in the break code after the instruction in
   the break code that actually made the call, but the break code is no longer
   there. This happened in rare cases to users and caused unsightly faults.

   One way to do a break after a tsxN or tspN instruction is to really set a
   before break at the next instruction, but mark it with a flag that tells
   the rest of probe to pretend that it's an after break at the right
   instruction. I leave this as a future change.  Steve Herbst 12/04/84 */

/*OUT	     if substr (op_name, 1, 3) = "tsp" | substr (op_name, 1, 3) = "tsx" then do;
/*OUT		tra_target = instruction.address;	/* save the computed target of transfer */
/*OUT		if relocate_sw then tra_target = tra_target - 1;
/*OUT		tra_modifier = instruction.modifier;
/*OUT		if substr (op_name, 1, 3) = "tsp" then new_op_name = "epp" || substr (op_name, 4, 1);
/*OUT		else new_op_name = "eax" || substr (op_name, 4, 1);
/*OUT
/*OUT		low_bound = lbound (op_mnemonic_$op_mnemonic, 1);
/*OUT		high_bound = hbound (op_mnemonic_$op_mnemonic, 1);
/*OUT						/* find out what number a "tra" is */
/*OUT		do i = low_bound to high_bound while
/*OUT		     (op_mnemonic_$op_mnemonic (i).opcode ^= "tra"); end;
/*OUT		if i > high_bound then go to NOT_TS;	/* should never happen */
/*OUT		tra_index = i;
/*OUT						/* now find out what number opcode we're creating */
/*OUT		do i = low_bound to high_bound while
/*OUT		     (op_mnemonic_$op_mnemonic (i).opcode ^= new_op_name); end;
/*OUT		if i > high_bound then go to NOT_TS;	/* tsxN with unrecognized N? */
/*OUT
/*OUT		unspec (instruction) = "0"b;
/*OUT		instruction.opcode = bit (bin (i, 10), 10);
/*OUT		instruction.address = fixed (rel (from), 18) + 1;
/*OUT		instruction.modifier = "000000"b;
/*OUT		to -> word = unspec (instruction);
/*OUT
/*OUT		instruction.opcode = bit (bin (tra_index, 10), 10);
/*OUT		instruction.address = tra_target;
/*OUT		instruction.modifier = tra_modifier;
/*OUT		addrel (to, 1) -> word = unspec (instruction);
/*OUT	     end;
/*OUT	     else  OUT*/

NOT_TS:		to -> word = unspec (instruction);	/* move it to its new home */
	end;

	else do;					/* EIS instruction	*/
	     to -> word = unspec (instruction);	/* first word requires no relocation */
	     do i = 1 to special;			/* process each descriptor */
		string (eis_mod) = substr (unspec (instruction), mod_offset (i), 7);
		string (new_operand) = addrel (from, i) -> word; /* pick up descriptor or indirect word */
		if indirect then do;		/* indirect word */
		     if register = "0100"b then	/* descriptor will ultimately have an ic mod */
			goto arrgh;		/* same problem as *ic */
		     if operand_reg = "0100"b then	/* indirect word has an ic modifier */
			operand_addr = operand_addr + delta;
		end;
		else if register = "0100"b then	/* descriptor with ic mod from instruction */
		     operand_addr = operand_addr + delta;
		addrel (to, i) -> word = string (new_operand); /* move this operand to new location */
	     end;

	     do i = special + 1 to instruction_len - 1;	/* process non-EIS descriptors, eg.: arg 100,ic */
		unspec (instruction) = addrel (from, i) -> word;
		if instruction.modifier = "110100"b then  /* relocate like a simple instruction */
		     goto arrgh;
		if instruction.modifier = "000100"b | instruction.modifier = "010100"b then
		     instruction.address = instruction.address + delta;
		addrel (to, i) -> word = unspec (instruction);
	     end;
	end;

	return;

arrgh:	code = error_table_$action_not_performed;
	return;
%page;
bce_relocate_instruction_: entry (from, to, p_delta, p_instruction_len, p_special, code);

	delta = p_delta;
	instruction_len = p_instruction_len;
	special = p_special;
	go to common;
%page;
%include op_mnemonic_format;


     end relocate_instruction_;





		    substr.pl1                      11/11/89  1103.4rew 11/11/89  0803.9      160434



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



/****^  HISTORY COMMENTS:
  1) change(80-10-31,Herbst), approve(), audit(), install():
     TR6700 Add uppercase -leading 10/31/80 S. Herbst
  2) change(83-10-03,Spitzer), approve(), audit(), install():
     TR11275 correct error msg for cpch 10/03/83 C. Spitzer
  3) change(84-01-03,Loepere), approve(), audit(), install():
     use ioa_ for bce compatibility 01/03/84 K. Loepere
  4) change(85-01-04,Lippard), approve(85-01-23,MCR7151),
     audit(85-11-07,Spitzer), install(86-02-21,MR12.0-1024):
     Add reverse_substr 01/04/85 Jim Lippard
                                                   END HISTORY COMMENTS */


substr:	procedure;

     dcl
	Larg (3)			fixed bin,
	Lret			fixed bin,
	Nargs			fixed bin,
	Npic			pic "(10)z9",
	Parg (3)			ptr,
	Pret			ptr,
	Scommand			bit (1) aligned,
	arg_ptr			entry (fixed bin, ptr, fixed bin, fixed bin(35)) variable,
	args_sw			bit (1),
	bit3			bit(3) aligned,
	bit4			bit(4) aligned,
	char3			char(3) aligned,
	char4			char(4) aligned,
         (cleanup, conversion)	condition,
	code			fixed bin(35),
	e			fixed bin,
	error			entry options (variable) variable,
         (i, j, n)			fixed bin,
	leading_sw		bit (1);
	
     dcl
	arg1			char(Larg(1)) based (Parg(1)),
	arg2			char(Larg(2)) based (Parg(2)),
	arg3			char(Larg(3)) based (Parg(3)),
	ret			char(Lret) varying based (Pret);

     dcl (addr, after, before, bit, bool, character, collate, collate9, convert, copy, decat,
	high, high9, index, length, low, ltrim, min, null, reverse, rtrim, search,
	substr, translate, verify)
				builtin;

     dcl
	active_fnc_err_		entry options (variable),
	com_err_			entry options (variable),
         (cu_$af_return_arg,
	cu_$af_arg_ptr,
	cu_$arg_ptr)		entry (fixed bin, ptr, fixed bin, fixed bin(35)),
	cu_$arg_count		entry returns (fixed bin),
         (get_temp_segment_,
	release_temp_segment_)	entry (char(*), ptr, fixed bin(35)),
	ioa_			entry() options(variable);

     dcl
	UP_A			char (2) int static options (constant) init ("^a"),
	UPPERCASE			char (26) aligned int static options (constant) init
					("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
	LOWERCASE			char (26) aligned int static options (constant) init
					("abcdefghijklmnopqrstuvwxyz"),
         (error_table_$bad_arg,
	error_table_$bad_conversion,
	error_table_$badopt,
	error_table_$wrong_no_of_args)
				fixed bin(35) ext static,

	ep (28)			char(15) int static options(constant) init (
				     "after",	/* Name of entry points supported herein.	*/
				     "before",
				     "bool",
				     "collate",
				     "collate9",
				     "copy_characters",
				     "decat",
				     "high",
				     "high9",
				     "index",
				     "length",
				     "low",
				     "lower_case",
				     "ltrim",
				     "reverse",
				     "reverse_after",
				     "reverse_before",
				     "reverse_decat",
				     "reverse_index",
				     "reverse_search",
				     "reverse_substr",
				     "reverse_verify",
				     "rtrim",
				     "search",
				     "substr",
				     "translate",
				     "upper_case",
				     "verify"),
	max_args (28)		fixed bin int static options(constant) init (
				     2,   2,   3,   0,   0,   2,   3,   1,   1,   2,  
				     1,   1, 999,   2,   1,   2,   2,   3,   2,   2,  
				     3,   2,   2,   2,   3,   3, 999,   2),  
	min_args (28)		fixed bin int static options(constant) init (
				     2, 2, 3, 0, 0, 2, 3, 1, 1, 2,
				     1, 1, 1, 1, 1, 2, 2, 3, 2, 2,
				     2, 2, 1, 2, 2, 2, 1, 2),
	options (28)		char(52) int static options(constant) init (
				     "source_string indexing_string",
				     "source_string indexing_string",
				     "bit_string bit_string 4_bit_string",
				     "",
				     "",
				     "string number_of_copies",
				     "source_string indexing_string 3_bit_string",
				     "number_of_copies",
				     "number_of_copies",
				     "source_string indexing_string",
				     "string",
				     "number_of_copies",
				     "strings",
				     "source_string search_string",
				     "string",
				     "source_string indexing_string",
				     "source_string indexing_string",
				     "source_string indexing_string 3_bit_string",
				     "source_string indexing_string",
				     "source_string search_string",
				     "string starting_index_number {length}",
				     "source_string verify_string",
				     "source_string search_string",
				     "source_string search_string",
				     "string starting_index_number {length}",
				     "string translate_to_string {translate_from_string}",
				     "strings",
				     "source_string verify_string"),
	sys_info$max_seg_size	fixed bin(35) ext static;

      dcl TRUE			bit (1) aligned internal static options (constant) init ("1"b),
	FALSE			bit (1) aligned internal static options (constant) init ("0"b);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	e = 25;					/* substr					*/
	go to COMMON;


after:  af:	entry;

	e = 1;
	go to COMMON;


before:  be:	entry;

	e = 2;
	go to COMMON;


bool:	entry;

	e = 3;
	go to COMMON;


collate:	entry;

	e = 4;
	go to COMMON;


collate9:	entry;

	e = 5;
	go to COMMON;


copy_characters:  cpch:	entry;

	e = 6;
	go to COMMON;


decat:	entry;

	e = 7;
	go to COMMON;


high:	entry;

	e = 8;
	go to COMMON;


high9:	entry;

	e = 9;
	go to COMMON;


index:	entry;

	e = 10;
	go to COMMON;


length:  ln:	entry;

	e = 11;
	go to COMMON;


low:	entry;

	e = 12;
	go to COMMON;


lower_case: lowercase:	entry;

	e = 13;
	go to COMMON;


ltrim:	entry;

	e = 14;
	go to COMMON;


reverse:  rv:	entry;

	e = 15;
	go to COMMON;


reverse_after:  rvaf:	entry;

	e = 16;
	go to COMMON;


reverse_before:  rvbe:	entry;

	e = 17;
	go to COMMON;


reverse_decat:  rvdecat:	entry;

	e = 18;
	go to COMMON;


reverse_index:  rvindex:	entry;

	e = 19;
	go to COMMON;


reverse_search:  rvsrh:	entry;

	e = 20;
	go to COMMON;

reverse_substr:  rvsubstr:	entry;

	e = 21;
	go to COMMON;

reverse_verify:  rvverify:	entry;

	e = 22;
	go to COMMON;


rtrim:	entry;

	e = 23;
	go to COMMON;


search:  srh:	entry;

	e = 24;
	go to COMMON;


translate:	entry;

	e = 26;
	go to COMMON;


upper_case: uppercase:	entry;

	e = 27;
	go to COMMON;


verify:	entry;

	e = 28;
	go to COMMON;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
COMMON:	call cu_$af_return_arg (Nargs, Pret, Lret, code);	/* get arg count, see how called, get ret val.	*/
	if code = 0 then do;			/* called as an active function.		*/
	     error = active_fnc_err_;
	     arg_ptr = cu_$af_arg_ptr;
	     Scommand = FALSE;
	     end;
	else do;					/* called as a command.			*/
	     error = com_err_;
	     arg_ptr = cu_$arg_ptr;
	     Scommand = TRUE;
	     Nargs = cu_$arg_count();
	     Pret = null;
	     on cleanup call janitor();
	     call get_temp_segment_ (ep(e), Pret, code);
	     if code ^= 0 then go to NO_TEMP_SEG;
	     Lret = (sys_info$max_seg_size - 1) * 4;
	     end;

	if Nargs < min_args(e) then			/* too few input arguments.			*/
	     go to wnoa;
	if Nargs > max_args(e) then			/* too many input arguments.			*/
	     go to wnoa;
	do i = 1 to min (Nargs, 3);			/* address input arguments.			*/
	     call arg_ptr (i, Parg(i), Larg(i), code);
	     end;		

	ret = "";					/* clear return arg.			*/
	go to do(e);				/* process according to input requirements.	*/

do( 1):						/* after.					*/
	ret = double_quotes(after(arg1,arg2));
	go to return;

do( 2):						/* before					*/
	ret = double_quotes(before (arg1, arg2));
	go to return;

do( 3):						/* bool					*/
	i = verify(arg1, "01");
	if i > 0 then do;
	     i = 1;
	     go to bad_conversion;
	     end;
	i = verify(arg2, "01");
	if i > 0 then do;
	     i = 2;
	     go to bad_conversion;
	     end;
	if Larg(3) ^= 4 then do;
	     i = 4;
	     go to bad_bit_string;
	     end;
	char4 = arg3;
	i = verify(char4, "01");
	if i > 0 then do;
	     i = 3;
	     go to bad_conversion;
	     end;
	bit4 = bit(char4, 4);
	ret = character(bool(bit(arg1), bit(arg2), bit4));
	go to return;

do( 4):						/* collate				*/
	if Scommand then				/* when invoked as a command, print collating seq	*/
	     ret = collate();
	else do;
	     ret = """";
	     ret = ret || substr (collate(),1,35);
	     ret = ret || substr (collate(),35);	/* double the quote in the quoted string.	*/
	     ret = ret || """";
	     end;
	go to return;

do( 5):						/* collate9				*/
	if Scommand then
	     ret = collate9();
	else do;
	     ret = """";
	     ret = ret || substr (collate(),1,35);
	     ret = ret || substr (collate9(),35);
	     ret = ret || """";
	     end;
	go to return;

do( 6):						/* copy					*/
	on conversion begin;
	     i = 2;
	     go to bad_conversion;
	     end;
	n = convert(n, arg2);
	revert conversion;
	if n < 0 then do;
	     i = 2;
	     go to nonnegative_arg;
	     end;
	else if n = 0 then;
	else
	     ret = double_quotes(copy (arg1, n));
	go to return;

do( 7):						/* decat					*/
	if Larg(3) ^= 3 then do;
	     i = 3;
	     go to bad_bit_string;
	     end;
	char3 = arg3;
	i = verify (char3, "01");
	if i > 0 then do;
	     i = 3;
	     go to bad_conversion;
	     end;
	bit3 = bit(char3, 3);
	ret = double_quotes(decat (arg1, arg2, bit3));
	go to return;

do( 8):						/* high					*/
do( 9):						/* high9					*/
do(12):						/* low					*/
	on conversion begin;
	     i = 1;
	     go to bad_conversion;
	     end;
	n = convert(n, arg1);
	revert conversion;
	if n < 0 then do;
	     i = 1;
	     go to nonnegative_arg;
	     end;
	else if n = 0 then
	     go to return;
	else go to do_hl(e);
do_hl(8):
	ret = high(n);
	go to return;
do_hl(9):
	ret = high9(n);
	go to return;
do_hl(12):
	ret = low(n);
	go to return;

do(10):						/* index					*/
	i = index (arg1, arg2);
ret_num:	Npic = i;
	ret = ltrim(Npic);
	go to return;

do(11):						/* length					*/
	i = Larg(1);
	go to ret_num;

do(13):						/* lower_case				*/
	do i = 1 to Nargs;
	     call arg_ptr (i, Parg (1), Larg (1), 0);
	     if ret ^= "" then ret = ret || " ";
	     ret = ret || double_quotes (translate (arg1, LOWERCASE, UPPERCASE));
	end;
	go to return;

do(14):						/* ltrim					*/
	if Nargs = 2 then
	     ret = double_quotes(ltrim(arg1, arg2));
	else ret = double_quotes(ltrim(arg1));
	go to return;

do(15):						/* reverse				*/
	if Larg(1) <= 0 then;
	else
	     ret = double_quotes(reverse (arg1));
	go to return;

do(16):						/* reverse after				*/
	if index(arg1, arg2) > 0 then
	     ret = double_quotes(reverse(before(reverse(arg1), reverse(arg2))));
	else ret = "";
	go to return;

do(17):						/* reverse before				*/
	if index(arg1, arg2) > 0 then
	     ret = double_quotes(reverse(after(reverse(arg1), reverse(arg2))));
	else ret = double_quotes(arg1);
	go to return;

do(18):						/* reverse decat				*/
	if Larg(3) ^= 3 then do;
	     i = 3;
	     go to bad_bit_string;
	     end;
	char3 = arg3;
	i = verify (char3, "01");
	if i > 0 then do;
	     i = 3;
	     go to bad_conversion;
	     end;
	bit3 = bit(char3, 3);
	if index(arg1, arg2) > 0 then
	     ret = double_quotes(reverse(decat(reverse(arg1), reverse(arg2), reverse(bit3))));
	else ret = double_quotes(decat(arg1, arg2, bit3));
	go to return;

do(19):						/* reverse_index				*/
	i = index (reverse(arg1), reverse(arg2));
	if i > 0 then
	     i = Larg(1) - i + 2 - Larg(2);
	go to ret_num;

do(20):						/* reverse_search				*/
	i = search (reverse(arg1), arg2);
	if i > 0 then
	     i = Larg(1) - i + 1;
	go to ret_num;

do(21):						/* reverse_substr				*/
	on conversion begin;
	     i = 2;
	     go to bad_conversion;
	     end;
	i = convert(i, arg2);
	revert conversion;
	if Nargs = 3 then do;
	     on conversion begin;
		i = 3;
		go to bad_conversion;
		end;
	     j = convert(j, arg3);
	     revert conversion;
	     end;
	else
	     j = Larg(1);
	if i <= 0 then do;
	     i = 2;
	     go to positive_arg;
	     end;
	else if i > Larg(1) then;
	else if j < 0 then do;
	     i = 3;
	     go to nonnegative_arg;
	     end;
	else if j = 0 then;
	else do;
	     if i+j-1 > Larg(1) then
	          j = Larg(1) - i + 1;
	     ret = double_quotes(reverse (substr (reverse (arg1), i, j)));
	     end;
	go to return;

do(22):						/* reverse_verify				*/
	i = verify (reverse(arg1), arg2);
	if i > 0 then
	     i = Larg(1) - i + 1;
	go to ret_num;

do(23):						/* rtrim					*/
	if Nargs = 2 then
	     ret = double_quotes(rtrim(arg1, arg2));
	else ret = double_quotes(rtrim(arg1));
	go to return;

do(24):						/* search					*/
	i = search (arg1, arg2);
	go to ret_num;

do(25):						/* substr					*/
	on conversion begin;
	     i = 2;
	     go to bad_conversion;
	     end;
	i = convert(i, arg2);
	revert conversion;
	if Nargs = 3 then do;
	     on conversion begin;
		i = 3;
		go to bad_conversion;
		end;
	     j = convert(j, arg3);
	     revert conversion;
	     end;
	else
	     j = Larg(1);
	if i <= 0 then do;
	     i = 2;
	     go to positive_arg;
	     end;
	else if i > Larg(1) then;
	else if j < 0 then do;
	     i = 3;
	     go to nonnegative_arg;
	     end;
	else if j = 0 then;
	else do;
	     if i+j-1 > Larg(1) then
		j = Larg(1) - i + 1;
	     ret = double_quotes(substr (arg1, i, j));
	     end;
	go to return;

do(26):						/* translate				*/
	if Nargs = 2 then
	     ret = double_quotes(translate (arg1, arg2));
	else
	     ret = double_quotes(translate (arg1, arg2, arg3));
	go to return;

do(27):						/* upper_case				*/
	args_sw, leading_sw = "0"b;
	do i = 1 to Nargs;
	     call arg_ptr (i, Parg (1), Larg (1), 0);
	     if ^args_sw & substr (arg1, 1, 1) = "-" then
		if arg1 = "-leading" then leading_sw = "1"b;
		else if arg1 = "-arguments" | arg1 = "-ag" then args_sw = "1"b;
		else do;
		     call error (error_table_$badopt, "uppercase", "^a", arg1);
		     return;
		end;
	     else do;
		args_sw = "1"b;
		if leading_sw then do;
		     if ret ^= "" then ret = ret || " ";
		     ret = ret || double_quotes (arg1);
		end;
		else do;
		     if ret ^= "" then ret = ret || " ";
		     ret = ret || double_quotes (translate (arg1, UPPERCASE, LOWERCASE));
		end;
	     end;
	end;

	if leading_sw then do;
	     substr (ret, 1, 1) = translate (substr (ret, 1, 1), UPPERCASE, LOWERCASE);
	     do i = 2 to length (ret);
		if index (LOWERCASE, substr (ret, i, 1)) ^= 0 then
		     if index (UPPERCASE || LOWERCASE || "'-", substr (ret, i - 1, 1)) = 0 then
						/* lowercase alpha preceded by nonalpha -> upper */
			substr (ret, i, 1) = translate (substr (ret, i, 1), UPPERCASE, LOWERCASE);
	     end;
	end;
	go to return;

do(28):						/* verify					*/
	i = verify (arg1, arg2);
	go to ret_num;

return:	if Scommand then do;
	     call ioa_ (UP_A, ret);
	     call release_temp_segment_ (ep(e), Pret, code);
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


positive_arg:
	j = 1;
	go to bad_arg;
nonnegative_arg:
	j = 2;
bad_arg:	Parg(1) = Parg(i);
	Larg(1) = Larg(i);
	call error (error_table_$bad_arg, ep(e), " ^a
  Argument ^d must be a ^[positive^;nonnegative^] integer.", arg1, i, j);
	call janitor();
	return;

wnoa:	call error (error_table_$wrong_no_of_args, ep(e), "
  Usage:  ^[[^]^a ^a^[]^]", ^Scommand, ep(e), options(e), ^Scommand);
	call janitor();
	return;

NO_TEMP_SEG:
	call error (code, ep(e), "^/While obtaining a temporary segment.");
	return;

bad_bit_string:
	call error (error_table_$bad_arg, ep(e), " ^a
  Third argument must be a bit string of length ^d.
  Usage:	^[[^]^a ^a^[]^]", arg3, i, ^Scommand, ep(e), options(e), ^Scommand);
	call janitor();
	return;

bad_conversion:
	Parg(1) = Parg(i);
	Larg(1) = Larg(i);
	call error (error_table_$bad_conversion, ep(e), " ^a
  Usage:  ^[[^]^a ^a^[]^]", arg1, ^Scommand,ep(e), options(e), ^Scommand);
	call janitor();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


double_quotes:	procedure (string) returns (char(*) varying);
						/* internal procedure to double all quotes in	*/
						/* a string.				*/

     dcl	string			char(*);

     dcl (i, j)			fixed bin;


     dcl 	copied_string		char(length(string)*2+2) varying;

     dcl	string_begin		char(i-1) based (addr(string_array(j))),
	string_end		char(length(string)-(j-1)) based(addr(string_array(j))),
	string_array (length(string))	char(1) based (addr(string));

	if Scommand then return (string);
	i = search(string,"""");
	if i = 0 then return("""" || string || """");
	j = 1;
	copied_string = """";
	do while (i > 0);
	     copied_string = copied_string || string_begin;
	     copied_string = copied_string || """""";
	     j = i+j;
	     i = search (string_end, """");
	     end;
	copied_string = copied_string || string_end;
	copied_string = copied_string || """";
	return (copied_string);


	end double_quotes;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


janitor: procedure;

	if  Scommand  &  Pret ^= null  then
	     call release_temp_segment_ (ep(e), Pret, code);

	end janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


	end substr;




		    pipe_.pl1                       11/11/89  1103.4rew 11/11/89  0803.9      214155



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


/****^  HISTORY COMMENTS:
  1) change(87-07-08,GWMay), approve(87-07-08,MCR7730), audit(87-08-10,JRGray),
     install(87-09-10,MR12.1-1104):
     Created as a service routine for "command_processor_".
  2) change(87-09-10,GWMay), approve(87-09-10,MCR7730), audit(87-09-10,GDixon),
     install(87-09-10,MR12.1-1104):
     Added any_other handlers and ips interrupt masking. Added the get_word
     function for more complete analysis of the attach description. Simplified
     the pipe_info structure. Changed the pipe_info structure pointer to be
     internal static. Combined the get_string routines into one routine with a
     command branch.
                                                   END HISTORY COMMENTS */
/* format: off */
%page;
pipe_:	proc options (main);
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

   Name: pipe_

   Function:  This subroutine supplies a set of I/O service entrypoints for
	    use by the command processor.  All iox_ calls needed to provide
	    the Multics pipe_ facility reside within this module.

   Entrypoints:

   pipe_$attach_pipe
      on the first entry per-process, creates the pipe storage area.
      Initializes variables and calls the iox_ entries that will attach the
      target attach description given as a parameter.

   pipe_$close_pipe
      calls the iox_ entrys to move the standard input or output switch to the
      attach state they were in before the pipe_$open_pipe entry was called.

   pipe_$copy
      performs a simple loop of calls to iox_ entries to get characters from
      standard input and put characters to standard output.

   pipe_$detach_pipe
      calls the iox_ entries that detach and destroy the io control block
      created by the pipe_$attach_pipe entrypoint.  Frees the information that
      was used to describe the attachment that is being released.

   pipe_$get_return_string
      calls iox_ to get characters from the specified input attachment and
      adds the information as is to a string defined by parameter input.

   pipe_$get_return_string_nnl
      same as pipe_$get_return_string except strips new_line characters.

   pipe_$initiate
      builds and returns a unique file name for use as a pipe temporary file.

   pipe_$open_pipe
      opens the target attachment made by the pipe_$attach_pipe entry, saves
      the current attachment of the standard switch in use and attaches the
      standard switch to the target attachment.

   pipe_$terminate
      deletes the pipe temporary files named by the pipe_$initiate entry and
      reinitializes name values

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  attach_pipe

   syntax:  pipe_$attach_pipe (char(*), bit(1) aligned, bit(1) aligned,
	     ptr, fixed bin(35));

  summary:  1) If the user is attempting to attach to user_input or
	     user_output, return an error.
            2) Create the pipe data area in system free area and set
	     the pointer to it.
            3) Allocate and initiate the pipe_info for this attachment.
	  4) Call iox_ to make the attachment to the parameter
	     attach description. Default to vfile_ or set the -extend
	     argument based on the parameter control.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

attach_pipe: entry (atd,		/* (input)  - target attachment     */
	          Sdefault_to_vfile,	/* (input)  - ON = add "vfile_"     */
		Sextend,		/* (input)  - ON = odd "-extend"    */
		Ppipe_info,	/* (output) - pointer to pipe_info  */
		code);		/* (output) - error status	      */

       dcl atd			char(*) parameter;
       dcl Sdefault_to_vfile		bit (1) aligned parameter;
       dcl Sextend			bit (1) aligned parameter;
       dcl match_switch		char (32) varying;

       code = 0;
       Ppipe_info = null;

       if atd = "" then return;

       match_switch = get_word (atd, 2);
       if match_switch = "user_input" | match_switch = "user_output" then do;
	code = error_table_$cyclic_syn;
	return;
	end;

       pipe_area_info_ptr_ = get_system_free_area_ ();

       on cleanup
	call detach_pipe (Ppipe_info, ignore_code);
%page;
       allocate pipe_info in (pipe_storage_area) set (Ppipe_info);
       pipe_info.old.Piocb = null;
       pipe_info.old.switch = SPACE;
       pipe_info.old.Sdo_not_close = FALSE;
	
/* A unique string is used for the pipe switch to make the mechanism
   resemble the one use by the command environment when pushing an
   execution level. */

       unique_string = unique_chars_ ("0"b);
       pipe_info.new.Piocb = null;
       pipe_info.new.switch =	"pipe_new_" || unique_string;
       pipe_info.new.Sdo_not_close = FALSE;
	
       pipe_info.save.switch = "pipe_save_" || unique_string;
       call iox_$find_iocb (pipe_info.save.switch, pipe_info.save.Piocb, code);
       pipe_info.save.Sdo_not_close = FALSE;
       pipe_info.Spipe_file = FALSE;

       if index (atd, "pipe_file_!") > 0 then
	pipe_info.Spipe_file = TRUE;

       if Sdefault_to_vfile then do;
	if Sextend then
	   call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb,
	      "vfile_ " || before (ltrim(atd), SPACE) || " -extend "
	      || after (ltrim(atd), SPACE), null(), code);
          else 
	   call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb,
	      "vfile_ " || ltrim(atd),  null(), code);
	end;
       else
	call iox_$attach_name (pipe_info.new.switch, pipe_info.new.Piocb,
	   atd, null(), code);

       return;
%page;
/* Internal to attach_pipe.  This routine returns a given word in the
   character string word_list.  The string is always a Multics attach
   description. */

get_word: proc    (word_list,
	         word_to_return)
          returns (char (32) varying);

       dcl  word_list		char (*) unaligned,
	  word_to_return		fixed bin,
	  work_list		char (1024) varying,
	  word			char (32) varying,
	  i			fixed bin;

/* If the attach description has a target attach, use only the target
   portion of the string. */

       work_list = ltrim (after (word_list, "-target "));
       if work_list = "" then work_list = ltrim (word_list);
       do i = 1 to word_to_return;
	word = before (work_list, SPACE);
	work_list = after (work_list, SPACE);
	work_list = ltrim (work_list);
	end;

       return (word);
       end get_word;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  close_pipe
   syntax:  pipe_$close_pipe (ptr, bit(1) aligned, fixed bin(35));

  summary:  1) Mask interrupts because we are moving standard I/O switches.
	  2) If the standard switch was attached when we started,
	     move it back to where it was before the open.
            3) If the target attachment was opened by the pipe_ subroutine,
	     close it.
            4) If the attachment is a pipe temporary file and the truncate
	     option is given, truncate the file.
            5) Unmask interrupts.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

close_pipe: entry (Ppipe_info,	/* (input) - points to pipe_info    */
	         Struncate,		/* (input) - ON = truncate pipe file*/
 	         code);		/* (output)- error status           */

       dcl Struncate		bit(1) aligned parameter;

       code = 0;
       if Ppipe_info = null then return;
       if pipe_info.old.Piocb = null then return;

       if (pipe_info.save.Piocb -> iocb.open_descrip_ptr ^= null
	& pipe_info.old.Piocb -> iocb.open_descrip_ptr ^= null) then do;

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

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

	call iox_$detach_iocb (pipe_info.old.Piocb, ignore_code);

	call iox_$move_attach
	   (pipe_info.save.Piocb, pipe_info.old.Piocb, ignore_code);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);
	end;
       
       if pipe_info.new.Sdo_not_close then;
       else
	call iox_$close (pipe_info.new.Piocb, code);
%page;
       if code = 0 then do;
	if pipe_info.Spipe_file & Struncate then do;

	   call iox_$open (pipe_info.new.Piocb, Stream_input_output,
	      FALSE, code);

	   if code = 0 then do;
	      call iox_$position (pipe_info.new.Piocb, 0, 0, code);
	      if code = 0 then
	         call iox_$control (pipe_info.new.Piocb, "truncate",
	         null, ignore_code);
	   
	      call iox_$close (pipe_info.new.Piocb, ignore_code);
	      end;
	   end;
	end;

       return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  copy
   syntax:  pipe_$copy (ptr, ptr, fixed bin(35))

  summary:  1) If the input or output source is missing, return.
	  2) Get a temp segment to hold the data from the input source.
	  3) While there is more data available from the input source,
	     get a block of characters from the input source and
	     output it to the output source.
	  4) Release the temp segment.
 
******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

copy:	entry (Pinput,		/* (input) - ptr pipe_info of input */
	       Poutput,		/* (input) - ptr pipe_info of output*/
	       code);		/* (output)- error status           */

       code = 0;
       if Pinput = null | Poutput = null then
	return;

       Pbuffer = null;
       on cleanup
	call release_temp_segment_ ("pipe_get_string", Pbuffer,
	   ignore_code);

       call get_temp_segment_ ("pipe_copy", Pbuffer, ignore_code);
       Lbuffer = CHARS_PER_SEGMENT;
       EOF = FALSE;
%page;
       do while (code = 0 & ^EOF);
	call iox_$get_chars (Pinput -> pipe_info.new.Piocb,
	   Pbuffer, Lbuffer, Lrecord, code);

	if code = error_table_$short_record then
	   code = 0;

	if code = error_table_$end_of_info then do;
	   code = 0;
	   EOF = TRUE;
	   end;

	if Lrecord > 0 then

/* If the get_chars operation did not return an error write with code
   and return any write errors. */

	   if code = 0 then call iox_$put_chars (Poutput ->
	      pipe_info.new.Piocb, Pbuffer, Lrecord, code);

/* Otherwise, flush the buffer and return the get_chars error. */

	   else call iox_$put_chars (Poutput -> pipe_info.new.Piocb,
	      Pbuffer, Lrecord, ignore_code);
	end;

       call release_temp_segment_ ("pipe_copy", Pbuffer, ignore_code);
       return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  detach_pipe
   syntax:  pipe_$detach_pipe (ptr, fixed bin(35))

  summary:  1) If not attached, return.
	  2) Detach the target attachment established by the attach_pipe
	     entry.
            3) Destroy any work io control blocks.
	  4) Free the pipe_info structure for the attachment.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

detach_pipe: entry (Ppipe_info,	/* (input) - ptr to pipe_info to det*/
	          code);		/* (output)- error status	      */

      code = 0;

      if Ppipe_info = null then return;

      if unspec (pipe_info.new.Piocb) ^= ""b then do;
         if pipe_info.new.Piocb ^= null then do;
	  if pipe_info.new.Piocb -> iocb.attach_descrip_ptr ^= null then
	     call iox_$detach_iocb (pipe_info.new.Piocb, code);
	  call iox_$destroy_iocb (pipe_info.new.Piocb, ignore_code);
	  end;
         end;

      if unspec (pipe_info.new.Piocb) ^= ""b then
         call iox_$destroy_iocb (pipe_info.save.Piocb, ignore_code);

      free pipe_info in (pipe_storage_area);
      Ppipe_info = null;
      return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  get_return_string
	  get_return_string_nnl

   syntax:  get_return_string (ptr, ptr, fixed bin(21), fixed bin(35))
	  get_return_string_nnl (ptr, ptr, fixed bin(21), fixed bin(35))

 function:  gets characters from an input source and adds them to a character
	  string.

  summary:  1) Get a temp segment to hold the data from the input source.
	  2) While there is more data available from the input source,
	     get a block of characters from the input source and,
               a) If the remove new line control is on remove the new
	        line character from the input string.
               b) If there is room in the return string, add the input
	        character string.  Otherwise, set the error status.
	  3) Release the temp segment.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

get_return_string: entry (Pinput,	/* (input) - ptr to pipe_info of src*/
		      Pret_string,	/* (input) - ptr to string storage  */
		      Lret_string,	/* (input) - available length of str*/
		      code);	/* (input) - error status	      */

       Sremove_new_lines = FALSE;
       go to GET_STRING_COMMON;
       

get_return_string_nnl: entry (Pinput,	/* same as get_return_string        */
		          Pret_string,
			Lret_string,
			code);

       Sremove_new_lines = TRUE;
%page;
GET_STRING_COMMON:
        
       code = 0;
       if Pinput = null then
	return;

       Pbuffer = null;
       on cleanup
	call release_temp_segment_ ("pipe_get_string", Pbuffer,
	   ignore_code);

       call get_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code);
       Lbuffer = CHARS_PER_SEGMENT;
       EOF = FALSE;

       do while (code = 0 & ^EOF);

	call iox_$get_line (Pinput -> pipe_info.new.Piocb,
	   Pbuffer, Lbuffer, Lrecord, code);

	if code = error_table_$short_record then
	   code = 0;
	else
	   if code = error_table_$end_of_info then do;
	      code = 0;
	      EOF = TRUE;
	      end;

	if length(record) > 0 then do;

	   if Sremove_new_lines then do;

	      if length(ret_string) > 0 then
	         ret_string = ret_string || SPACE;

	      if substr (record, length(record), length (NL)) = NL then
	         Lrecord = Lrecord - length (NL);
	      end;

	   if (length(ret_string) + length(record))
	      > maxlength(ret_string) then
	      code = error_table_$command_line_overflow;
	   else
	      ret_string = ret_string || record;
	   end;
	end;

       call release_temp_segment_ ("pipe_get_string", Pbuffer, ignore_code);
       return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  initiate
   syntax:  pipe_$initiate (ptr)

  summary:  1) Build a unique pipe temporary file name.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

initiate:  entry (Ppipe_atd);		/* (input) - ptr to storage for the */
				/*           pipe temp file pathname*/

dcl Ppipe_atd ptr parameter;
dcl pipe_atd char(58) based (Ppipe_atd);

       if Ppipe_atd = null then
	return;

       pipe_atd = 
	rtrim(get_pdir_ ()) || ">pipe_file_" || rtrim(unique_chars_ ("0"b));

       return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  open_pipe
   syntax:  pipe_$open_pipe (ptr, bit(1) aligned, fixed bin(35))

  summary:  1) Determine which standard I/O switch to use based on the
	     INPUT control parameter.
            2) Locate the io control block of the switch to be opened.
	     If the iocb cannot be located, there is something wrong,
	     return.
            3) Open the target attachment.
	  4) Save the current attach description of the standard switch
	     so that it can restored by the close_pipe entrypoint.
	  5) Attach the standard switch "syn_" to the target attachment.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

open_pipe: entry (Ppipe_info,		/* (input) - ptr to pipe_info of src*/
	        INPUT,		/* (input) - ON = open for input    */
	        code);		/* (output)- error status	      */

       dcl INPUT			bit(1) aligned parameter;
       dcl mode			fixed bin;

       code = 0;
       if Ppipe_info = null then
	return;

       if INPUT then do;
	pipe_info.old.switch = "user_input";
	mode = Stream_input;
	end;
       else do;
	pipe_info.old.switch = "user_output";
	mode = Stream_output;
	end;

       call iox_$look_iocb (pipe_info.old.switch, pipe_info.old.Piocb, code);

       if code ^= 0 then return;
%page;	
       on cleanup
	call iox_$close(pipe_info.new.Piocb, code);

       call iox_$open (pipe_info.new.Piocb, mode, "0"b, code);

       if code = error_table_$file_already_opened |
	code = error_table_$not_closed then do;
	pipe_info.new.Sdo_not_close = TRUE;
	code = 0;
	end;

       if code ^= 0 then return;

       on cleanup
	call close_pipe (Ppipe_info, FALSE, ignore_code);

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

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

       call iox_$move_attach (pipe_info.old.Piocb, pipe_info.save.Piocb, code);

       if code = 0 then do;

	call iox_$attach_ptr (pipe_info.old.Piocb,
	   "syn_ " || pipe_info.new.switch, null(), code);

	if code ^= 0 then
	   call close_pipe (Ppipe_info, FALSE, ignore_code);

	revert cleanup;
	end;

       else
	call iox_$close(pipe_info.new.Piocb, code);

       call hcs_$reset_ips_mask (ips_mask, ips_mask);
       return;
%page;
/* ***************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
******************************************************************************

entryname:  terminate
   syntax:  pipe_$terminate (ptr, ptr, fixed bin(35))

  summary:  1) If there in an input path, expand the pathname and
	     delete it. Set the pathname to SPACE.
	  2) If there in an output path, expand the pathname and
	     delete it. Set the pathname to SPACE.

******************************************************************************
----|----1----|----2----|----3----|----4----|----5----|----6----|----7----|---
*************************************************************************** */

terminate: entry (Ppipein_path,	/* (input) - ptr to input path      */
	        Ppipeout_path,	/* (input) - ptr to output path     */
	        code);		/* (output)- error status	      */

       dcl Ppipein_path		ptr parameter,
	 Ppipeout_path		ptr parameter;

       dcl pipe_path		char (58) based;

       code = 0;

       if Ppipein_path ^= null then
	if Ppipein_path -> pipe_path ^= SPACE then do;
	   call delete_$path (Ppipein_path -> pipe_path, "",
	      FILES_ONLY_FORCE_NO_QUERY, "", code);
	   Ppipein_path -> pipe_path = SPACE;
	   end;

       if Ppipeout_path ^= null then
	if Ppipeout_path -> pipe_path ^= SPACE then do;
	   call delete_$path (Ppipeout_path-> pipe_path, "",
	      FILES_ONLY_FORCE_NO_QUERY, "", code);
	   Ppipeout_path -> pipe_path = SPACE;
	   end;
       return;
%page;
       dcl Lret_string		fixed bin parameter,
	 Pinput			ptr parameter,
	 Poutput			ptr parameter,
           Pret_string		ptr parameter,
	 code			fixed bin(35) parameter,
	 Ppipe_info		ptr parameter;

       dcl pipe_area_info_ptr_	ptr internal static init (null),
	 pipe_storage_area		area based (pipe_area_info_ptr_);

       dcl 1 pipe_info		aligned based (Ppipe_info),
	   2 old,
	     3 Piocb		ptr,
	     3 switch		char(32) unaligned,
	     3 Sdo_not_close	bit (1),
             2 new			aligned like old,
	   2 save			aligned like old,
	   2 Spipe_file		bit (1);

       dcl ret_string		char (Lret_string) varying 
				based (Pret_string);

       dcl Pbuffer			ptr,
	 Lbuffer			fixed bin(21),
	 Lrecord			fixed bin(21),
	 record			char (Lrecord) based (Pbuffer);

       dcl EOF			bit (1) aligned;
       dcl Sremove_new_lines		bit (1) aligned;
       dcl ignore_code		fixed bin (35);
       dcl ips_mask			bit(36) aligned;
       dcl unique_string		char (15);

       dcl (after, before, index, length, ltrim, maxlength, null, rtrim,
	 substr, unspec)		builtin;

       dcl (any_other, cleanup)	condition;

       dcl FALSE			bit (1) aligned internal static
				options (constant) init ("0"b),
	 NL			char (1) aligned internal static
				options (constant) init ("
"),
           FILES_ONLY_FORCE_NO_QUERY	bit (36) aligned internal static
				options (constant) init
           ("100100000000000000000000000000000000"b),
           SPACE			char (1) aligned internal static
				options (constant) init (" "),
           TRUE			bit (1) aligned internal static
				options (constant) init ("1"b);
%page;
      dcl (error_table_$command_line_overflow,
	error_table_$cyclic_syn,
	error_table_$end_of_info,
	error_table_$file_already_opened,
	error_table_$not_closed,
	error_table_$short_record)
				fixed bin(35) ext static;

      dcl	delete_$path		entry (char(*), char(*), bit(36) aligned, char(*), fixed bin(35)),
	get_pdir_			entry() returns(char(168)),
	get_system_free_area_	entry() returns(ptr),
	get_temp_segment_		entry (char(*), ptr, fixed bin(35)),
	hcs_$reset_ips_mask		entry (bit(36) aligned, bit(36) aligned),
	hcs_$set_ips_mask		entry (bit(36) aligned, bit(36) aligned),
	release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
	unique_chars_		entry (bit(*)) returns(char(15));
%page;
%include iocb;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include system_constants;

end pipe_;




		    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
