



		    bce_exec_com_.pl1               11/11/89  1133.9r w 11/11/89  0826.1      113643



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_exec_com_:     procedure (ss_info_ptr);

/* Modified from absentee_listen_ to become bootload Multics exec_com by 
Keith Loepere, April 1983 */
/* Modified August 1983 by Keith Loepere for new bce switches. */

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

declare  (addr, addrel, empty, index, length, ltrim, min, null, reverse, rtrim, search, substr, unspec, verify)
				  builtin;

declare  (cleanup, request_abort_, sub_request_abort_)
				  condition;

declare  arg_count			  fixed bin,
         arg_len			  fixed bin (21),
         arg_ptr			  ptr,
         arg			  char (arg_len) based (arg_ptr),
         arg_list_ptr		  ptr,
         actual_len			  fixed bin (21),
         bce_data$get_line		  entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable external,
         1 bce_get_line_entry		  aligned based (addr (bce_data$get_line)), /* template for an entry variable */
	 2 proc			  ptr,
	 2 env			  ptr,
         bce_data$get_line_data_ptr	  ptr external,
         bce_data$subsys_info_ptr	  ptr external,
         bce_data$command_abs_data_ptr	  ptr external,
         bce_ready			  entry (char (*)),
         ec_file_name		  char (32),
         1 my_abs_data		  aligned like abs_data,
         old_abs_data_ptr		  ptr,
         read_chars			  char (read_len) based (read_ptr),
         read_len			  fixed bin (21),
         read_ptr			  ptr,
         seg_ptr			  ptr,
         status			  fixed bin (35),
         temp_seg_ptr		  ptr,
         whoami			  char (32),
         work_len			  fixed bin (21),
         work_ptr			  ptr,
         work_string		  char (work_len) based (work_ptr);

declare  1 ec_info			  aligned like ec_data;

declare  CP_null_line		  fixed bin init (100) static options (constant);  /* cp_ returns this for null line */

declare  (
         error_table_$badopt,
         error_table_$badpath,
         error_table_$end_of_info,
         error_table_$not_act_fnc,
         error_table_$unimplemented_version
         )			  fixed bin (35) external,
         sys_info$max_seg_size	  fixed bin (18) external;

declare  active_fnc_err_		  entry options (variable),
         bce_check_abort		  entry,
         bce_data$exec_com_get_line	  entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable ext,
         bce_execute_command_		  entry (ptr, char (*), ptr, fixed bin (35)),
         bootload_fs_$get_ptr		  entry (char (*), ptr, fixed bin (21), fixed bin (35)),
         command_processor_$subsys_execute_line entry (char (*), ptr, entry, ptr, char (*), fixed bin (35)),
         com_err_			  entry options (variable),
         cu_$af_return_arg_rel	  entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         cu_$arg_ptr_rel		  entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
         cu_$arg_list_ptr		  entry () returns (ptr),
         cu_$generate_call		  entry (entry, ptr),
         cv_dec_check_		  entry (char (*), fixed bin (35)) returns (fixed bin (35)),
         get_temp_segment_		  entry (char (*), ptr, fixed bin (35)),
         release_temp_segment_	  entry (char (*), ptr, fixed bin (35));
%page;
%include bce_abs_io_data;
%page;
%include bce_subsystem_info_;
%page;
%include ec_data;
%page;
	old_abs_data_ptr = bce_data$command_abs_data_ptr;

	call initialize_ec_info ();

	ec_info.who_am_i, whoami = "exec_com";

	call check_arg_list (ss_info.arg_list_ptr);

	if arg_count < 1 then do;
	     if ec_info.active_function
	     then call active_fnc_err_ (0, whoami, "Usage:  [ec path {args}]");
	     else do;
		call com_err_ (0, whoami, "Usage:  ec path {args}");
		signal request_abort_;
	     end;
	     go to EGRESS;
	end;

	on cleanup call clean_up ();

	call get_temp_segment_ ((ec_info.who_am_i), temp_seg_ptr, status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Getting temp segment.");
	     
	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, status, ss_info.arg_list_ptr);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Getting first argument.");

	if substr (arg, 1, min (arg_len, 1)) = "-"
	then call complain (error_table_$badopt, ec_info.who_am_i, "^a", arg);
	begin;
declare  1 args			  (arg_count - 1) aligned,
	 2 ptr			  ptr,
	 2 len			  fixed bin (21),
	 2 quotes			  fixed bin (21);

	     call attach_ec (find_ec ());

	     if ec_info.active_function then ec_info.call_ready_proc = "0"b;
	     status = CP_null_line;			/* Suppress initial call to ready proc			*/
%page;
/* The following routine reads lines from the input file and passes them on to the command processor. It communicates
   with bce_exec_com_input through the attach_data block (found by bce_data$command_abs_data_ptr) in order to determine
   when command vs. input lines are being read and what the ready mode is.					*/

	     do while ("1"b);
		if ec_info.call_ready_proc & status ^= CP_null_line then call invoke_ready_procedure ();

		ec_info.input_line = "0"b;

		read_ptr, work_ptr = temp_seg_ptr;
		read_len = 4096;		/* 1st page */
		work_len = 0;
		do while (status ^= 0 | work_len = 0);
		     on sub_request_abort_ go to EGRESS;
		     call bce_check_abort;
		     call bce_data$exec_com_get_line (addr (bce_data$exec_com_get_line), addr (read_chars), length (read_chars), actual_len, status);
		     revert sub_request_abort_;
		     work_len = work_len + actual_len;
		     if status ^= 0 then
			if status = error_table_$end_of_info then
			     if work_len = 0 then go to EGRESS; /* I don't know if this is exactly legal, and I know that	*/
			     else status = 0;	/* bce_exec_com_input wont do this, but if there is a partial line...	*/
			else do;
			     call com_err_ (status, ec_info.who_am_i, "Error while reading command line.");
			     signal request_abort_;
			end;
		end;

		ec_info.input_line = "1"b;		/* anything read after this point is an input line	*/

		on request_abort_ go to EGRESS;
		on sub_request_abort_ go to EGRESS;
		call command_processor_$subsys_execute_line ("bce", bce_data$subsys_info_ptr, bce_execute_command_, null (), work_string, status);
		if status ^= 0 then
		     if status ^= CP_null_line then call com_err_ (status, whoami);
		revert request_abort_;
		revert sub_request_abort_;
	     end;
	     go to EGRESS;
%page;
invoke_ready_procedure:
     procedure ();

	call bce_ready ("bce (ec)");
	return;

     end invoke_ready_procedure;
%page;
attach_ec:
     procedure (pathname);

