



		    full_command_processor_.pl1     09/25/78  1427.2rew 09/25/78  1427.2      208530



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

full_command_processor_: proc(input_linep, input_linel, code);

/* initially coded in December 1969 by V Voydock */
/* modified May 1970 by R. Frankston for Limited Service System */
/* Modified to use PL/I quoting convention, call com_err_ on errors and not expect lines
   to end in new line character in June 1971 by V. Voydock */
/* Modified in November 1971 by V. Voydock to use error_table codes, treat the new line character as
   the equivalent of the ";" and to fix a few minor bugs */

/* Modified in May 1972 by V. Voydock as part of fast command loop */

/* Modified 25 Aug 1973 by Richard H. Gumpertz to make "a ([x])" work where x returns "" */



dcl	(input_linel, 		/* length of input line passed to command processor */
	 temp_com_linel, 		/* length of temporary command line (if it is nec. to build it) */
	 inl, 			/* internal copy of input line length (changed during processing) */
	 i, 			/* Temporary variable */
	 j, 			/*    "            "    */
	 m, 			/*    "	         "    */
	 first(0:1) based(fp), 	/* Index (in command line) of first char of ith argument */
	 len(0:1) based(lp), 	/* Length of ith argument */
	 actual_first(0:26), 	/* vble "first" is based on this if less than 25 args in line */
	 actual_len(0:26), 		/* vble "len" is based on this if less than 25 args in line */
	 arg_limit, 		/* max number of args before more space must be allocated */
	 whereami, 		/* index of first free character in command line */
	 lng, 			/* length of atom returned by special syntactic construct handlers */
	 inl_left, 		/* number of chars left to be scanned in input line */
	 startno, 			/* index in input line  of first char of atom being processed */
	 argno, 			/* number of arguments to be passed to command */
	 atoml, 			/* space left in temp command line for returned atom */
	 max_com_line int static init(132), 	/* maximum size of expanded command line */
	 end_iter			/* 0 if no iteration sets have been found so far
				   1 if end of an iteration set has been reached
				   2 if iteration set is being processed, and end has not been reached */
		   ) fixed bin aligned;

dcl      (code, 
	error_table_$unbalanced_parentheses external, 
	error_table_$unbalanced_brackets external, 
	error_table_$mismatched_iter external
		) fixed bin(35) aligned;

dcl	(cp_data_$under_lss external, 		/* true if running under limited service system */
	 space_not_allocated init("1"b), 	/* true if space for expanded com line not yet allocated */
	 processing_active_string, 		/* true if we are processing an active string */
	 ignore_brack, 			/* true if we are not to treat brackets as special chars */
	 first_parenthesis init("1"b), 	/* true until first parenthesis is seen */
	 semicolon_seen init("0"b), 		/* true if semicolon has been seen while processing com line */
	 message_not_printed int static, 	/* true if error message has not yet been printed */
	 no_work_done init("1"b), 		/* true if no non-null command has been yet found in line */
	 in_iteration_set, 			/* true if processing an iteration set */
	 argspace_grown init("0"b), 		/* true if space had to be allocated for array "first" */
	 special_char_seen			/* true if special command lang char has been seen in command */

			) bit(1) aligned;
/*  */
dcl	(input_linep, 		/* ptr to input line to be processed */
	 inp, 			/* ptr to beg of command in input line or temp command line */
	 inlp, 			/* ptr to beginning of command in original input line */
	 fp init(addr(actual_first(0))), 	/* ptr to space on which "first" array is based */
	 lp init(addr(actual_len(0))), 	/* ptr to space on which "len" array is based */
	 tfp, 			/* temp copy of fp used by allocation procedure */
	 tlp, 			/* temp copy of lp used by allocation procedure */
	 atomp, 			/* ptr to "atom" to be processed by spec syntactic subroutines */
	 temp_com_linep, 		/* ptr to simple command line being built */
	 startp, 			/* ptr to beginning of spec syntactic construct */
	 cp_data_$command_table_ptr external		/* ptr to command table used with limited command systems */
				 ) ptr aligned;