declare  NL			  char (1) static options (constant) init ("
");
declare  WHITE			  char (5) static options (constant) initial ("
	 ");					/* FF VT NL TAB SPACE				*/
declare  arg_num			  fixed bin;
declare  idx			  fixed bin (21);
declare  input_file			  char (abs_data.input_string.len) based (abs_data.input_string.ptr);
declare  pathname			  char (*);

	whoami = "exec_com";

	abs_data_ptr = addr (my_abs_data);

	unspec (abs_data) = "0"b;

	abs_data.allocated_chars_ptr = addrel (temp_seg_ptr, 1024);
	abs_data.allocated_chars_len = 4096;		/* 2nd page */
	abs_data.work_area_ptr = addrel (temp_seg_ptr, 2048);  /* rest */
	abs_data.work_area_len = sys_info$max_seg_size - 2048;
	abs_data_work_area = empty ();
%page;
	abs_data.arg_info.arg_ptr, abs_data.input_string.ptr, abs_data.ec_data_ptr = null ();
	abs_data.else_clause_ptr, abs_data.chars_ptr = null ();
	abs_data.attach.save_ptr, abs_data.attach.victim_ptr = null ();
	abs_data.labels_ptr = null ();
	abs_data.arg_info.ec_name_ptr = null ();
%page;
	call initiate_input_path (pathname);

/* Determine version of input file									*/

	if substr (input_file, 1, min (8, abs_data.input_string.len)) ^= "&version" | search (input_file, WHITE) ^= 9
	then do;
	     abs_data.input_string.start, abs_data.input_string.limit = 0;
	end;
	else do;
	     idx = index (substr (input_file, 9), NL);
	     if idx = 0
	     then call complain (error_table_$unimplemented_version, whoami, "Newline must end &version statement.");
	     if verify (substr (input_file, 9, idx - 1), WHITE) = 0
	     then call complain (error_table_$unimplemented_version, whoami,
		     "No version given in &version statement.");
	     if status ^= 0 | cv_dec_check_ (ltrim (rtrim (substr (input_file, 10, idx - 2), WHITE), WHITE), status) ^= 1 /* only version */
	     then call complain (error_table_$unimplemented_version, whoami, "&version ""^a""",
		     substr (input_file, 10, idx - 2));
	     abs_data.input_string.start, abs_data.input_string.limit = idx + 8;
	end;
%page;



/* ATTACH HERE */


	abs_data.comment_line.on, abs_data.control_line.on = "0"b; /* implement tracing defaults				*/
	if ec_info.active_function then abs_data.command_line.on, abs_data.input_line.on = "0"b;
	else abs_data.command_line.on, abs_data.input_line.on = "1"b;

	abs_data.active, abs_data.eof = "0"b;
	unspec (abs_data.if_info) = "0"b;
	abs_data.chars_ptr, abs_data.else_clause_ptr = null ();
	abs_data.nest_level, abs_data.expected_nest_level = 0;
	abs_data.chars_len, abs_data.else_clause_len = 0;
	abs_data.input_string.position = abs_data.input_string.start;

	abs_data.ec_data_ptr = addr (ec_info);

	abs_data.arg_ptr = addr (args);
	abs_data.arg_count = arg_count - 1;
	do arg_num = 2 to arg_count;
	     call cu_$arg_ptr_rel (arg_num, args (arg_num - 1).ptr, args (arg_num - 1).len, status, arg_list_ptr);
	     args (arg_num - 1).quotes = -1;
	end;
	bce_data$command_abs_data_ptr = abs_data_ptr;
	return;

     end attach_ec;
%page;
find_ec:
     procedure () returns (char (*));

declare  (index, reverse, rtrim)	  builtin;

declare  pathname			  char (32) varying;

	pathname = arg;

	if index (reverse (rtrim (pathname)), "ce.") ^= 1 then pathname = rtrim (pathname) || ".ec";

	return (pathname);

     end find_ec;
%page;
initiate_input_path:
     procedure (file_name);

declare  file_name			  char (*) parameter,
         input_entry_len		  fixed bin (21);

	call bootload_fs_$get_ptr (file_name, abs_data.input_string.ptr, abs_data.input_string.len, status);
	if abs_data.input_string.ptr = null ()
	then call complain (status, whoami, "Input file: ^a", file_name);

/* Fill in &ec_name (&0) */

	input_entry_len = length (rtrim (file_name));

	abs_data.ec_name_ptr = addr (ec_file_name);
	substr (ec_file_name, 1, input_entry_len) = substr (file_name, 1, input_entry_len);

	abs_data.ec_name_len = input_entry_len - index (reverse (substr (file_name, 1, input_entry_len)), ".");
	if abs_data.ec_name_len = 0 then call complain (error_table_$badpath, whoami);
	return;

     end initiate_input_path;
     end; /* begin block */

EGRESS:
	call clean_up ();
	return;
%page;
initialize_ec_info:
     procedure ();

	seg_ptr = null ();

	ec_info.active_function = "0"b;
	ec_info.return_len = 0;
	ec_info.return_ptr = null ();
	ec_info.input_line = "1"b;
	ec_info.call_ready_proc = "0"b;
	return;

     end initialize_ec_info;
%page;
check_arg_list:
     procedure (P_arg_list_ptr);

declare  P_arg_list_ptr		  ptr;

	arg_list_ptr = P_arg_list_ptr;

	call cu_$af_return_arg_rel (arg_count, ec_info.return_ptr, ec_info.return_len, status, arg_list_ptr);
	if status = 0 then ec_info.active_function = "1"b;
	else if status ^= error_table_$not_act_fnc
	then call complain (status, ec_info.who_am_i, "Getting argument list.");

	return;

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

	if bce_data$command_abs_data_ptr ^= old_abs_data_ptr then do;
	     if bce_data$command_abs_data_ptr = bce_data$get_line_data_ptr then do; /* &attach in effect */
		bce_get_line_entry.env = null ();
		bce_get_line_entry.proc = bce_data$command_abs_data_ptr -> abs_data.victim_ptr;
		bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr -> abs_data.save_ptr;
	     end;		/* now &detach'ed */

	     bce_data$command_abs_data_ptr = old_abs_data_ptr;
	end;
	if temp_seg_ptr ^= null then call release_temp_segment_ ((ec_info.who_am_i), temp_seg_ptr, status);
	return;

     end clean_up;
%page;
complain:
     procedure () options (variable);

declare  arg_list_ptr		  ptr;

	arg_list_ptr = cu_$arg_list_ptr ();

	if ec_info.active_function then call cu_$generate_call (active_fnc_err_, arg_list_ptr);
	else call cu_$generate_call (com_err_, arg_list_ptr);

	go to EGRESS;

     end complain;
     end bce_exec_com_;




		    bce_exec_com_input.pl1          11/11/89  1133.9r w 11/11/89  0826.1      413577



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */
bce_exec_com_input: proc (bce_sw_data_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status);

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

/* major part of v1 exec_com converted for bootload Multics by
Keith Loepere April 1983 */
/* Modified August 1983 for new bce switches */

declare  bce_sw_data_ptr		  ptr,
         P_buffer			  char (P_actual_len) based (P_buffer_ptr),
         P_buffer_ptr		  ptr,
         P_buffer_len		  fixed bin (21),
         P_actual_len		  fixed bin (21),	/* length of data actually returned			*/
         P_status			  fixed bin (35);	/* standard system error code				*/

declare  (addr, binary, char, codeptr, copy, divide, index, length, ltrim, max, min, mod, null, rank, rtrim, search,
         string, substr, unspec, verify)
				  builtin;

declare  (area, cleanup, request_abort_, sub_request_abort_)
				  condition;

declare  1 bce_switch aligned based,		/* bce i/o switch */
       2 routine_entry		  entry,
       2 data_ptr			  ptr;

declare  1 bce_get_line_entry		  aligned based (addr (bce_data$get_line)), /* template for an entry variable */
       2 proc			  ptr,
       2 env			  ptr;

declare  IS			  char (input_string.len) based (input_string.ptr),
         old_IS_pos			  fixed bin (21);

declare  CL_len			  fixed bin (21),
         CL_pos			  fixed bin (21),
         CL_ptr			  ptr,
         CL			  char (CL_len) based (CL_ptr),
         not_in_CL			  bit (1) aligned,
         old_CL_pos			  fixed bin (21);

declare  RS_len			  fixed bin (21),
         RS_pos			  fixed bin (21),
         RS_ptr			  ptr,
         RS			  char (RS_len) based (RS_ptr),
         old_RS_len			  fixed bin (21);
%page;
declare  arg_idx			  fixed bin,
         break			  fixed bin,
         buffer_allocated		  bit (1) aligned,
         buffer_len			  fixed bin (21),
         buffer_ptr			  ptr,
         control			  fixed bin,
         copy_len			  fixed bin (21),
         from_sw			  bit (1) aligned,
         get_next_line		  local label variable,
         hash			  fixed bin,
         input_reset_sw		  bit (1) aligned,
         len			  fixed bin (21),
         quote_modifier		  fixed bin,
         start			  fixed bin (21),
         state			  fixed bin,
         saved_hash			  fixed bin,
         saved_label_ptr		  ptr,
         saved_state		  fixed bin,
         scanning_clause		  bit (1) aligned,
         status			  fixed bin (35),
         test			  bit (1) aligned,
         twoL			  fixed bin (21),
         width			  fixed bin;

declare  1 ready_mode		  aligned,
	 2 flag			  bit (1) unaligned,
	 2 pad			  bit (35) unaligned;

declare  ec_name			  char (arg_info.ec_name_len) based (arg_info.ec_name_ptr),
         return_arg			  char (ec_data.return_len) varying based (ec_data.return_ptr);

declare  arg_string			  char (arg_array (arg_idx).len) based (arg_array (arg_idx).ptr);

declare  1 arg_array		  (abs_data.arg_count) aligned based (abs_data.arg_ptr),
	 2 ptr			  ptr,
	 2 len			  fixed bin (21),
	 2 quotes			  fixed bin (21);
%page;
declare  NL			  char (1) static options (constant) initial ("
");

declare  NL_THEN_AMP		  char (2) static options (constant) initial ("
&");

declare  SPACE			  char (1) static options (constant) initial (" "),
         TRUE			  char (4) static options (constant) initial ("true"),
         FALSE			  char (5) static options (constant) initial ("false"),
         TRACE_THEN			  char (6) static options (constant) initial ("&then "),
         TRACE_ELSE			  char (6) static options (constant) initial ("&else ");

declare  RANK_ZERO			  fixed bin static options (constant) initial (48),
         RANK_AMP_ADJ		  fixed bin static options (constant) initial (-10),
         RANK_F_ADJ			  fixed bin static options (constant) initial (54);

declare  NONE			  fixed bin static options (constant) initial (0),
         QUOTE			  fixed bin static options (constant) initial (1),
         REQUOTE			  fixed bin static options (constant) initial (2);

declare  NORMAL			  fixed bin static options (constant) initial (0),
         SEARCHING_FOR_LABEL		  fixed bin static options (constant) initial (1),
         MUST_BE_LABEL		  fixed bin static options (constant) initial (2),
         MUST_BE_THEN		  fixed bin static options (constant) initial (3),
         SKIPPING_CLAUSE		  fixed bin static options (constant) initial (4);

declare  DATA			  fixed bin static options (constant) initial (-1),
         COMMENT			  fixed bin static options (constant) initial (0),
         ELSE			  fixed bin static options (constant) initial (6),
         GOTO			  fixed bin static options (constant) initial (7),
         LABEL			  fixed bin static options (constant) initial (10),
         THEN			  fixed bin static options (constant) initial (16);

declare  LOW			  (12) fixed bin static options (constant)
				  initial (1, 2, 5, 6, 7, 8, 10, 11, 12, 13, 16, 17);

declare  HIGH			  (12) fixed bin static options (constant)
				  initial (1, 4, 5, 6, 7, 9, 10, 11, 12, 15, 16, 17);

declare  KEYWORD			  (17) char (12) varying static options (constant)
				  initial ("attach", "command_line", "comment_line", "control_line", "detach",
				  "else", "goto", "if", "input_line", "label", "print", "quit", "ready",
				  "ready_proc", "return", "then", "version");

declare  TRACE			  (-1:17) bit (1) aligned static options (constant)
				  initial ("0"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, (7) ("1"b), "0"b, "0"b);

declare  SKIPABLE			  (-1:17) bit (1) aligned static options (constant)
				  initial ("1"b, "0"b, (5) ("1"b), "0"b, "1"b, "0"b, "1"b, "0"b, (5) ("1"b), "0"b,
				  "1"b);

declare  WHITE			  char (5) static options (constant) initial ("
	 ");					/* FF VT NL HT SP					*/

declare  (
         error_table_$noalloc,
         error_table_$command_line_overflow,
         error_table_$end_of_info,
         error_table_$long_record
         )			  fixed bin (35) external,
         bce_data$command_abs_data_ptr	  pointer external,
         bce_data$get_line_data_ptr	  pointer external,
         bce_data$subsys_info_ptr	  pointer external,
         bce_data$put_chars		  entry (ptr, ptr, fixed bin (21), fixed bin (35)) variable ext,
         bce_data$get_line		  entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)) variable ext;

declare  active_fnc_err_		  entry () options (variable),
         bce_check_abort		  entry,
         com_err_			  entry () options (variable),
         cu_$arg_list_ptr		  entry () returns (ptr),
         cu_$arg_ptr		  entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
         command_processor_$subsys_eval_string
				  entry (char (*), ptr, entry, ptr, char (*), fixed bin, char (*) var, fixed bin (35)),
         bce_execute_command_		  entry (ptr, char (*), ptr, fixed bin (35)),
         ioa_$general_rs		  entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)),
         ioa_$nnl			  entry options (variable);
%page;
%include bce_abs_io_data;
%page;
%include abs_io_hash;
%page;
%include ec_data;
%page;
/* bce_exec_com_input: procedure (bce_sw_data_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status); */

	abs_data_ptr = bce_sw_data_ptr -> bce_switch.data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;
	buffer_ptr = P_buffer_ptr;
	buffer_len = P_buffer_len;
	input_reset_sw = "0"b;

/* recursion check. used to protect against &if [<get from ec>] */

	if abs_data.active then
	     if attachedp ()
	     then do;				/* Not our problem; we can offload this request to attachee */
		call bce_data$get_line (addr (bce_data$get_line), P_buffer_ptr, P_buffer_len, P_actual_len, P_status);
		return;
	     end;
	     else do;
		call com_err_ (0, "bce_exec_com_", "Attempt to invoke parser recursively.  Check for invalid ""&if"" test.");
		signal request_abort_;
	     end;

	on cleanup abs_data.active = "0"b;		/* Protect against non-local goto			*/

	abs_data.active = "1"b;			/* Prevent recursive invocation of this I/O switch	*/

/* Handle abnormal situations:  no data left, or partial line remaining.  Initialize for exit paths as needed.	*/

	if abs_data.eof then go to END_OF_FILE;		/* No data left, just exit without doing any work		*/

	if abs_data.chars_len > 0 then go to CONTINUE_LONG_RECORD;

/* Now initialize variables for the scan...								*/

	width = 0;				/* width of modifier field, e.g., f, q, r, qf, rf, f&n, etc */
	quote_modifier = NONE;			/* quote processing to be done to current parameter	*/
	from_sw = "0"b;				/* current parameter doesn't (yet) have f as in &f	*/
	saved_hash = -1;				/* used by &goto... valid range 0:60			*/

/* Hack nested &if statements where we returned something and have to skip the rest of a compound statement		*/

	if abs_data.nest_level > abs_data.expected_nest_level
	then state = SKIPPING_CLAUSE;			/* In the middle of an &if:  if we're here, skip the rest	*/
	else state = NORMAL;

	if abs_data.else_clause_len > 0 then go to CONTINUE_WITH_PENDING_ELSE_CLAUSE;
						/* not finished with last line, can't expand another yet	*/

	buffer_allocated = "0"b;			/* Initially expanding into P_buffer			*/
	get_next_line = EXPAND_NEXT_LINE;		/* Normal setting.  Used by &if nesting get control back.	*/
	CL_len = 0;				/* No statements scanned yet, so don't skip anything	*/
%page;
EXPAND_NEXT_LINE:
	input_string.position = input_string.position + CL_len;
						/* Position to the beginning of the next statement	*/
	if input_string.position >= input_string.len then go to END_OF_FILE;
						/* If we've gone too far, punt now			*/

	CL_ptr = addr (substr (IS, input_string.position + 1));
	CL_len = index (substr (IS, input_string.position + 1), NL);
	if CL_len = 0 then go to NO_NEW_LINE;		/* Must be at end of file, print warning and &quit	*/

	not_in_CL = "0"b;				/* Use original line in input seg, no expansions so far	*/
	scanning_clause = "0"b;			/* We are not currently within an &then or &else clause	*/

	CL_pos = index (CL, "&") - 1;			/* Find the first ampersand in the current line		*/
	if CL_pos < 0 then go to COPY_REST;		/* No ampersands in line.  Skip expansion loop.		*/

	RS_len, old_CL_pos, old_RS_len = 0;		/* So far we've expanded nothing			*/
	RS_ptr = buffer_ptr;			/* We will expand to here, if necessary			*/
	twoL = 1;					/* This is 2**(quote depth), used for requoting		*/

	if CL_pos = 0
	then do;					/* First char is ampersand.  Special case for fast comments */
	     break = index ("0123456789efinqracdglptv", substr (CL, 2, 1)) - 1;
	     if break < 0 then go to COMMENT_LINE;	/* If it's a comment, we needn't expand it or return it	*/
	     if break < 10 then go to EXPAND_ARG_NUMBER;
						/* A digit.  Get whole number and expand argument		*/
	     if break < 16 then go to EXPAND (break);	/* Might be expandable, investigate further		*/
	     go to EXPAND_AGAIN;			/* This might be a keyword, but we can't handle it now.	*/
	end;
%page;
/* This is the loop which expands lines from the input segment.  It is entered here if the first character on the line
   is not an ampersand.  If the first character is an ampersand, it will have been handled on the previous page as a
   performance hack to not expand comment lines.  If no expandable constructs are encountered, the line will still be
   in the input segment.  If expansion is done, it is initially into the caller-provided buffer, but if that is too
   small, a larger buffer will be allocated and expansion will use it until the next line is returned to the caller.	*/

EXPAND_LOOP:
	break = index ("0123456789efinqr", substr (CL, CL_pos + 2, 1)) - 1;
	if break < 0 then go to EXPAND_AGAIN;		/* Not expandable. skip it				*/
	if break < 10 then go to EXPAND_ARG_NUMBER;	/* A digit.  Get whole number and expand argument		*/
	go to EXPAND (break);			/* Might be expandable... investigate further		*/

EXPAND (10):					/* &e						*/
	if substr (CL, CL_pos + 3, 1) ^= "c" then go to EXPAND_AGAIN;
						/* performance hack for &else				*/

	if substr (CL, CL_pos + 4, min (CL_len, 5)) = "_name" then call emit_ec_name ();

	go to EXPAND_AGAIN;

EXPAND (11):					/* &f						*/
	from_sw = "1"b;

	go to EXPAND_MODIFIER;

EXPAND (12):					/* &i						*/
	if substr (CL, CL_pos + 3, 1) ^= "s" then go to EXPAND_AGAIN;
						/* Performance hack for &if				*/

	if substr (CL, CL_pos + 4, min (CL_len - 3, 16)) = "_active_function"
	then call predicate (functionp (), 18);
	else if substr (CL, CL_pos + 4, min (CL_len - 3, 3)) = "_af" then call predicate (functionp (), 5);
	else if substr (CL, CL_pos + 4, min (CL_len - 3, 9)) = "_attached" then call predicate (attachedp (), 11);
	else if substr (CL, CL_pos + 4, min (CL_len - 3, 11)) = "_input_line" then call predicate (input_linep (), 13);

	go to EXPAND_AGAIN;

EXPAND (13):					/* &n:  The number of arguments given for substitution	*/
	call emit_arg_count ();

	go to EXPAND_AGAIN;

EXPAND (14):					/* &q						*/
	quote_modifier = QUOTE;

	go to EXPAND_MODIFIER;

EXPAND (15):					/* &r						*/
	quote_modifier = REQUOTE;

EXPAND_MODIFIER:
	width = width + 1;
	break = rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO;
	if break = RANK_F_ADJ & ^from_sw
	then do;
	     from_sw = "1"b;
	     go to EXPAND_MODIFIER;
	end;
	if break = RANK_AMP_ADJ
	then if substr (CL, CL_pos + width + 3, 1) = "n"
	     then do;				/* &..&n:  Appropriately modified last argument		*/
		arg_idx = abs_data.arg_count;
		width = width + 2;
		go to COPY_ARG;
	     end;
	if break < 0 | break > 9
	then do;					/* Construct isn't really a parameter, skip it		*/
	     width = 0;				/* Reset these to default values, save the work elsewhere	*/
	     quote_modifier = NONE;
	     from_sw = "0"b;
	     go to EXPAND_AGAIN;
	end;

EXPAND_ARG_NUMBER:
	arg_idx = 0;
	do break = break repeat (rank (substr (CL, CL_pos + width + 2, 1)) - RANK_ZERO) while (break >= 0 & break <= 9);
	     if arg_idx <= abs_data.arg_count then arg_idx = 10 * arg_idx + break;
	     width = width + 1;
	end;

COPY_ARG:
	call copy_up_to_ampersand (width);		/* Skip construct (width chars long)			*/
	width = 0;
	if from_sw
	then do;					/* User specified range of arguments to expand		*/
	     from_sw = "0"b;
	     do arg_idx = max (1, arg_idx) to abs_data.arg_count;
		call copy_string (arg_string, quote_modifier);
		if arg_idx ^= abs_data.arg_count then call copy_string (SPACE, NONE);
	     end;
	end;
	else if arg_idx = 0 then call copy_string (ec_name, quote_modifier);
	else if arg_idx <= abs_data.arg_count then call copy_string (arg_string, quote_modifier);
	quote_modifier = NONE;

EXPAND_AGAIN:
	CL_pos = CL_pos + 1;			/* Skip ampersand					*/
	break = index (substr (CL, CL_pos + 1), "&") - 1;
	if break >= 0
	then do;					/* Any more ampersands in line?			*/
	     CL_pos = CL_pos + break;
	     go to EXPAND_LOOP;
	end;

COPY_REST:
	if not_in_CL
	then do;					/* Copy rest of line if any expansions			*/
	     copy_len = CL_len - old_CL_pos;
	     call check_len (copy_len);
	     substr (RS, RS_len - copy_len + 1, copy_len) = substr (CL, old_CL_pos + 1, copy_len);
	end;
	else do;					/* Use unexpanded string, we may not need to copy it	*/
	     RS_len = CL_len;
	     RS_ptr = CL_ptr;
	end;
%page;
/* We come here to identify the current request line as a statement, command, or expansion to be returned.
   We can get here by falling through from expansion, or to identify an &then or &else clause.			*/

CHECK_CONTROL:
	if substr (RS, 1, min (1, RS_len)) = "&"
	then do;					/* If first char is ampersand, hash on second char	*/
	     on sub_request_abort_ go to ABORT;
	     call bce_check_abort;			/* allow to break out of possible loop in exec_com land */
	     revert sub_request_abort_;
	     break = index ("acdegilpqrtv", substr (RS, 2, 1));
	     if break = 0 then go to COMMENT_LINE;
	     len = search (substr (RS, 3), WHITE);	/* Get length of possible keyword			*/
	     do control = LOW (break) to HIGH (break);
		if KEYWORD (control) = substr (RS, 2, len)
		then do;				/* Got a match! so just space RS_pos over it		*/
		     RS_pos = verify (substr (RS, len + 3), WHITE) + len + 1;
		     if RS_pos = len + 1 then RS_pos = RS_len;
		     go to STATE (state);		/* And we're off to an action routine (of some sort)	*/
		end;
	     end;

	     if len > 4
	     then if break = 4
		then if substr (RS, 2, 4) = "else"
		     then call warning (0,
			     "Whitespace must follow the ""&else"" keyword or the line is a comment.");
		     else ;
		else if break = 11
		then if substr (RS, 2, 4) = "then"
		     then call warning (0,
			     "Whitespace must follow the ""&then"" keyword or the line is a comment.");

COMMENT_LINE:
	     control = COMMENT;			/* We have a leading ampersand but no keyword. Ignore it	*/
	end;
	else control = DATA;			/* No ampersand so this line can be returned to user	*/

	go to STATE (state);			/* Off to the wars (someone will handle this line)	*/

STATE (0):					/* NORMAL:  we come here if not in search or conditional	*/
	if TRACE (control) then call trace_output (abs_data.control_line, RS);

	go to CONTROL (control);			/* This is where we really head off to the action routine	*/
%page;
CONTINUE_LONG_RECORD:
	buffer_allocated = "1"b;			/* Tell exit routine to take data out of buffer		*/
	CL_len = 0;				/* Don't skip over statement since we did no expansion	*/
	scanning_clause = "0"b;			/* Init this for tastefulness sake			*/
	not_in_CL = "1"b;				/* Not from input segment				*/
	RS_len = abs_data.chars_len;			/* set RS to pending string				*/
	RS_ptr = abs_data.chars_ptr;

CONTROL (-1):					/* DATA = data to return to caller			*/
	if not_in_CL & ^buffer_allocated & ^scanning_clause
	then P_actual_len = RS_len;			/* All done since all data is already in caller's buffer	*/
	else do;					/* Otherwise copy as much as will fit			*/
	     P_actual_len = min (P_buffer_len, RS_len);
	     P_buffer = RS_ptr -> P_buffer;		/* If it doesn't all fit, stash the rest for later calls	*/
	     if P_actual_len < RS_len
	     then if not_in_CL
		then do;				/* We have an allocated buffer, and characters in it	*/
		     abs_data.chars_ptr = addr (substr (RS, P_actual_len + 1));
		     abs_data.chars_len = RS_len - P_actual_len;
		end;
		else do;				/* this means no pending &else clause or full buffer	*/
		     RS_ptr = addr (substr (RS, P_actual_len + 1));
		     abs_data.chars_len, RS_len = RS_len - P_actual_len;
		     call allocate_buffer (RS_len);
		     abs_data.chars_ptr = RS_ptr;
		end;
	     else abs_data.chars_len = 0;
	end;

	input_string.position = input_string.position + CL_len;
						/* Step over statement so we will get next one later	*/

	if input_linep ()
	then call trace_output (abs_data.input_line, P_buffer);
	else call trace_output (abs_data.command_line, P_buffer);

	if abs_data.chars_len > 0
	then P_status = error_table_$long_record;	/* Pending chars exist so tell caller			*/
	else P_status = 0;

EGRESS:
	abs_data.active = "0"b;
	return;
%page;
NO_NEW_LINE:
	if state = SEARCHING_FOR_LABEL then go to STATE (SEARCHING_FOR_LABEL);
						/* &goto should field this				*/

	if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec				*/

	call warning (0, "The last line did not end in a newline and was ignored.");

END_OF_FILE:
	if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited his ec.				*/

	if state = MUST_BE_THEN
	then call error (0, "The end of file was encountered when a ""&then"" statement was expected.");

ABORT:	abs_data.eof = "1"b;			/* Make sure that end of file is remembered		*/

	if ^input_reset_sw
	then do;					/* Mustn't leave &attach in effect			*/
	     input_reset_sw = "1"b;

	     call reset_input ();
	end;

	P_actual_len = 0;				/* Tell user what happened and how much data he got	*/
	P_status = error_table_$end_of_info;

	go to EGRESS;				/* Only one exit allowed for cleanup purposes		*/
%page;
/* The following small serving of spaghetti is used to implement &goto and &label.  Labels are kept in chained buckets
   in a small hash table.  Buckets are allocated the first time a label is seen, whether it it in a &label or a &goto.
   There is no limit on the length of labels and the characters in a label, except that leading and trailing whitespace
   are removed from them.  The blank label is allowed.  Label search is defined to find the first instance of a label
   starting from the top of the file, so duplicate instances of the same label are ignored.  The hashed label scheme is
   a large performance improvement in big exec_coms.							*/

CONTROL (7):					/* &goto						*/
	abs_data.nest_level = 0;			/* reset nest state, so parser doesn't think we are	*/
	abs_data.else_clause_len = 0;			/* still in if statement or have else clause pending.	*/
	get_next_line = EXPAND_NEXT_LINE;		/* also set scanner back to normal			*/

	input_string.limit = max (input_string.limit, input_string.position + CL_len);
						/* save farthest point in case backward branch		*/
	go to GET_CURRENT_LABEL;			/* now go parse statement				*/

CONTROL (10):					/* &label						*/
	if scanning_clause then call error (0, "A label may not follow ""&then"" or ""&else"".");

	if input_string.limit > input_string.position then go to get_next_line;
						/* Have we seen this label already?			*/

GET_CURRENT_LABEL:
	current_label_ptr = addr (substr (RS, RS_pos + 1));
	current_label_len = length (rtrim (substr (RS, RS_pos + 1), WHITE));
	hash =
	     mod (binary (unspec (char (substr (current_label, 1, min (2, current_label_len)), 2)), 18)
	     + current_label_len, 61);

	if hash = saved_hash			/* cheap test -- saved_hash = -1 if not looking		*/
	then if current_label = saved_label_ptr -> label.name
	     then do;
		saved_hash = -1;			/* reset saved_hash to illegal value for test		*/
		if state = MUST_BE_LABEL
		then do;				/* Label found in hash table has been verified		*/
		     state = NORMAL;
		     go to get_next_line;
		end;
		state = NORMAL;			/* reset from SEARCHING_FOR_LABEL			*/
		label_ptr = saved_label_ptr;		/* so saved block will be threaded properly		*/
		go to THREAD_IN_LABEL;
	     end;

	if state = MUST_BE_LABEL then go to UNSTUCK_LABEL;/* User has edited the input file.			*/

	if abs_data.labels_ptr = null () then call allocate_hash_table ();

	do label_ptr = abs_data.labels_ptr -> hash_table (hash) repeat (label.next_ptr) while (label_ptr ^= null ());
	     if current_label = label.name		/* if match then three possible actions			*/
	     then if control = LABEL			/* for label we just go to next line, which in		*/
		then if state = NORMAL		/* search mode calls for special action to		*/
		     then go to get_next_line;	/* only scan control lines for efficiency		*/
		     else go to GET_NEXT_LABEL_LINE;
		else do;
		     saved_hash = hash;
		     saved_label_ptr = label_ptr;
		     old_IS_pos = input_string.position;
		     input_string.position = label.statement_pos;
		     if input_string.position > 0
		     then if substr (IS, input_string.position, 1) ^= NL then go to UNSTUCK_LABEL;
		     state = MUST_BE_LABEL;
		     CL_len = 0;
		     go to get_next_line;
		end;
	end;

	on area call error (error_table_$noalloc, "Allocating label ""^a"".", current_label);

	allocate label in (abs_data_work_area);		/* we need a new label cell since we now know this label	*/
						/* has never been seen before.  length is arbitrary	*/
	revert area;

	if control = GOTO
	then do;
	     saved_hash = hash;			/* we do this for cheap compare above			*/
	     saved_label_ptr = label_ptr;		/* we will need this later for compare and threading in	*/
	     old_IS_pos = input_string.position;	/* this is for line number in error message		*/
	     state = SEARCHING_FOR_LABEL;		/* set state to ignore everything but labels		*/
	     input_string.position = input_string.limit - CL_len;
	     go to GET_NEXT_LABEL_LINE;		/* start search beyond what we've already seen		*/
	end;

THREAD_IN_LABEL:
	label.statement_pos = input_string.position;	/* set label to beginning of its line			*/
	label.next_ptr = abs_data.labels_ptr -> hash_table (hash);
	abs_data.labels_ptr -> hash_table (hash) = label_ptr;

	if state = NORMAL then go to get_next_line;	/* We are done unless still skipping			*/

GET_NEXT_LABEL_LINE:
	input_string.position = input_string.position + CL_len;
	CL_len = index (substr (IS, input_string.position), NL_THEN_AMP) - 1;
						/* search for next control string			*/
	if CL_len >= 0 then go to get_next_line;	/* Found something; check it out			*/

	input_string.position = old_IS_pos;		/* Restore position for error message.			*/
	call error (0, "Label ""^a"" not found.", saved_label_ptr -> label.name);

STATE (1):					/* SEARCHING_FOR_LABEL				*/
	if control = LABEL
	then go to GET_CURRENT_LABEL;			/* in this state we ignore everything but &label lines	*/
	else go to GET_NEXT_LABEL_LINE;		/* since efficient label search is critical		*/

STATE (2):					/* MUST_BE_LABEL					*/
	if control = LABEL then go to GET_CURRENT_LABEL;

UNSTUCK_LABEL:
	input_string.position = old_IS_pos;
	state = NORMAL;
	call error (0, "Label ""^a"" is unstuck.  Active programs may not be edited.", saved_label_ptr -> label.name);
%page;
CONTROL (0):					/* COMMENT LINE					*/
	if scanning_clause then call error (0, "A comment may not follow ""&then"" or ""&else"".");

	call trace_output (abs_data.comment_line, CL);

	go to get_next_line;

CONTROL (11):					/* &print						*/
	call ioa_$nnl (substr (RS, min (RS_pos + 1, RS_len)));
	go to get_next_line;

CONTROL (12):					/* &quit						*/
	if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&quit"".");

	go to END_OF_FILE;

CONTROL (15):					/* &return					*/
	if RS_pos = RS_len then RS_pos = RS_pos - 1;	/* Newline at end of null return string is not white space	*/

	RS_ptr = addr (substr (RS, RS_pos + 1));	/* Adjust RS to only be argument of statement		*/
	RS_len = RS_len - RS_pos;

	if functionp ()
	then do;
	     RS_len = RS_len - 1;			/* Don't return newline at end for active function	*/
	     if RS_len > ec_data.return_len
	     then call warning (error_table_$command_line_overflow,
		     "Expanded value length of ^d characters exceeds return argument length of ^d characters.",
		     RS_len, ec_data.return_len);
	     return_arg = RS;
	end;
	else call bce_data$put_chars (addr (bce_data$put_chars), addr (RS), length (RS), status);

	go to END_OF_FILE;

CONTROL (17):
	call error (0, "The ""&version"" statement may only be the first line of the program.");
%page;
CONTROL (1):					/* &attach					*/
	if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&attach"".");

	if ec_data_ptr ^= null () & ^attachedp ()
	then do;
	     bce_data$command_abs_data_ptr -> abs_data.save_ptr = bce_data$get_line_data_ptr;
	     bce_data$command_abs_data_ptr -> abs_data.victim_ptr = codeptr (bce_data$get_line);  
	     bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr;
	     bce_data$get_line = bce_exec_com_input;
	end;

	go to get_next_line;

CONTROL (5):					/* &detach					*/
	if RS_pos ^= RS_len then call warning (0, "No arguments are required by ""&detach"".");

	input_string.position = input_string.position + CL_len;
						/* Adjust position in case call to reset_input fails	*/
	CL_len = 0;				/* Make sure that it isn't adjusted twice if it doesn't	*/

	call reset_input ();			/* Do &detach, call get_line for saved switch if input line */

	go to get_next_line;

reset_input:
     procedure ();

	if attachedp ()
	then do;
	     bce_get_line_entry.env = null ();
	     bce_get_line_entry.proc = bce_data$command_abs_data_ptr -> abs_data.victim_ptr;
	     bce_data$get_line_data_ptr = bce_data$command_abs_data_ptr -> abs_data.save_ptr;
	     if input_linep () then do;
		call bce_data$get_line (addr (bce_data$get_line), P_buffer_ptr, P_buffer_len, P_actual_len, P_status);
		go to EGRESS;
	     end;
	end;
	return;
     end;
%page;
CONTROL (13):					/* &ready						*/
	string (ready_mode) = ""b;
	ready_mode.flag = trace_mode ();		/* don't do anything, though */

	go to get_next_line;

CONTROL (14):					/* &ready_proc					*/
	test = trace_mode ();
	if ec_data_ptr ^= null () then ec_data.call_ready_proc = test;
	go to get_next_line;

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

	if RS_len = RS_pos
	then do;
	     call warning (0, "Missing keyword in mode statement.  ""on"" assumed.");
	     return ("1"b);
	end;

	RS_len = length (rtrim (RS, WHITE));

	if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then return ("1"b);
	if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then return ("0"b);
	call warning (0, "Illegal keyword in mode statement.  ""on"" assumed.");

	return ("1"b);
     end;
%page;
CONTROL (2):					/* &command_line					*/
	call trace_control (abs_data.command_line);
	go to get_next_line;

CONTROL (3):					/* &comment_line					*/
	call trace_control (abs_data.comment_line);
	go to get_next_line;

CONTROL (4):					/* &control_line					*/
	call trace_control (abs_data.control_line);
	go to get_next_line;

CONTROL (9):					/* &input_line					*/
	call trace_control (abs_data.input_line);
	go to get_next_line;

trace_control:
     procedure (trace_structure);

declare  1 trace_structure		  aligned like abs_data.command_line;

	if RS_len = RS_pos
	then do;
	     call warning (0, "Missing keyword in tracing statement.  ""on"" assumed.");
	     trace_structure.on = "1"b;
	     return;
	end;

	len = search (substr (RS, RS_pos + 2), WHITE);	/* Find end of keyword				*/
	RS_len = length (rtrim (RS, WHITE));		/* Find end of tokens on line				*/

	if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then trace_structure.on = "1"b;
	else if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then trace_structure.on = "0"b;
	else do;
	     call warning (0, "Invalid keyword in tracing statement.  ""on"" assumed.");
	     trace_structure.on = "1"b;
	end;

	return;

     end trace_control;
%page;
trace_output:
     procedure (trace_structure, line);

declare  1 trace_structure		  aligned like abs_data.command_line,
         line			  char (*);


	do while (trace_structure.on);		/* Do this only if tracing is enabled.			*/
	     call bce_data$put_chars (addr (bce_data$put_chars), addr (line), length (line), status);
	     if status = 0 then return;		/* Exit if line successfully traced			*/

	     call com_err_ (status, "bce_exec_com_", "Unable to do trace output.");
	     signal request_abort_;
	end;

	return;

     end trace_output;
%page;
CONTROL (8):					/* &if						*/
	start = find_clause ("&then");

	if RS_len = RS_pos | start = RS_pos then call error (0, "Missing conditional in ""&if"" statement.");

	if start >= 0
	then do;
	     old_RS_len = RS_len;			/* Save for locating &then clause			*/
	     RS_len = start;			/* Delay assignment for benefit of error message routine.	*/
	end;

	RS_len = length (rtrim (RS, WHITE));

	abs_data.nest_level = abs_data.nest_level + 1;

	if state = NORMAL
	then do;
	     call trace_output (abs_data.control_line, RS);
	     call trace_output (abs_data.control_line, NL);
	     abs_data.expected_nest_level = abs_data.nest_level;
	     if ^conditional () then state = SKIPPING_CLAUSE;
	end;

	if start < 0
	then do;
	     saved_state = state;
	     state = MUST_BE_THEN;
	     go to EXPAND_NEXT_LINE;			/* Go direct, don't mess around. This state is indivisible	*/
	end;

	RS_ptr = addr (substr (RS, start + 1));
	RS_len = old_RS_len - start;

	RS_pos = verify (substr (RS, 6), WHITE) + 4;	/* Find beginning of clause beyond "&then"		*/
	if RS_pos = 4 then RS_pos = RS_len;
%page;
CONTINUE_THEN:
	if abs_data.else_clause_len <= 0
	then do;					/* maybe we even have the &else			*/
	     start = find_clause ("&else");
	     if start >= 0
	     then do;				/* We do. Copy the whole line into an allocated buffer	*/
		if ^not_in_CL | ^buffer_allocated then call allocate_buffer (RS_len);
		abs_data.else_clause_len = RS_len - start;
		abs_data.else_clause_ptr = addr (substr (RS, start + 1));
		RS_len = length (rtrim (substr (RS, 1, start), WHITE)) + 1;
		substr (RS, RS_len, 1) = NL;		/* Break the line.  We'll get rest of the line next time	*/
		get_next_line = GET_PENDING_ELSE_CLAUSE;
	     end;
	end;

	if RS_pos >= RS_len then RS_pos = RS_len - 1;	/* Newline at end of null line is not white space		*/

	RS_ptr = addr (substr (RS, RS_pos + 1));	/* Step over &then or &else and following whitespace	*/
	RS_len = RS_len - RS_pos;

	if state = NORMAL
	then do;					/* This clause will be executed.  First, we trace ourself.	*/
	     if control = THEN
	     then call trace_output (abs_data.control_line, TRACE_THEN);
	     else call trace_output (abs_data.control_line, TRACE_ELSE);

	     abs_data.expected_nest_level = 0;		/* After taking this clause we skip until back at top level */

	     if abs_data.else_clause_len = 0 & abs_data.nest_level > 0
	     then get_next_line = ENTER_SKIPPING_CLAUSE_STATE;
	end;					/* Arrange to set state to skipping after taking clause	*/

	scanning_clause = "1"b;			/* Comments and labels are forbidden in clauses		*/

	go to CHECK_CONTROL;			/* Prepare to execute clause				*/

STATE (3):					/* MUST_BE_THEN					*/
	if control = COMMENT then go to get_next_line;	/* comments are allowed between &if and &else statements	*/

	if control ^= THEN then call error (0, "Missing ""&then"" keyword following ""&if"" statement.");

	state = saved_state;			/* pop state saved in &if (NORMAL or SKIPPING_CLAUSE)	*/

	go to CONTINUE_THEN;

CONTROL (16):					/* &then:  this can't be reached by a legitimate clause	*/
	call error (0, "Unexpected ""&then"" statement.");
%page;
CONTINUE_WITH_PENDING_ELSE_CLAUSE:
	buffer_allocated = "1"b;			/* We have just reentered, so initialize--this must be	*/
	CL_len = 0;				/* We haven't done any expansion this time, so don't skip	*/
	not_in_CL = "1"b;				/* in an allocated buffer, not in the input file		*/

GET_PENDING_ELSE_CLAUSE:
	RS_len = abs_data.else_clause_len;		/* Set RS to pending &else clause in allocated buffer	*/
	RS_ptr = abs_data.else_clause_ptr;
	abs_data.else_clause_len = 0;			/* Unmark pending &else clause storage			*/

	RS_pos = verify (substr (RS, 6), WHITE) + 4;	/* Set RS_pos as if we came from CHECK_CONTROL		*/
	if RS_pos = 4 then RS_pos = RS_len;		/* Locate it at first non-white char or at end of line	*/

	get_next_line = EXPAND_NEXT_LINE;		/* Reset this since we don't want to come back here	*/

	control = ELSE;				/* This is the only kind of statement that is ever pending	*/

CONTROL (6):					/* &else						*/
	if abs_data.nest_level <= 0 then call error (0, "Unexpected ""&else"" statement.");

	abs_data.nest_level = abs_data.nest_level - 1;	/* Implement nesting here				*/
	if abs_data.nest_level < abs_data.expected_nest_level
	then state = NORMAL;
	else state = SKIPPING_CLAUSE;

	go to CONTINUE_THEN;

STATE (4):					/* SKIPPING_CLAUSE					*/
	if ^scanning_clause
	then if control = ELSE | control = COMMENT
	     then go to CONTROL (control);		/* &else or comments are part of nested compound statement	*/
	     else do;				/* anything else ends compound statement		*/
		scanning_clause = "0"b;		/* comments and &labels are legal again			*/
		state = NORMAL;			/* nested statement must end here			*/
		abs_data.nest_level = 0;		/* so reset back to top level				*/
		go to STATE (NORMAL);
	     end;

	if SKIPABLE (control)
	then go to get_next_line;
	else go to CONTROL (control);

ENTER_SKIPPING_CLAUSE_STATE:
	state = SKIPPING_CLAUSE;			/* We have taken a clause, so we skip rest of if statement	*/

	get_next_line = EXPAND_NEXT_LINE;		/* Reset this, we don't need to come here again		*/

	go to EXPAND_NEXT_LINE;
%page;
/* This function is called from &if to find &then and from &then or &else to find an &else which follows on the same
   line.  The contract of the function is to return the length of the string preceding the keyword, which must be
   delimited on BOTH sides by whitespace.  If it is followed by a newline, that is considered whitespace.  If the
   clause is not found, the -1 is returned.								*/

find_clause:
     procedure (keyword) returns (fixed bin (21));

declare  keyword			  char (*),
         keyword_pos		  fixed bin (21),
         start_keyword		  fixed bin (21);

	keyword_pos = RS_pos;			/* start with first unidentified character		*/

	start_keyword = index (substr (RS, RS_pos + 1), keyword) - 1;

	if start_keyword < 0 then return (-1);

	keyword_pos = RS_pos + start_keyword;

	if index (WHITE, substr (RS, keyword_pos + length (keyword) + 1, 1)) - 1 < 0
	     | index (WHITE, substr (RS, keyword_pos, 1)) - 1 < 0
	then call warning (0, "Whitespace must surround the ""^a"" keyword.", keyword);

	return (keyword_pos);

     end find_clause;
%page;

/* This procedure implements knowledge of the syntax of &if conditionals (except for detection of missing conditionals,
   which is done in &if).  The forms accepted are "true", "false", "[...]", "|[...]", and "||[...]".  The forms
   containing brackets are evaluated by calling command_processor_$subsys_eval_string with the string contained between them.  A
   zero error code must be returned, and the returned value must be either "true" or "false".			*/

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

declare  AF_len			  fixed bin (21),
         AF_ptr			  ptr,
         AF			  char (AF_len) based (AF_ptr),
         bars_len			  fixed bin,
         value			  char (8) varying;

	if substr (RS, RS_pos + 1) = "true" then return ("1"b);

	if substr (RS, RS_pos + 1) = "false" then return ("0"b);

	if substr (RS, RS_pos + 1, 1) = "|"
	then if substr (RS, RS_pos + 2, 1) = "|"
	     then bars_len = 2;
	     else bars_len = 1;
	else bars_len = 0;

	if substr (RS, RS_pos + bars_len + 1, 1) ^= "[" | substr (RS, RS_len) ^= "]"
	then call error (0, "Malformed conditional in ""&if"" statement.");

	AF_ptr = addr (substr (RS, RS_pos + bars_len + 2));
	AF_len = RS_len - RS_pos - bars_len - 2;	/* do not pass brackets surrounding if expression		*/

	on request_abort_ call error (0, "request_abort_ signalled while evaluating ""&if"" clause.");
	call command_processor_$subsys_eval_string ("bce", bce_data$subsys_info_ptr, bce_execute_command_, null (), AF, (bars_len + 1), value, status);
	revert request_abort_;

	if status ^= 0 then call error (status, "Evaluating ""&if"" clause.");

	if value = "true" then return ("1"b);

	if value = "false" then return ("0"b);

	call error (0, "Illegal value ""^a"" returned by active function.", value);

     end conditional;
%page;
/* This utility predicate knows how to determine if some switch is &attached. */

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

	return (bce_data$command_abs_data_ptr = bce_data$get_line_data_ptr);

     end attachedp;

/* This utility predicate knows how to determine if the current line is an input line				*/

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

	if ec_data_ptr = null () then return ("0"b);	/* Can't be input unless someone tells us so		*/

	return (ec_data.input_line);

     end input_linep;

/* This utility predicate knows how to tell if we were invoked as an active function				*/

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

	if ec_data_ptr = null ()
	then return ("0"b);				/* Can't return a value if we don't have a place to put it	*/
	else return (ec_data.active_function);

     end functionp;
%page;
emit_ec_name:
     procedure ();					/* &ec_name:  The entryname of the input file, sans suffix	*/

	call copy_up_to_ampersand (7);
	call copy_string (ec_name, QUOTE);

     end emit_ec_name;
%page;
emit_arg_count:
     procedure ();

declare  arg_count_pic		  picture "zzzzzzzz9",
         arg_count_len		  fixed bin,
         arg_count			  char (arg_count_len) based (addr (substr (arg_count_pic, 10 - arg_count_len)));

	call copy_up_to_ampersand (1);
	arg_count_pic = abs_data.arg_count;
	arg_count_len = length (ltrim (arg_count_pic));
	call copy_string (arg_count, NONE);

     end emit_arg_count;

predicate:
     procedure (test, width);

declare  test			  bit (1) aligned,
         width			  fixed bin;

	call copy_up_to_ampersand (width);
	if test
	then call copy_string (TRUE, NONE);
	else call copy_string (FALSE, NONE);

	return;

     end predicate;

copy_up_to_ampersand:
     procedure (width);

declare  width			  fixed bin;

	len = CL_pos - old_CL_pos;
	if len > 0
	then do;
	     call check_len (len);
	     substr (RS, RS_len - len + 1, len) = substr (CL, old_CL_pos + 1, len);
	end;

	CL_pos = CL_pos + width;
	old_CL_pos = CL_pos + 1;

	not_in_CL = "1"b;				/* Make sure that we know some expansion was encountered	*/

	return;

     end copy_up_to_ampersand;
%page;
copy_string:
     procedure (arg_string, quote_modifier);

declare  arg_string			  char (*),
         quote_modifier		  fixed bin;

declare  (arg_pos, quote_pos, quote_len)
				  fixed bin (21);

	if quote_modifier = NONE
	then do;
	     call check_len (length (arg_string));
	     substr (RS, RS_len - length (arg_string) + 1) = arg_string;
	     return;
	end;

	arg_pos = 0;

QLOOP:
	quote_len = index (substr (RS, old_RS_len + 1), """") - 1;
	if quote_len >= 0
	then do;
	     old_RS_len = old_RS_len + quote_len;
	     quote_len = verify (substr (RS, old_RS_len + 1), """") - 1;
	     if quote_len < 0 then quote_len = RS_len - old_RS_len;
	     old_RS_len = old_RS_len + quote_len;
	     if mod (quote_len, twoL) = 0
	     then do while (mod (quote_len, 2 * twoL) ^= 0);
		quote_len = quote_len - twoL;
		twoL = 2 * twoL;
	     end;
	     else do while (quote_len ^= 0);
		twoL = divide (twoL, 2, 17, 0);
		quote_len = mod (quote_len, twoL);
	     end;
	     go to QLOOP;
	end;
	else old_RS_len = RS_len;

	if quote_modifier = REQUOTE
	then do;					/* insert quotes if requoting				*/
	     call check_len (twoL);
	     substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL);
	     twoL = 2 * twoL;			/* increase quote depth by one			*/
	end;

DBL_LOOP:
	quote_pos = index (substr (arg_string, arg_pos + 1), """") - 1;
	if quote_pos >= 0
	then do;
	     call check_len (quote_pos);
	     substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos);
	     arg_pos = arg_pos + quote_pos + 1;
	     call check_len (twoL);
	     substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL);
	     if arg_pos < length (arg_string)
	     then go to DBL_LOOP;
	     else go to APPEND;
	end;

	quote_pos = length (arg_string) - arg_pos;
	if quote_pos > 0
	then do;					/* something after last quote in arg			*/
	     call check_len (quote_pos);
	     substr (RS, RS_len - quote_pos + 1, quote_pos) = substr (arg_string, arg_pos + 1, quote_pos);
	end;

APPEND:
	if quote_modifier = REQUOTE
	then do;					/* append quotes if requoting				*/
	     twoL = divide (twoL, 2, 17, 0);
	     call check_len (twoL);
	     substr (RS, RS_len - twoL + 1, twoL) = copy ("""", twoL);
	end;
	old_RS_len = RS_len;

	return;

     end copy_string;
%page;
check_len:
     proc (len);					/* routine to make sure we don't overflow input buffer	*/

declare  len			  fixed bin (21),
         new_RS_len			  fixed bin (21);

	new_RS_len = RS_len + len;

	if new_RS_len > buffer_len then call allocate_buffer (new_RS_len);

	RS_len = new_RS_len;

	return;

     end check_len;

allocate_buffer:
     procedure (required_len);

declare  required_len		  fixed bin (21);

	not_in_CL = "1"b;				/* RS will not be eq to CL after this			*/
	buffer_allocated = "1"b;

	if required_len <= abs_data.allocated_chars_len
	then do;					/* Reuse allocated buffer if possible			*/
	     abs_data.allocated_chars_ptr -> RS = RS;
	     buffer_ptr, RS_ptr = abs_data.allocated_chars_ptr;
	     return;
	end;
	else call error (0, "Expanded line exceeds implementation restriction of ^d characters in length.", abs_data.allocated_chars_len);
	return;

     end allocate_buffer;
%page;
allocate_hash_table:
     procedure ();

	on area call error (error_table_$noalloc, "Allocating label hash table.");

	allocate hash_table set (abs_data.labels_ptr) in (abs_data_work_area);

	revert area;

     end allocate_hash_table;
%page;
error:
     procedure () options (variable);

declare  complain			  entry () variable options (variable),
         line_len			  fixed bin (21),
         line_number		  fixed bin (21),
         line_ptr			  ptr,
         line_start			  fixed bin (21),
         line			  char (line_len) based (line_ptr),
         message			  char (256),
         severity			  bit (1),
         status_ptr			  ptr,
         status			  fixed bin (25) based (status_ptr),
         who			  char (72) varying;

	severity = "1"b;
	go to ERROR_COMMON;

warning:
     entry options (variable);

	severity = "0"b;

ERROR_COMMON:
	call cu_$arg_ptr (1, status_ptr, (0), (0));
	call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, message, (0), "1"b, "0"b);

	line_number = 0;
	do line_start = 0 repeat (line_start + line_len + 1)
	     while ((line_start <= input_string.position) & (line_start < input_string.len));

	     line_len = index (substr (IS, line_start + 1), NL) - 1;
	     if line_len < 0 then line_len = input_string.len - line_start;
	     line_number = line_number + 1;
	     line_ptr = addr (substr (IS, line_start + 1));
	end;

	if ec_data.active_function
	     then complain = active_fnc_err_;
	else complain = com_err_;
	who = ec_data.who_am_i;

	call complain (status, who, "^[^/^]^[Error^;Warning^] on line #^d of ^a:^/^a^/SOURCE:^-^a", status ^= 0,
	     severity, line_number, ec_name, message, line);

	if ^severity then return;

	state = NORMAL;				/* Prevent looping if state is a MUST_BE state.		*/

	go to END_OF_FILE;

     end error;
     end bce_exec_com_input;






		    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