dcl	com_line char(temp_com_linel) based(temp_com_linep) aligned,    /* input line is copied here piece by piece 
						      if '"', '(', or '[' are found in it */
	atom char(atoml) based(atomp), 
	input_line char(inl+1) based(inp) aligned, 	/* input line to be processed */
	nl char(1) aligned int static init("
"), 							/* New line character */
	nch char(1) aligned;     			/* character currently being examined */

dcl	cu_$gen_call ext entry(ptr, ptr), 
	cu_$grow_stack_frame ext entry(fixed bin, ptr, fixed bin(35)), 
	cu_$shrink_stack_frame ext entry(ptr, fixed bin(35)), 
	find_command_ ext entry(ptr, fixed bin, ptr, fixed bin(35)), 
	transform_command_ ext entry(ptr, fixed bin, ptr, fixed bin(35)), 
	proc_parens_ ext entry(ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin(35)), 
	proc_quotes_ ext entry(ptr, fixed bin, fixed bin, ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin(35)), 
	(proc_brackets_$nested_brackets, 
	 proc_brackets_)   ext entry(ptr, fixed bin, fixed bin, fixed bin, char(*) var, char(*) var, fixed bin(35)), 
	com_err_ ext entry options(variable);

dcl	(addr, addrel, bin, bit, divide, mod, null, search, string, substr) builtin;

		/* structure to scan input line */
dcl	1 x based(inp) aligned, 
	  2 ch(0:31) char(1) unaligned;

dcl	(cleanup, command_abort_) condition;
/**/
	/* ***********************************START OF SIMPLE COMMAND LOOP*********************************** */


	processing_active_string, ignore_brack = "0"b;

START:	message_not_printed = "1"b;
	temp_com_linel = input_linel;
	inl = input_linel-1;
	inp, inlp = input_linep;
	
NEXT_COMMAND:
	
		/* If called to evaluate active function, lower arg_limit to allow for return arg */
	if processing_active_string then arg_limit = 25;
	else arg_limit = 26;

NEXT_ITER:
	len(0), whereami, end_iter, code, startno = 0;
	in_iteration_set, special_char_seen = "0"b;
	argno = -1;
	
NEXT_ATOM:	/* Skip leading blanks */
	do i = startno to inl while(ch(i) = " "); end;
	
	j = i;	/* Set j = i in case we have line of the form "command;  ;"  */
	
		/* Check to see if we have reached the end of the command line or the
		   end of the command (the part ended by ";") and then check to see if
		   we must allocate more space for the first and len arrays */
	if i>inl then go to SCAN_DONE;
	nch = ch(i);		/* Pick up next character */
	if nch = nl then nch = ";";	/* nl < = > ;  */
	if nch = ";" then  do; semicolon_seen = "1"b; go to SCAN_DONE; end;
	argno = argno+1;
	if argno>arg_limit then do; tfp, tlp = null; on condition(cleanup) call cleanup_proc; call grow_space; end;

		/* Set index of first character in the atom.  If this is a simple command
		   this index is relative to the original input line, otherwise it is
		   relative to the temporary command line being built */
	if special_char_seen then first(argno) = whereami;
	else first(argno) = i;
/*  */
		/* Scan for next break or special character */

	if ignore_brack then j = search(substr(input_line,i+1,inl-i+1)," ;()""
");
		else j = search(substr(input_line,i+1,inl-i+1)," ;()[]""
");
	if j=0 then do;
	     j = inl+1;
	     go to END_OF_ATOM_FOUND;
	end;
	j = j+i-1;
	     nch = ch(j);
	     if nch = " " then  do;  startno = j+1;  go to END_OF_ATOM_FOUND;  end;
	     if nch = nl then nch = ";";			/* Treat nl as equivalent to ";" */
	     if nch = ";" then  do; semicolon_seen = "1"b; go to END_OF_ATOM_FOUND; end;
	     if nch = "(" then go to MORE_COMPLICATED;
	     if nch = """" then go to MORE_COMPLICATED;
	     if nch = "[" then go to CALL_PROC_BRACKETS;
	     if nch = ")" then do; code = error_table_$unbalanced_parentheses; go to PRINT_MESSAGE; end;
  	     if nch = "]" then do; code = error_table_$unbalanced_brackets; go to PRINT_MESSAGE; end;

END_OF_ATOM_FOUND:
	
		/* Save length of current atom */
	len(argno) = j-i;

		/* If one of the special command language syntactic characters has been seen then
		   copy the atom from the input line into the temporary command line being built */
	if special_char_seen then
	     do;
	     substr(com_line, whereami+1, len(argno)) = substr(input_line, i+1, len(argno));
	     whereami = whereami+len(argno);
	     end;

	if nch = " " then go to NEXT_ATOM;


SCAN_DONE:
	
		/* We have finished parsing a command.  Now test for a null command; that is a line
		   consisting of all blanks, or a portion of a line of the form ";  ;" etc */
	if len(0) = 0 then go to CHECK_FOR_ANOTHER_COMMAND;
	
		/* Test for end of iteration group */
	if end_iter = 1 then go to CHECK_FOR_ANOTHER_COMMAND;
	
		/* Indicate that a non-null command line has been typed */
	no_work_done = "0"b;
	
		/* If calling active function, set variables so that a varying
		   string return argument will be added to end of argument list */
	if processing_active_string then
	     do;
	     argno = argno+1;
	     len(argno), first(argno) = 1;
	     end;

		/* If a special char was seen, change inp to point to the temporary command line */
	if special_char_seen then  inp = temp_com_linep;
/*  */
		/* Enter begin block which allocates space for arg list. Set up arg list and call command */
	begin;

dcl	1 argument_list aligned, 
	  2 dum_ptr ptr,      /* dummy ptr used to force arg list to even word boundary */
	  2 twice_no_of_args bit(18) unaligned init(bit(bin(argno*2, 18), 18)), 
	  2 tag bit(18) initial("000000000000000100"b) unaligned, 
	  2 twice_no_of_descriptors bit(18) unaligned init(bit(bin(argno*2, 18), 18)), 
	  2 pad bit(18) initial("0"b) unaligned, 
	  2 argument_ptr(argno) ptr, 
	  2 descriptor_ptr(argno) ptr;
	 
dcl	1 descriptor(argno) aligned, 
	  2 flag bit(1) unaligned,
	  2 type bit(6) unaligned,
	  2 packed bit(1) unaligned,
	  2 ndims bit(4) unaligned,
	  2 size bit(24) unaligned;

dcl	(command_name_ptr initial(addr(ch(first(0)))), 		/* ptr to name of command to be called */
	 command_entry_ptr					/* ptr to entry pt of command to be called */
				) ptr aligned;

		/* Build argument list */
	do i = 1 to argno;
	     argument_ptr(i) = addr(ch(first(i)));
	     descriptor_ptr(i) = addr(descriptor(i));
	     string(descriptor(i)) = "1"b;		/* init */
	     descriptor(i).size = bit(bin(len(i), 24));
	     descriptor(i).type = bit(bin(21, 6));      /* indicates non-varying string */
	     descriptor(i).packed = "1"b;
	end;
	
		/* If calling active fnc, add varying str return arg to end of arg list */
	if processing_active_string then
	     do;
	     workspace = "";		/* default return value is "" (in case act fnc does not return value) */
	     argument_ptr(argno) = addrel(addr(workspace), 1);
	     descriptor(argno).flag = "1"b;
	     descriptor(argno).ndims = "0000"b;
	     descriptor(argno).size = bit(bin(max_com_line, 24));
	     descriptor(argno).type = bit(bin(22, 6));     /* indicates varying string */
	     descriptor(argno).packed = "1"b;
	     end;
	
		/* If running Limited Service System see if this is a legal command name */
	if cp_data_$under_lss then
	     do;
	     call transform_command_(command_name_ptr, len(0), cp_data_$command_table_ptr, code);
	     if code ^= 0 then return;
	     end;

		/* Get pointer to command whose name is pointed to by command_name_ptr */
	call find_command_(command_name_ptr, len(0), command_entry_ptr, code);
	if code ^= 0 then  do; message_not_printed = "0"b; return; end;

		/* watch for aborted command */
	on condition(command_abort_) go to ABORT_COMMAND;
	
		/* Generate a call to the command */
	call cu_$gen_call(command_entry_ptr, addr(twice_no_of_args));
ABORT_COMMAND:
	revert condition(command_abort_);
	end;
/*  */
		/* Build value to be returned (if any) */
	if processing_active_string then  ret_string = ret_string||workspace;

		/* If we are in an iteration set go process next member of set */
	if in_iteration_set then  do; inp = inlp; go to NEXT_ITER; end;
	
CHECK_FOR_ANOTHER_COMMAND:
	
		/* If we had to allocate space for the first and len arrays, free it up */
	if argspace_grown then
	     do;
	     free fp->first;
	     free lp->len;
	     fp = addr(actual_first(0));
	     lp = addr(actual_len(0));
	     revert condition(cleanup);
	     argspace_grown = "0"b;
	     end;
	
		/* If this is the end of the input, check for null command line and return */
	if nch ^= ";" then  do; if no_work_done then code = 100; return; end;

		/* We must now process the next command in the input line.  We must change inp to point
		   to the first character after the ";".  Since inp must point to a word boundary, we
		   must if necessary, blank out the ";" and characters before it and adjust inp */
	nch = " ";
	inp = inlp;
	j = j+1;
	i = mod(j, 4);
	if i>0 then substr(input_line, j-i+1, i) = " ";
	inp = addr(ch(j-i));
	inlp = inp;
	inl = inl-j+i;

		/* If we have had to use a temporary command line, deallocate the space */
	if ^space_not_allocated then
	     do;
	     call cu_$shrink_stack_frame(temp_com_linep, code);
	     space_not_allocated = "1"b;
	     end;

		/* Since the input line is shorter, adjust the variable which keeps track of how big a space
		   we must allocate if it is necessary to grow a temporary command line again */
	temp_com_linel = inl+1;
	go to NEXT_COMMAND;


	/* ***********************************END OF SIMPLE COMMAND LOOP*********************************** */
/*  */
	
		/* The following code is only executed if an error occurs or if one of the
		     special command language characters is seen */
MORE_COMPLICATED:
	
	m = j-i;
	
	if ^special_char_seen then
	     do;
	     if space_not_allocated then
	          do;
		/* allocate stack space for temporary command line */
	          m = divide(temp_com_linel, 4, 17, 0)+1;
	          call cu_$grow_stack_frame(m, temp_com_linep, code);
		if code ^= 0 then go to PRINT_MESSAGE;
	          space_not_allocated = "0"b;
	          end;
	     	/* copy constant part of command line into temporary */
	     if j>0 then substr(com_line, 1, j) = substr(input_line, 1, j);
	     whereami = j;     /* index of first free character in command line */
	     m = 0;
	     special_char_seen = "1"b;
	     end;
	
AGAIN:
	
		/* Get ptr to beginning of free space in temporary command line */
	atomp = addr(temp_com_linep->x.ch(whereami));
	
		/* Copy part of atom before "(" if any */
	if m>0 then
	     do;
	     substr(atom, 1, m) = substr(input_line, i+1, m);
	     whereami = whereami+m;
	     m = 0;
	     go to AGAIN;
	     end;
	
	atoml = max_com_line-whereami+1;      /* maximum allowable size of returned atom */
	startp = addr(ch(j));      /* ptr to beginning of special construction */
	inl_left = inl-j;      /* number of characters left in input line */
	
		/* Call appropriate special syntactic construct handler */
	if nch = "(" then
	     do;
	     in_iteration_set = "1"b;
	     call proc_parens_(startp, inl_left, startno, atomp, atoml, lng, first_parenthesis, code);
	     first_parenthesis = "0"b;
	     end;
	else  
	if nch = """" then call proc_quotes_(startp, inl_left, startno, atomp, atoml, lng, first_parenthesis, code);
/*  */
		/* Check for various special conditions.  The variable "end_iter" describes the
		   state of iteration sets in this command line.  If code = 0 and we were
		   processing parens (i.e. nch = "(") then we must check whether there a previous iteration
		   set in this command line was exhausted (e.g. an line of the form "f (a b) (c d e)"  )
		   This is an error and is indicated by end_iter = 1. Next, if the status code = 101 then
		   a quoted string has an iteration set as part of its tail (e. g. a line of the
		   form "f "abd"(de qwer)". If code = 102 a bracket was seen and we must invoke the bracket
		   processor.  If code = 103 then we have just found an exhausted iteration set.  If a previous
		   iteration set in the command line was not exhausted, indicated by end_iter = 2 this is an
		   error (e.g. a line of the form "f (a b c) (d e)"    )    */
	if code = 0 then
	     if nch = "(" then
		if end_iter = 1 then go to MISMATCHED_ITER;
		else end_iter = 2;
	     else;
	else
	if code = 101 then  do; code = 0;  in_iteration_set = "1"b; end;     /* case "abc"(def ghj)     */
	else
	if code = 102 then do; j = j+startno; go to CALL_PROC_BRACKETS; end;  /* "[" seen */
	else
	if code = 103 then do;
	     if end_iter = 2 then go to MISMATCHED_ITER;
	     end_iter = 1; code = 0;
	     goto UPDATE_STARTNO;
	end;
	else
	     do;
PRINT_MESSAGE: call com_err_(code, "command_processor_");
	     message_not_printed = "0"b;
	     return;
	     end;
	


		/* If no error has occured in the processing of this special
		   syntactic construct, then go process the next atom */
	len(argno) = lng+j-i;
	whereami = whereami+lng;
UPDATE_STARTNO:
	startno = startno+j;
	go to NEXT_ATOM;


MISMATCHED_ITER:

	code = error_table_$mismatched_iter;
	go to PRINT_MESSAGE;

/**/
			/* BRACKETS SEEN IN COMMAND LINE */

CALL_PROC_BRACKETS:
	
		/* Allocate space for returned string if necessary.  (Allocation is necessary
		     if this is the first time we are calling proc_brackets_ or if we
		     are processing a line of the form "ff [f x; g [h z]]".  In the latter case we need
		     the space for the value returned by the fnc h, since otherwise it would
		     "overwrite" the value already returned by the fnc f)     */
	if ^processing_active_string then 
GET_SPACE:     begin;
	     dcl  (return_string, working_space) char(max_com_line) var init("");
	     if ^processing_active_string then
		call proc_brackets_(inp, inl, j, max_com_line, return_string, working_space, code);
	     else
	          do;      /* case:  "ff [f x; g [h z]]"     */
	          call proc_brackets_$nested_brackets(inp, inl, j, max_com_line, return_string, working_space, code);
			/* Concatenate the value returned by the fnc g applied to "[h z]" with
			   the value already returned by f  */
	          ret_string = ret_string||return_string;
	          end;
	     end;
	else      
	if semicolon_seen then go to GET_SPACE;
	else call proc_brackets_$nested_brackets(inp, inl, j, max_com_line, ret_string, workspace, code);

		/* Command line with brackets has been processed.  Check for nonzero error code. If so, 
		   print error message and return. Otherwise, go process next command in input line */
	if code  ^=  0
	then if code  ^=  100
	     then if message_not_printed
		then go to PRINT_MESSAGE;
	return;
/*  */
		/* Internal procedure to allocate space for information about the arguments
		   (namely the first and len arrays).  It frees up the current arrays, if they were allocated */
grow_space: proc;

dcl	system_area area based(area_ptr);

dcl	old_arg_limit fixed bin aligned;

dcl	area_ptr internal static ptr aligned initial(null);

dcl	space(0:arg_limit) fixed bin aligned based;

dcl	get_system_free_area_ ext entry(ptr);

		/* Get pointer to the system free area in this ring, if we have not already done so */
	if area_ptr = null then call get_system_free_area_(area_ptr);

		/* Save current size of arg info.  Increase size (doubling each time called) */
	old_arg_limit = arg_limit;
	arg_limit = arg_limit+2*arg_limit;

		/* Allocate space for more arg info */
	argspace_grown = "1"b;
	allocate space in (system_area) set (tfp);
	allocate space in (system_area) set (tlp);

		/* Copy existing arg info into the newly allocated space */
	arg_limit = old_arg_limit;
	tfp->space = fp->space;
	tlp->space = lp->space;

		/* If current arg info was allocated (i. e. not in stack), free it up */
	if fp ^= addr(actual_first(0)) then free fp->space;
	if lp ^= addr(actual_len(0)) then free lp->space;

		/* Restore arg_limit. If called while evaluating active function, lower arg_limit
		   to allow for return argument.  Set pointers, null out tfp and tlp so
		   the cleanup procedure will not get confused if a certain race condition occurs */
	arg_limit = arg_limit+2*arg_limit;
	if processing_active_string then arg_limit = arg_limit-1;
	fp = tfp;
	lp = tlp;
	tfp, tlp = null;
	return;

end grow_space;
/*  */
		/* Cleanup procedure which frees any allocated arg info. */
cleanup_proc: proc;

		/* If we were interrupted after allocation of new space and before fp and/or lp
		   were set, free up appropriate space */
	if tfp ^= null then if tfp ^= fp then free tfp->first;
	if tlp ^= null then if tlp ^= lp then free tlp->first;

		/* if fp and lp point to allocated space, free it up */
	if fp ^= null then if fp ^= addr(actual_first(0)) then free fp->first;
	if lp ^= null then if lp ^= addr(actual_len(0)) then free lp->len;

end cleanup_proc;
/*  */
/**********************************************************************************************/
		/* Entry point called by proc_brackets_ and proc_brackets_$nested_brackets
		   to invoke active functions and pass back their return strings */
return_val: entry(input_linep, input_linel, iflag, ret_string, workspace, code);       

dcl	iflag bit(1) aligned;		/* indicates whether or not brackets should be ignored */

dcl	(ret_string, 			/* ret arg to be passed back to proc_brackets */
	 workspace			/* space in which to store intermediate results */
		   ) char(*) var;

	processing_active_string = "1"b;  ignore_brack = iflag;  go to START;
	


/**********************************************************************************************/
		/* This entry is called by proc_brackets after it has built a "bracketless" command
		   line, and wants to execute the result */
ignore_brackets: entry(input_linep, input_linel, iflag, code);

	processing_active_string = "0"b;  ignore_brack = iflag;  go to START;
	
	
/**********************************************************************************************/
		/* Entry point to set maximum command line size */
set_line: entry(newsize);

dcl	newsize fixed bin;
	
	max_com_line = newsize;
	return;
	
/**********************************************************************************************/
		/* Entry point to get the current maximum command line size */
get_line: entry(newsize);
	
	newsize = max_com_line;
	
	return;
	
/**********************************************************************************************/
		/* Entry point to cause command processor to check all commands
		   against a given table before invoking them.  Used by the Limited Service
		   System and various other limited command systems */
setup_lss: entry(table_ptr);

dcl	table_ptr ptr;

	cp_data_$under_lss = "1"b;
	cp_data_$command_table_ptr = table_ptr;
	return;
	
/**********************************************************************************************/
		/* Entry point to leave "lss mode".  Left in for debugging purposes */
reset_lss: entry;

	cp_data_$under_lss = "0"b;
	return;
	
	
end full_command_processor_;




		    eval_ec_if_test_.pl1            09/25/78  1427.2rew 09/25/78  1427.2       16047



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

eval_ec_if_test_: proc(line_ptr,line_length,index_of_bracket,value,code);

dcl	line_ptr ptr;

dcl	code fixed bin(35) aligned;

dcl	(line_length,
	 index_of_bracket,
	 max_com_line
			) fixed bin;

dcl	value char(8) aligned;

dcl	full_command_processor_$get_line ext entry(fixed bin);

dcl	(addr, length, substr, verify) builtin;

		/* Get size of maximum expanded command line */
	code=0;
	call full_command_processor_$get_line(max_com_line);

		/* Enter begin block to allocate space for returned value */
	begin;

dcl	pad bit(1) aligned,
	(i, l) fixed bin;

dcl	(ret_string,
	 workspace
		    ) char(max_com_line) var;

dcl	proc_brackets_$return_value ext entry(ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin,
				        char(*) var,char(*) var,fixed bin(35));

		/* Call part of command processor to evaluate the active function */
	call proc_brackets_$return_value(line_ptr,line_length-1,index_of_bracket-1,pad,max_com_line,
				   ret_string,workspace,code);

	l = length(ret_string);

/* Following code is used to strip off leading blanks from returned value,
   since proc_brackets_ copies original string (blanks in this case) up to the left bracket */

	if l>0 then do;
	     i = verify(ret_string," ");
	     value = substr(ret_string,i,l-i+1);
	end;
	else value = "";
     end;

end eval_ec_if_test_;




		    set_com_line.pl1                09/25/78  1427.2rew 09/25/78  1427.2       15210



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

set_com_line: scl:
     procedure;

/* initially coded in February 1970 by V. Voydock */
/* modified on February 8, 1970 at 2:45 P. M. by V. Voydock */
/* Modified 761025 by PG to convert to Version 2 PL/I */

/* automatic */

dcl  arg_len fixed bin (21),
     arg_ptr ptr,
     code fixed bin (35),
     size fixed bin (21);

/* based */

dcl  arg_string char (arg_len) based (arg_ptr);

/* entries */

dcl  com_err_ entry options (variable),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cv_dec_ entry (char (*)) returns (fixed bin (35)),
     command_processor_$set_line entry (fixed bin (21)),
     command_processor_$get_line entry (fixed bin (21)),
     ioa_ entry options (variable);

/* program */

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0
	then size = 132;
	else do;
	     size = cv_dec_ (arg_string);
	     if size <= 0
	     then do;
		call com_err_ (0, "set_com_line", "Invalid command line size ""^a"".", arg_string);
		return;
	     end;
	end;

	call command_processor_$set_line (size);
	return;

get_com_line: gcl:
	entry;

	call command_processor_$get_line (size);
	call ioa_ ("Maximum expanded command line = ^d characters.", size);
	return;

     end;




		    proc_brackets_.pl1              09/25/78  1427.2rew 09/25/78  1427.2       84582



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

proc_brackets_: proc(inputlinep,inputlinel,brackind,max_com_line,ret_string,workspace,code);

/* initially coded in January 1970 by V. Voydock */
/* Modified to handle recursive active functions correctly in all cases in June
   1971 by V. Voydock */
/* Modified in April 1972 to handle quoted return strings correctly by V. Voydock */
/* Modified in May 1972 as part of fast command loop */

dcl	(inputlinel,
	 brackind,
	 max_com_line,    /* maximum expanded command line size */
	 code,
	 lng,
	 i,
	 should_not_rescan,
	 ind init(brackind),	/* index of bracket in inputline */
	 error_table_$unbalanced_brackets external,
	 error_table_$null_brackets external,
	 error_table_$command_line_overflow external,
	 j,
	 bracketless_str_lng init(0),	/* lng of bracketless string before [ or after ] */
	 built_cline_lng init(1),	/* current lng of bracketless command line being built */
	 first_input_char init(1)		/* index of first input char of current bracket pair */
				) fixed bin;

dcl	(ignoreb init("0"b),
	 not_in_quoted_string
			) bit(1) aligned,
	should_return_value bit(2) aligned;

dcl	(inputlinep,
	 inp init(inputlinep),
	 clinep
		) ptr;

dcl	ret_string char(*) var,   /* string to hold value returned (a parameter)  */
	workspace char(*) var,   /* space in which to store intermediate results */
	comline char(max_com_line) aligned,    /* bracketless command line being built */
	inputline char(inputlinel) based(inp) aligned,
	nch char(1) aligned;

dcl	1 x based(inp) aligned,
	     2 ch(0:31) char(1) unaligned;

dcl	full_command_processor_$ignore_brackets ext entry(ptr,fixed bin,bit(1) aligned,fixed bin),
	full_command_processor_$return_val ext entry(ptr,fixed bin,bit(1) aligned,char(*) var,char(*) var,fixed bin),
	proc_brackets_$return_value ext entry(ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin,
				        char(*) var,char(*) var,fixed bin);

dcl	(addr,mod,substr,divide,index,length) builtin;
/*  */
	code=0;
	should_return_value="00"b;
	
PROCESS_NEXT_BRACKET_PAIR:
	
		/* See if "|[" in input line */
	if ch(ind-1)="|" then  do; ignoreb="1"b; should_not_rescan=1; end;
	else should_not_rescan=0;
	
		/* Calculate lng of  bracketless string before next bracket pair */
	bracketless_str_lng=ind-should_not_rescan-first_input_char+1;
	
		/* Copy the bracketless prefix string into the command line being built */
	call copy_bracketless_string();
	if code^=0 then return;
	
		/* Find the end of the bracket pair being processed */
	call find_matching_right_bracket();
	if code^=0 then return;
	
		/* Calculate the index of the first character of the bracket pair to be evaluated.
		   It must start on a word boundary, so we adjust it if necessary. We then
		   blank out the string which will hold the returned result */
	ind=ind+1;
	i=mod(ind,4);    /* find out if ind points to word boundary */
	if i>0 then substr(inputline,ind-i+1,i)=" ";
	ret_string="";
/*  */
		/* Call command processor to evaluate contents of bracket pair and return value
		   to be inserted in command line being built */
	call full_command_processor_$return_val(addr(ch(ind-i)),j-ind+i,"0"b,ret_string,workspace,code);
	if code^=0 then do; if code=100 then code=error_table_$null_brackets; return; end;
	lng=length(ret_string);

		/* Returned string should be inserted into command line being
		   built without scanning it for brackets */
	if should_not_rescan=1 then go to ADD_STRING_TO_LINE;
	
		/* Returned string should be scanned for brackets.  If any are found
		   they must be evaluated and their value inserted into the command line */

	if index (ret_string, "[") = 0 then goto ADD_STRING_TO_LINE; /* check if there are any brackets at all */
	not_in_quoted_string="1"b;
	do i=1 to lng;
	     nch=substr(ret_string,i,1);
	     if nch="[" then
	  	if not_in_quoted_string then go to BRACKET_FOUND;
		else;
	     else
	     if nch="""" then
		if i=lng then not_in_quoted_string=^not_in_quoted_string;
		else
		if substr(ret_string,i+1,1)="""" then i=i+1;
		else not_in_quoted_string=^not_in_quoted_string;
	end;

		/* There was no bracket in the string returned by the active function */
	go to ADD_STRING_TO_LINE;
	
BRACKET_FOUND:
		/* Allocate space to copy returned string.  */
	begin;

dcl	rescanline char(lng) aligned;

		/* Copy returned string into temporary */
	rescanline=ret_string;
	
		/* Clear old returned string and call proc_brackets recursively
		   to determine value of bracketed string that was returned */
	ret_string="";
	call proc_brackets_$return_value(addr(rescanline),lng-1,i-1,ignoreb,max_com_line,ret_string,workspace,code);
	end;

	lng=length(ret_string);

ADD_STRING_TO_LINE:

	if lng>max_com_line-built_cline_lng+1 then do; code=error_table_$command_line_overflow; return; end;
	substr(comline,built_cline_lng,lng)=ret_string;
	built_cline_lng=built_cline_lng+lng;
/*  */
		/* We have finished evaluating a bracket pair.  Now
		   let us find the next one and process it */
	not_in_quoted_string="1"b;
	do ind=j+1 to inputlinel;
	     nch=ch(ind);
	     if nch="[" then
		if not_in_quoted_string then do; first_input_char=j+2; go to PROCESS_NEXT_BRACKET_PAIR; end;
		else;
	     else
	     if nch="""" then
		if ind=inputlinel then not_in_quoted_string=^not_in_quoted_string;
		else
		if ch(ind+1)="""" then ind=ind+1;
		else not_in_quoted_string=^not_in_quoted_string;
	end;

		/* The end of the input line has been reached */
	first_input_char=j+2;
	bracketless_str_lng=inputlinel-j;

		/* Copy the bracketless suffix string into the command line being built */
	call copy_bracketless_string();
	if code^=0 then return;
/*  */
	/* We have built a command line which either does not contain brackets or
		   contains brackets which should be ignored.  */
	built_cline_lng=built_cline_lng-1;

		/* If the call was via the "return_value" entry, return the
		   command line just built.  This is the case of recursive active functions */
	if should_return_value="11"b then
	     do;
	     iflag=ignoreb;
	     ret_string=substr(comline,1,built_cline_lng);
	     return;
	     end;

		/* Otherwise we call the command processor at the appropriate entry */
	ret_string="";
	clinep=addr(comline);
	if should_return_value then
	call full_command_processor_$return_val(clinep,built_cline_lng,ignoreb,ret_string,workspace,code);
	else
	call full_command_processor_$ignore_brackets(clinep,built_cline_lng,ignoreb,code);
	
	return;


/*  */
		/* This entry is called when a recursive active function is encountered.
		   That is, an active function whose value is another active function.  The
		   parameter iflag is necessary so that this entry can tell its caller if
		   a line containing brackets which are to be ignored is being returned.
	   	   For example if "[f]" returns the value "[h]" which returns the value "|[g]" */

return_value: entry(inputlinep,inputlinel,brackind,iflag,max_com_line,ret_string,workspace,code);

dcl	iflag bit(1) aligned;

	code = 0;

	should_return_value="11"b;	go to PROCESS_NEXT_BRACKET_PAIR;



		/* This entry is called by full_command_processor_$return_val if a nested bracket
		   is encountered.  For example the line "[F x [g y] ]"
		   It builds a bracketless command line by evaluating all the nested brackets.
		   It then evaluates this command line and returns its value to its caller.  In
		   the example, suppose "[g y]" returns the value "foo" and suppose
		   [f x foo] returns the value "hello", then nested_brackets will return
		   the value "hello" to return_val */
nested_brackets: entry(inputlinep,inputlinel,brackind,max_com_line,ret_string,workspace,code);

	code = 0;

	should_return_value="01"b;  go to PROCESS_NEXT_BRACKET_PAIR;
/*  */
		/* Internal procedure to copy bracketless strings into command line being built */
copy_bracketless_string: proc;

	if bracketless_str_lng>max_com_line-built_cline_lng+1 then 
	     do;
	     code=error_table_$command_line_overflow;
	     return;
     	     end;
	
	substr(comline,built_cline_lng,bracketless_str_lng)=substr(inputline,first_input_char,bracketless_str_lng);
	built_cline_lng=built_cline_lng+bracketless_str_lng;

end copy_bracketless_string;
/*  */
		/* Internal procedure to find the right bracket which matches the left bracket of the
		   active string being processed */
find_matching_right_bracket: proc;

dcl	(lcnt,
	 rcnt
		) fixed bin initial(0);
	not_in_quoted_string="1"b;
	
	do j=ind+1 to inputlinel;
	     nch=ch(j);
	     if nch="]" then
		if not_in_quoted_string then
		     if lcnt=rcnt then return;
		     else rcnt=rcnt+1;
		else;
	     else
	     if nch="[" then
		if not_in_quoted_string then lcnt=lcnt+1;
		else;
	     else
	     if nch="""" then
		if j=inputlinel then not_in_quoted_string=^not_in_quoted_string;
		else
		if ch(j+1)="""" then j=j+1;
		else not_in_quoted_string=^not_in_quoted_string;
	end;
	
	code=error_table_$unbalanced_brackets;	/* Brackets do not balance */
	return;


end find_matching_right_bracket;

end proc_brackets_;




		    proc_parens_.pl1                09/25/78  1427.2rew 09/25/78  1427.2      126297



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

proc_parens_: proc(input_linep,input_line_lng,last_char_of_iter_set,atomp,atom_buffer_lng,atom_lng,first_call,code);

/* initially coded in January 1970 by V. Voydock */
/* modified on February 12, 1970 at 9:15 P. M. by V. Voydock */
/* modified to accept new quoting convention and to not expect lines to end
   with a new line char in June 1971 by V. Voydock */
/* Extensively reorganized for clarity (taking advantage of fast internal procedures in version 2 pl1)
   and to fix bug which caused quoted strings to be occasionally ignored in March 1972 by V. Voydock */
/* EIS version S. Herbst 3/4/74 */

dcl	(input_line_lng,		/* length of input line to be processed (INPUT) */
	 last_char_of_iter_set,	/* index of first char to be scanned when control returns to caller (OUTPUT) */
	 atom_buffer_lng,		/* amt of space avail. to store atom being built by this proc (INPUT) */
	 atom_lng,		/* length of atom built by this procedure (OUTPUT) */
	 end_of_simple_head,	/* index of first char after the end of the simple head (e.g. in (a b)
				   the space immediately following the "a". In (asd(1 2) z) the "("
				   immediately following the "d" */
	 first_nonblank,		/* index of first nonblank character in input line */
	 j,k,			/* Temporary variables */
	 last_char_of_head,		/* index of the last char in the head of the iteration set. (e. g. in
				   (a(b d) def)x"y"(1 2) the head is (a(b d) def) the tail x"y"(1 2) */
	 end_of_simple_tail,	/* index of first char after simple tail (e. g. in (a b)DEF; the ";"
				   in  (a b)DEF(1 2)  the "(" immediately after the F */
	 first_char initial(1),	/* index of first char being processed (value changes during processing) */
	 last_char_of_atom,		/* index of current last character in atom being built */
	 simple_tail_lng,		/* length of simple tail part. In   (a b)DEF"a c"    DEF is s. t. p. */
	 right_paren_cnt,		/* count of number of right parenthesis seen */
	 left_paren_cnt		/* count of number of left parentheses seen */
						) fixed bin aligned;

dcl	(code,
	 error_table_$mismatched_iter external,
	 error_table_$unbalanced_parentheses external
				) fixed bin(35) aligned;

dcl	(in_quoted_string initial("0"b),	/* True if char being scanned is inside quoted string */
	 nonsimple_tail initial("0"b),	/* Indicates (a b)DE"1 2" or (a b)DE(1 2) as opposed to (a b)DE */
	 quote_inside_parens initial("0"b),	/* Indicates ("ABC") as opposed to (ABC)"DEF" */
	 paren_inside_parens initial("0"b),	/* Indicates ( a(b c)) as opposed to (a b)(d e) */
	 attached_iter_set,			/* True if case (a(b ...) ...) or (a ...)bcd(q ...)  */
	 first_call			/* True if this is first time procedure was called for this line */
				) bit(1) aligned;

dcl	(input_linep,		/* pointer to input line to be processed (INPUT) */
	 atomp			/* pointer to space in which to store atom being built (INPUT) */
		) ptr aligned;

dcl	input_line char(input_line_lng+1) based(input_linep),	/* based structure to reference input */
	atom char(atom_buffer_lng) based(atomp),		/* based string to reference atom */
	ch(0:31) char(1) unaligned based(input_linep),		/* based array to get single chars of input */
	nch char(1) aligned,				/* character currently being scanned */
	nl char(1) aligned internal static initial("
");			/* new line character */

dcl	(addr,search,substr) builtin;
/*  */
	code=0;
	
		/* If this is first invocation search for "[" in input line.  Otherwise the case
		   "(a b)  [f x]" will not work. We search to first ";" or to end */
	if first_call then if search(input_line,"[]")^=0 then call check_for_bracket;
	if code^=0 then return;
	
START:	last_char_of_atom=0;
	attached_iter_set="0"b;
	
		/* Skip leading blanks */
	do first_nonblank=first_char to input_line_lng while(ch(first_nonblank)=" "); end;
	
		/* Build "atom" to be returned */
	end_of_simple_head = search(substr(input_line,first_nonblank+1,input_line_lng-first_nonblank+1)," ();""
");
	if end_of_simple_head=0 then go to UNBALANCED_PARENS;
	end_of_simple_head = end_of_simple_head + first_nonblank - 1;
	     nch=ch(end_of_simple_head);
	     if nch=" " then		/* Case:   (ab_ ...) where "_" represents a blank */
		do;
		first_char=end_of_simple_head+1;
		call find_matching_right_paren;
		if code^=0 then return;
		last_char_of_atom=end_of_simple_head-first_nonblank;
		go to END_PAREN_PAIR;
		end;
	     if nch=")" then
		do;
		nch=ch(end_of_simple_head-1);
		if nch=" " then go to NULL_ITER_SET;		/* Case:   (     ) */
		if nch="(" then go to NULL_ITER_SET;		/* Case:   () */
		last_char_of_head=end_of_simple_head;		/* Case: (  ab) */
		last_char_of_atom=end_of_simple_head-first_nonblank;
		go to END_PAREN_PAIR;
		end;
	     if nch="(" then		/* Case:   (ab( ... ) ... )    */
		do;
		attached_iter_set,paren_inside_parens="1"b;
PROC_SPEC_CHAR:	last_char_of_atom=end_of_simple_head-first_nonblank;
		call process_special_char(end_of_simple_head);
		quote_inside_parens,paren_inside_parens="0"b;
		if code=-1 then  do; code=0; go to START; end;	/* Case:   (ab(   ) ... ) */
		if code^=0 then return;
		call find_matching_right_paren;
		if code^=0 then return;
		go to END_PAREN_PAIR;
		end;
	     if nch="""" then do; quote_inside_parens="1"b; go to PROC_SPEC_CHAR; end;	/* Case:   ("a"...) */
	     if nch=";" then go to UNBALANCED_PARENS;
	     if nch=nl then go to UNBALANCED_PARENS;

/*  */
END_PAREN_PAIR:
	
		/* Process the "tail". e. g. in  "(a b c(d e))fg(h k)" the
	 	   tail is "fg(h k)"    */
	end_of_simple_tail = search(substr(input_line,last_char_of_head+2,input_line_lng-last_char_of_head)," ();""
");
	if end_of_simple_tail=0 then do;
	     end_of_simple_tail = input_line_lng + 1;
	     go to DO_TAIL;
	end;
	end_of_simple_tail = end_of_simple_tail + last_char_of_head;
	     nch=ch(end_of_simple_tail);
	     if nch=" " then go to DO_TAIL;	/* Case:   (a b)de_   where "_" represents a blank */
	     if nch=";" then go to DO_TAIL;	/* Case:   (a b)de;   */
	     if nch=nl then go to DO_TAIL;	/* Case:   (a b)de%   where "%" represents a new line character */
	     if nch=")" then go to DO_TAIL;	/* Case:   ((a b)de(f g))   */
	     if nch="(" then do; nonsimple_tail="1"b; go to DO_TAIL; end;	/* Case:   (a b)de(f g)   */
	     if nch="""" then do; nonsimple_tail="1"b; go to DO_TAIL; end;	/* Case:   (a b)de"xyz"   */

		/* Calculate the length of tail before first special character */
DO_TAIL:	simple_tail_lng=end_of_simple_tail-last_char_of_head-1;
	
		/* Copy simple portion of the tail (if any) into the atom being built. (e. g. in
		   (a b)DEF"1 2" then tail is DEF"1 2" and the simple portion of the tail is DEF   ) */
	if simple_tail_lng^=0 then
	     do;
	     substr(atom,last_char_of_atom+1,simple_tail_lng)=substr(input_line,last_char_of_head+2,simple_tail_lng);
	     last_char_of_atom=last_char_of_atom+simple_tail_lng;
	     end;

		/* If the tail has a special character in it (e.g. (a b)DEF"1 2" or (a b)DEF(1 2)   )
		   then call subroutine to process it */
	if nonsimple_tail then do; call process_special_char(end_of_simple_tail); if code^=0 then return; end;
	else first_char=end_of_simple_tail;

		/* Now fill in the part of the atom which appears before the first special character. (e g.
	  	   in  (ASDF"1 2")qwer  fill in ASDF. Blank it out in the input line unless it is attached
		   to another iteration set (e. g. in  (a b(de fgh)) the "a" is not attached
		   and the "b" is.  Set variables indicating no errors, the length of the atom being returned,
		   and where the caller should continue the scan of the input line, and return. */
	k=end_of_simple_head-first_nonblank;
	if k>0 then do; substr(atom,1,k)=substr(input_line,first_nonblank+1,k);
	if ^attached_iter_set then substr(input_line,first_nonblank+1,k)=" "; end;
	last_char_of_iter_set=first_char;
	atom_lng=last_char_of_atom;
	code=0;
	return;


UNBALANCED_PARENS:	code=error_table_$unbalanced_parentheses;
		return;
/*  */
		/* We are processing a null iteration set */
NULL_ITER_SET:  left_paren_cnt,right_paren_cnt=0;
	      in_quoted_string="0"b;
	      code=103;

		/* Find end of null iteration group.  i. e. we are cleaning up a case of the
		   ... (       )bc"d e;"( a) ...  The variable "in_quoted_string" indicates
		   that we are inside a quoted string and that characters which otherwise would
		   terminate the scan or indicate an error condition should be treated as ordinary characters */
	do k = end_of_simple_head+1 to input_line_lng;
	     nch=ch(k);
	     if nch=" " then
	          do;
	          if in_quoted_string then go to END_LOOP;	/* case:  (      )"abc def"   */
	          if left_paren_cnt=right_paren_cnt then go to END_NULL_ITER_SET;
	          end;
	     else  
	     if (nch=";") | (nch=nl) then 
		do;
		if in_quoted_string then go to END_LOOP;	/* case:  (    )";"  or  (    )"nl"     */
		go to END_NULL_ITER_SET;
		end;
	     else   
	     if nch="""" then
		if k=input_line_lng then in_quoted_string=^in_quoted_string;
		else
		if ch(k+1)="""" then k=k+1;
		else in_quoted_string=^in_quoted_string;
	     else   
	     if nch=")" then
		do;
		if in_quoted_string then go to END_LOOP;	/* case:  (   )")"    */
		if left_paren_cnt=right_paren_cnt then go to END_NULL_ITER_SET;	/* case    (    ))
							   e. g. in atom of form:   (((   ))  abc)  */
		right_paren_cnt=right_paren_cnt+1;
		end;
	     else   
	     if nch="(" then
		do;
		if in_quoted_string then go to END_LOOP;	/* case  (    )"("   */
		left_paren_cnt=left_paren_cnt+1;
		end;
	     else   
	     if left_paren_cnt^=right_paren_cnt then		/* case:   (ab(   )XY(1 2))  */
		do;
		code=error_table_$mismatched_iter;
		return;
		end;
END_LOOP: end;
	
		/* We have found the end of the null iteration set */
END_NULL_ITER_SET:	last_char_of_iter_set=k;
		return;
/*  */
		/* Internal procedure to find the matching right parenthesis in the iteration
		   set we are now processing */
find_matching_right_paren: proc;


	left_paren_cnt,right_paren_cnt=0;
	last_char_of_head = first_char-1;
FIND_LOOP:j = last_char_of_head;
	last_char_of_head = search(substr(input_line,j+2,input_line_lng-j),"();""
");
	if last_char_of_head=0 then go to BAD;
	last_char_of_head = last_char_of_head + j;
	     nch=ch(last_char_of_head);
	     if nch=")" then
		if ^in_quoted_string then
		     if left_paren_cnt=right_paren_cnt then return;
		     else right_paren_cnt=right_paren_cnt+1;
		else;
	     else   
	     if nch="(" then
		if ^in_quoted_string then left_paren_cnt=left_paren_cnt+1;
		else;
	     else
	     if (nch=";") | (nch=nl) then
		if ^in_quoted_string then go to BAD;
		else;
	     else
	     if nch="""" then
		if last_char_of_head=input_line_lng then in_quoted_string=^in_quoted_string;
		else
		if ch(last_char_of_head+1)="""" then last_char_of_head=last_char_of_head+1;
		else in_quoted_string=^in_quoted_string;
	if last_char_of_head < input_line_lng then go to FIND_LOOP;

BAD:	code=error_table_$unbalanced_parentheses;
	return;


end find_matching_right_paren;
/**/
		/* Internal procedure to search command line for a left bracket */

check_for_bracket: proc;

dcl	error_table_$unbalanced_brackets external fixed bin(35) aligned;



	     k = 0;
    CHECK_LOOP:j = k;
	     k = search(substr(input_line,j+2,input_line_lng-j),"[];""
");
	     if k=0 then return;
	     k = k+j;
	     nch=ch(k);
	     if nch="""" then
		if k=input_line_lng then in_quoted_string=^in_quoted_string;
		else
		if ch(k+1)="""" then k=k+1;
		else in_quoted_string=^in_quoted_string;
	     else   
	     if nch="[" then
		if ^in_quoted_string then   do; last_char_of_iter_set=k; code=102; return; end;
		else;
	     else
	     if (nch=";") | (nch=nl) then
		if ^in_quoted_string then return;
		else;
	     else
	     if nch="]" then
		if ^in_quoted_string then  do; code=error_table_$unbalanced_brackets; return; end;
	     if k < input_line_lng then go to CHECK_LOOP;

end check_for_bracket;
/*  */
		/* Internal procedure to process quoted strings and iteration sets
		   encountered while processing this iteration set */
process_special_char: proc(special_char_index);

dcl	(startp,
	 atmp
		) ptr aligned;

dcl	(special_char_index,
	 atoml,
	 lng,
	 inl_left
		) fixed bin aligned;

dcl	(proc_parens_,
	 proc_quotes_
			) ext entry(ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin(35));


		/* Set up arguments with which to call special syntatic subroutines */
	startp=addr(ch(special_char_index));
	atmp=addr(atomp->ch(last_char_of_atom));
	atoml=atom_buffer_lng-last_char_of_atom;
	inl_left=input_line_lng-special_char_index;
	
	if nch="(" then call proc_parens_(startp,inl_left,first_char,atmp,atoml,lng,"0"b,code);
	else call proc_quotes_(startp,inl_left,first_char,atmp,atoml,lng,"0"b,code);
	
	if nch="""" then
	     if quote_inside_parens then
		if code=101 then do; attached_iter_set="1"b; code=0; end;  /* case ("ab"(d qwe)) */
		else
		if code=103 then paren_inside_parens="1"b;	/* case  ("ab"(   ))  */
		else
		substr(input_line,end_of_simple_head+1,first_char)=" ";	/* case ("a" de) or ("a"2 def) */
	     else
	     if code=101 then code=0;		/* case (a b)"def"  */
	
	if code^=0 then
	     if code^=103 then return;
	     else   
	     if paren_inside_parens then	/* Case: (ab( )  d)   We must blank out used up set, i.e. ab( ) */
		do;
		substr(input_line,first_nonblank+1,first_char+end_of_simple_head-first_nonblank)=" ";
		code=-1;
		return;
		end;
	     else do; code=error_table_$mismatched_iter; return; end; 	/* case  (ab(cd er)d(  )  z)  */
	
	first_char=first_char+special_char_index;
	last_char_of_atom=last_char_of_atom+lng;
	
	return;


end process_special_char;

end proc_parens_;




		    proc_quotes_.pl1                09/25/78  1427.2rew 09/25/78  1427.2       35235



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

proc_quotes_: proc(a_inp,inl,last_char_scanned,a_atomp,spaceleft,atomlng,first_parenthesis,code);

/* initially coded in January 1970 by V. Voydock */
/* Modified to use PL/I quoting convention in June 1971 by V. Voydock */
/* EIS version Steve Herbst 3/4/74 */

dcl	(inl,
	 startno,
	 i,j,k,
	 last_char_scanned,
	 length_of_quoted_string initial(0),
	 length_of_tail,
	 lng,
	 spaceleft,
	 atomlng
		) fixed bin;

dcl      (code,
	error_table_$unbalanced_quotes external,
	error_table_$unbalanced_brackets external
					) fixed bin(35);

dcl	first_parenthesis bit(1) aligned;

dcl	(inp initial(a_inp),
	 atomp initial(a_atomp),
	 a_inp,
	 a_atomp
			) ptr;

dcl	nch char(1) aligned,
	atom char(spaceleft) based(atomp),
	input_line char(inl+1) based(inp);

dcl	special char(8) init(" ;()""
[]");

dcl	proc_parens_ ext entry(ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin,bit(1) aligned,fixed bin(35));


dcl	(addr, index, search, substr) builtin;

dcl	ich(0:31) char(1) unaligned based(inp),
	ach(0:31) char(1) unaligned based(atomp);
	
/*  */
	last_char_scanned,code=0;
	
		/* Look for a second quote. If it is followed immediately by another quote,
		   keep on going. Quoted string gets copied into the atom being built. */
LOOP:	j = last_char_scanned;
   again:	i = j;
	j = index(substr(input_line,i+2,inl-i),"""");
	if j=0 then go to UNBALANCED;
	j = j+i;
	if j=inl then do; nch = " ";  go to END_QUOTE; end;
	if ich(j+1)="""" then do;
	     substr(atom,length_of_quoted_string+1,j-i) = substr(input_line,i+2,j-i);
	     length_of_quoted_string = length_of_quoted_string + j - i;
	     j = j+1;
	     go to again;
	end;
	else go to END_QUOTE;
	
UNBALANCED: code = error_table_$unbalanced_quotes;
	  return;
	
END_QUOTE:k = j-i-1;
	if k>0 then substr(atom,length_of_quoted_string+1,k) = substr(input_line,i+2,k);
	length_of_quoted_string = length_of_quoted_string + k;

		/* Now see if anything is attached to quoted string  (e. g. "abc"(def ghj)     ) */
	last_char_scanned = search(substr(input_line,j+2,inl-j),special);
	if last_char_scanned=0 then do;
	     last_char_scanned = inl+1;
	     nch = " ";
	     go to PROC_TAIL;
	end;
	last_char_scanned = last_char_scanned + j;
	nch=ich(last_char_scanned);
	i = index(special,nch);
	if i<7 then go to PROC_TAIL;
	if i=7 then do; code = 102; return; end;
	else do; code = error_table_$unbalanced_brackets; return; end;
	
PROC_TAIL:
		/* Compute length of "tail". Then copy it into the atom being built */
	length_of_tail=last_char_scanned-j-1;
	if length_of_tail=0 then go to CHECK;
	substr(atom,length_of_quoted_string+1,length_of_tail)=substr(input_line,j+2,length_of_tail);
	
		/* If paren terminates tail, call paren handler, if quote, loop back, else return */
CHECK:	if nch^="(" then
	     if nch^="""" then go to RETURN;
	     else  do; length_of_quoted_string=length_of_quoted_string+length_of_tail; go to LOOP; end;
	
		/* Call parenthesis handler to take care of rest of atom */
	call proc_parens_(addr(ich(last_char_scanned)),inl-last_char_scanned,startno,
		        addr(ach(length_of_quoted_string+length_of_tail)),
		        spaceleft-length_of_quoted_string-length_of_tail,lng,first_parenthesis,code);

		/* Bump indices, indicate that we are processing iteration set and return */
	length_of_tail=length_of_tail+lng;
	last_char_scanned=last_char_scanned+startno;
	if code=0 then code=101;
RETURN:	atomlng=length_of_quoted_string+length_of_tail;
	return;
	
end proc_quotes_;




		    full_find_command_.pl1          12/19/78  1859.9rew 12/19/78  1859.9       95085



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

full_find_command_:  proc(am_ptr,comp,coml,entry_point_ptr,code);


/* find_command_ ..... standard service subroutine to return a pointer to a command entry point,
	given the command name as it originally appeared in the command line. */

/* Initial coding by R. C. Daley,December 1969 */
/* modified on June 23,1970 at 3:35 P. M. by V. Voydock */
/* Modified in November 1971 by V. Voydock to not blow up if a command of the form
   "name is typed, to force pathnames to override previously known reference names,
   and to make the code more readible */

/* Modified in May 1972 by V. Voydock as part of the fast command loop */
/* Modified 6/24/76 by S. Herbst to fix bugs */



/* ******************************************************************************************************* 
	 N_O_T_E_: The case of a pathname being passed (ie pointed to by "comp") is not as simple as it
	   may seem.  Let X be the reference name (i. e. entry name) portion of the pathname.
	   Several cases may occur.  The segment whose pathname was passed may already be known
	   to the process (either by the reference name X or another reference name), or another
	   segment may be known to the process by the reference name X, or X may not be known to the
	   process.  In _a_l_l cases, the name X may or may not exists in the AM.  This procedure has been
	   carefully coded to account for all these cases.  It should not be changed casually 
 ******************************************************************************************************* */




dcl	(comp,
	 p,
	 entry_point_ptr,
	 am_ptr,
	 oldp,
	 cp
		) ptr;

dcl	(coml,
	 command_length,
	ename_length,
	 entry_index initial(0),
	 entry_length initial(0),
	 oldu,
	 aml int static initial(9),		/* Size of associative memory */
	 i,
	 j
		   ) fixed bin;
/*  */
dcl	(pathname_given,
	 print_message,
	 am_entry_exists,
	 term_called,
	 pathname_error
			) bit(1) aligned init("0"b);

dcl	1 w aligned,				/* temporary for high speed comparison */
	     2 (c1,c2,c3,c4) fixed bin(71),		/* of command name (char(32)),*/
	     2 (s1,s2,s3,s4) fixed bin(71);		/* and entry name (char(32)). */

dcl	1 cs based(cp) aligned,			/* dcl for initialization of above structure */
	     2 command char(32),
	     2 entry char(32);


dcl	1 am(0:9) based(am_ptr) aligned,		/* declaration of associative memory */
	     2 command(2) fixed bin(71),			/* space for command name */
	     2 entry_point_ptr ptr,				/* pointer to command entry */
	     2 usage fixed bin;			/* usage indicator */

dcl	1 ame based(p) aligned,			/* based declaration for entry of assoc. mem. */
	     2 command char(16),
	     2 entry_point_ptr ptr,
	     2 usage fixed bin;



dcl	1 aw based(p) aligned,			/* dcl for associative memory lookup */
	     2 (c1,c2) fixed bin(71);		/* command name (char(32)) */

dcl	name char(168) based(p) unaligned,		/* based dcl for pickup of command name */
	dname char(168),				/* for pickup of expanded directory name */
	buffer char(168),				/* for ename (which might be >32) */
	nch char(1) aligned,
	cname char(coml) based(comp),			/* name to be printed on error */
	ch(0:167) char(1) unaligned based(p);

dcl 	SPACE char(2) int static options(constant) init("	 ");  /* blank and tab */

dcl	code fixed bin(35) aligned;

dcl	error_table_$seg_not_found fixed bin(35) ext,	/* standard error codes used by find_command_ */
	error_table_$namedup fixed bin(35) ext,
	error_table_$segknown fixed bin(35) ext,
	error_table_$bad_command_name fixed bin(35) ext,
	error_table_$dirseg fixed bin(35) ext,
	error_table_$entlong fixed bin(35) ext,
	error_table_$noentry fixed bin(35) ext,
	error_table_$no_ext_sym fixed bin(35) ext;

dcl	expand_pathname_ entry(char(*),char(*),char(*),fixed bin(35)),
	term_$no_clear ext entry(char(*) aligned,fixed bin(35)),
	hcs_$initiate ext entry(char(*) aligned,char(*) aligned,char(*) aligned,fixed bin,fixed bin,ptr,fixed bin(35)),
	hcs_$make_ptr ext entry(ptr,char(*) aligned,char(*) aligned,ptr,fixed bin(35)),
	(com_err_,
	 com_err_$suppress_name
				) external entry options(variable);

dcl	(addr, index, length, null, rtrim, substr, verify) builtin;
/*  */
	print_message="1"b;  go to START;

fc_no_message: entry(am_ptr,comp,coml,entry_point_ptr,code);  /* for the use of find_command_$fc_no_message */

	print_message = "0"b;
	go to START;

fc_print_message: entry(comp,coml,entry_point_ptr,code);	/* this was put in for the use of init_admin */

	print_message="0"b;

START:	if cname=">" then do;			/* command name ">" */
	     code = error_table_$dirseg;
	     go to ERROR;
	end;
	if verify(cname,SPACE)=0 then do;		/* blank command name */
BLANK:	     if print_message then call com_err_(0,"command_processor_","Blank command name.");
	     code = error_table_$seg_not_found;
	     return;
	end;
	p = comp;
	command_length=coml;

		/* Look for pathname and for entry name explicitly specified (i. e. "$") */
	do i=0 to command_length-1;
	     nch=ch(i);
	     if nch=">"  then pathname_given="1"b;
	     if nch="<"  then pathname_given="1"b;
	     if nch="$" then
		do;
		command_length=i;				/* if entry found,adjust command name length */
		if command_length=0 then  do; code=error_table_$bad_command_name; go to ERROR; end;
		entry_index=command_length+2;			/* locate first character of entry */
		entry_length = length(rtrim(cname))-entry_index+1;  /* get length of entry name */
		if entry_length=0 then do;
ENTNULL:		     code = error_table_$bad_command_name;
		     go to ERROR;
		end;
		if verify(substr(cname,i+2),SPACE)=0 then  go to ENTNULL;
		if entry_length>length(cs.entry) then do;
		     buffer = substr(cname,i+1,entry_length);
ENTLONG:		     code = error_table_$entlong;
		     if print_message then call com_err_(code,"command_processor_","^a",buffer);
		     return;
		end;
		go to FIND_IT;			/* skip out of character scan */
		end;
	end;


		/* If a pathname was passed, convert it to an absolute pathname. Otherwise,
		   pick up the simple command name */
FIND_IT:	cp=addr(w);
	if pathname_given  then 
	     do;
	     call expand_pathname_(substr(name,1,command_length),dname,buffer,code);
	     if code^=0 then go to ERROR;
	     end;
	else buffer = substr(p->name,1,command_length);
	if verify(buffer,SPACE)=0 then go to BLANK;
	ename_length = length (rtrim (buffer));
	if ename_length > length(cs.entry) then go to ENTLONG;
	cp -> cs.command = buffer;

		/* Now store away the entry name if one was specified. Otherwise the
		   entry name is the same as the command name */
	if entry_index^=0  then cp->cs.entry=substr(p->name,entry_index,entry_length);
	else  cp->cs.entry=cp->cs.command;

		/* If a pathname was passed, initiate it to override the search rules (i. e. "initiated_segments"
		   is the first thing in the search rules). If another segment is already known by the
		   same reference name, we terminate it (and remove it from the AM if it is there) */
	if pathname_given then
	     do;
LOOP:	     call hcs_$initiate((dname),cp->cs.command,cp->cs.command,0,0,p,code);
	     if code^=0 then
		do;
		if code=error_table_$segknown then go to SEARCH_AM;
		if term_called then  do; pathname_error="1"b; go to SEARCH_AM; end;
		if code^=error_table_$namedup then go to ERROR;
		call term_$no_clear(cp->cs.command,code);
		if code^=0 then go to ERROR;
		term_called="1"b;
		go to LOOP;
		end;
	     end;
/*  */
SEARCH_AM:
	if (ename_length>16) | (nch="$") then go to CALL_MP;

		/* Search associative memory for command/entry name match.  The comparison
		   is made using based fixed bin(71) variables to maximize the
		   efficiency of the search.  If a match is found and the command was
		   specified by a pathname, then the pathname must overide the associative memory.
		   That is, the AM entry of the old segment is replaced by
		   a pointer to the segment specified by the pathname */
	oldu=aml+1;
	do i=0 to aml;
	     p=addr(am(i));
	     if p->aw.c1^=w.c1  then go to SKIP;
	     if p->aw.c2^=w.c2  then go to SKIP;
	     p->ame.usage=aml+1;			/* entry found,indicate recent usage */
	     entry_point_ptr=p->ame.entry_point_ptr;			/* pick up command entry pointer */

	     do j=i+1 to aml;			/* decrement usage for remaining AM entries */
		am(j).usage=am(j).usage-1;
	     end;

	     if pathname_given then			/* pathname overrides AM */
		do;
		oldp=p;
		if pathname_error then go to CLEAR_AME;		/* have found entry to clear */
		am_entry_exists="1"b;
		go to CALL_MP;
		end;

	     code=0;				/* set return status code for successful return */
	     return;

SKIP:	     p->ame.usage=p->ame.usage-1;		/* this AM entry does not match,decrement usage */
	     if p->ame.usage<oldu  then		/* is this the least used entry seen so far? */
		do;
		oldu=p->ame.usage;			/* if so,remember this entry */
		oldp=p;
		end;
	end;

		/* Command was not found in associative memory.  We must try to snap a link to it */
CALL_MP:	call hcs_$make_ptr(null,cp->cs.command,cp->cs.entry,entry_point_ptr,code);
	if code^=0 then  do; if am_entry_exists then go to CLEAR_AME; go to ERROR; end;

		/* If linking was successful and command name is of correct form, put it in AM */
	if ename_length<17 then
	     if nch^="$" then
		do;
		oldp->ame.command=cp->cs.command;
		oldp->ame.entry_point_ptr=entry_point_ptr;
		oldp->ame.usage=aml+1;
		end;
	return;					/* return control to caller */
/*  */
CLEAR_AME:
	oldp->aw.c1,oldp->aw.c2=0;

ERROR:	entry_point_ptr=null;

		/* Do not print error message if called at fc_no_message entry */
	if print_message then
	     do;
	     if code=error_table_$seg_not_found  then 	/* check for segment not found */
NO_SEG:		call com_err_$suppress_name(0,"command_processor_","Segment ^R^a^B not found.",cp->cs.command);
	     else
	     if code=error_table_$noentry then go to NO_SEG;
	     else
	     if code=error_table_$no_ext_sym  then	/* check for entry not found */
		call com_err_$suppress_name(0,"command_processor_","Entry point ^R^a^B not found in segment ^R^a^B."
				        ,cp->cs.entry,cp->cs.command);
	     else
	     call com_err_(code,"command_processor_","^R^a^B",cname);
	     end;

end  full_find_command_;




		    find_command_error_.pl1         12/19/78  1859.9rew 12/19/78  1859.9       13644



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

find_command_error_: proc(cp,code);

/* Initially coded in May 1972 by V. Voydock as part of fast command loop */

dcl	cp ptr;

dcl	(code,
	 error_table_$seg_not_found external,
	 error_table_$noentry external,
	 error_table_$no_ext_sym external
			) fixed bin(35);

dcl	command_name char(32) aligned based(cp);

dcl	com_err_ ext entry options(variable),
	com_err_$suppress_name ext entry options(variable);
/*  */
		/* Check for segment not found */
	if code=error_table_$seg_not_found  then 
NO_SEG: 	     do;
	     call com_err_$suppress_name(0,"command_processor_","Segment ^R^a^B not found.",cp->command_name);
	     return;
	     end;
	if code=error_table_$noentry then go to NO_SEG;
	if code=error_table_$no_ext_sym  then	/* check for entry not found */
	     do;
	     call com_err_$suppress_name(0,"command_processor_","Entry point ^R^a^B not found in segment ^R^a^B.",
				   cp->command_name,cp->command_name);
	     return;
	     end;
	else call com_err_(code,"command_processor_","^R^a^B",cp->command_name);

end find_command_error_;



		    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
