



		    get_seg_ptr_.pl1                11/05/86  1509.8r w 11/04/86  1042.7       85095



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


/*	This procedure was initially coded by Richard H. Gumpertz on 1/7/71
   Procedure last modified:
   04/10/71 at 1536 by RHG to rename get_seg_ptr_$** to get_seg_ptr_**
   to use the already installed copy of stack_frame.incl.pl1
   03/31/71 at 1428 by RHG to add entry point get_seg_ptr_arg_
   03/24/71 at 1758 by RHG to clear return_code in $search
   03/24/71 at 1714 by RHG to make things a bit neater
   03/22/71 at 0357 by RHG to rename open_seg_ to get_seg_ptr_
   to combine get_seg_ptr_ and release_seg_ptr_
   to add the entry point $search
   to change wanted_access from fixed bin(5) to bit(6) aligned
   01/20/71 at 1820 by RHG to supress hcs_$initiate_count errors such as "segknown"
   01/18/71 at 1104 by RHG to reformat the source
   01/17/71 at 1951 by RHG to speed up open_seg_$path
   01/17/71 at 1251 by RHG for initial implementation
   11/14/73 by Kobziar to not check append access
   11/30/77  by David Levin to zero unused part of last word.
   */
/*	This procedure opens a segment for reading or writing, returning a pointer and a bit_count.
   If the segment does not exist and "create" access was specified in the call then an attempt is
   made to create the segment. A non-null pointer is returned if the segment is initiated.
   An error code will be returned in return_code if the access to the
   segment is not at least that specified in wanted_access. Otherwise any error return will have
   the return_ptr null.

   The entry point get_seg_ptr_arg_ is identical to the main entry except that
   the pathname is fetched out of the caller's argument list.

   The entry point get_seg_ptr_full_path_ is identical to the main entry except that
   a directory name and an entry name are taken rather than a relative path name.

   The entry point get_seg_ptr_search_ initiates the segment via search rules but
   initiates the segment with a null reference name. If it creates a segment
   it creates it in the process directory.

   The entry point release_seg_ptr_ terminates a segment. It also truncates
   the segment and sets its bit count if a nonnegative bit count is given.
   */
/*  */
get_seg_ptr_: procedure (path_name, wanted_access, bit_count, return_ptr, return_code);
	call expand_pathname_ (path_name, directory_name, entry_name, error_code);
	if error_code ^= 0 then goto error_return;
	goto common;

get_seg_ptr_arg_: entry (arg_number, wanted_access, bit_count, return_ptr, return_code);
	call cu_$arg_ptr_rel (arg_number, temp_ptr, len, error_code,
	     cu_$stack_frame_ptr () -> prev_sp -> arg_ptr);
	if error_code ^= 0 then goto error_return;
	call expand_pathname_ (path_name_arg, directory_name, entry_name, error_code);
	if error_code ^= 0 then goto error_return;
	goto common;

get_seg_ptr_full_path_: entry (d_name, e_name, wanted_access, bit_count, return_ptr, return_code);
	directory_name = d_name;
	entry_name = e_name;
	goto common;

get_seg_ptr_search_: entry (ref_name, wanted_access, bit_count, return_ptr, return_code);
	call hcs_$fs_get_seg_ptr (ref_name, temp_ptr, error_code);
	if temp_ptr ^= null then			/* temp_ptr = null if seg not known	*/
	     do;
	     call hcs_$fs_get_path_name (temp_ptr, directory_name, len, entry_name, error_code);
						/* get the path name of the segment	*/
	     if error_code ^= 0 then goto error_return;
	     goto common;
	end;
	call hcs_$make_ptr (null_string, ref_name, null_string, temp_ptr, error_code);
						/* search for the segment	*/
	if temp_ptr = null then			/* temp_ptr = null if seg doesn't exist	*/
	     do;
	     if substr (wanted_access, 6, 1) = "0"b then goto error_return;
						/* return if "create" bit not on	*/
	     directory_name = get_pdir_ ();		/* else create the segment in the process dir	*/
	     entry_name = ref_name;
	     return_code = 0;
	     goto create;
	end;
	call hcs_$fs_get_path_name (temp_ptr, directory_name, len, entry_name, error_code);
						/* get the path name of the seg	*/
	if error_code ^= 0 then goto error_return;
	call hcs_$terminate_name (ref_name, error_code);	/* terminate the name we just made known	*/
	if error_code ^= 0 then goto error_return;
	goto common;

release_seg_ptr_: entry (seg_ptr, bit_count, return_code);
	return_code = 0;
	goto release;
						/*  */
dcl  path_name char (*),
     path_name_arg char (len) based (temp_ptr),
     arg_number fixed bin,
     ref_name char (*),
     d_name char (*),
     e_name char (*),
     seg_ptr ptr,
     wanted_access bit (6) aligned,
     bit_count fixed bin (24),
     word_count fixed bin (24),
     word_mask (0:3) bit (36) aligned int static options (constant)
     init ("777777777777"b3, "777000000000"b3, "777777000000"b3, "777777777000"b3),
     segment (262144) bit (36) aligned based,
     return_ptr ptr,
     return_code fixed bin (35);

dcl (addr,
     divide,
     fixed,
     length,
     mod,
     null,
     substr) builtin;

dcl (error_table_$moderr,
     error_table_$noentry) fixed bin (35) external;

dcl  expand_pathname_ external entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
     cu_$stack_frame_ptr external entry () returns (ptr),
     cu_$arg_ptr_rel external entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr),
     get_pdir_ external entry () returns (char (168) aligned),
     hcs_$status_ external entry (char (*) aligned, char (*) aligned, fixed bin, ptr, ptr, fixed bin (35)),
     hcs_$initiate_count external entry (char (*) aligned, char (*) aligned, char (*) aligned,
     fixed bin (24), fixed bin, ptr, fixed bin (35)),
     hcs_$append_branch external entry (char (*) aligned, char (*) aligned, fixed bin (5), fixed bin (35)),
     hcs_$fs_get_path_name external entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35)),
     hcs_$fs_get_seg_ptr external entry (char (*), ptr, fixed bin (35)),
     hcs_$make_ptr external entry (char (*) aligned, char (*), char (*) aligned, ptr, fixed bin (35)),
     hcs_$terminate_name external entry (char (*), fixed bin (35)),
     hcs_$set_bc external entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (35)),
     hcs_$truncate_seg external entry (ptr, fixed bin (24), fixed bin (35)),
     hcs_$terminate_noname external entry (ptr, fixed bin (35));

%include	status_info_branch;
%include	stack_frame;

dcl  error_code fixed bin (35),
     directory_name char (168) aligned,
     entry_name char (32) aligned,
     temp_ptr ptr,
     len fixed bin;

dcl  null_string char (0) aligned internal static initial ("");
						/*  */
common:	return_code = 0;				/* initialize	*/

	call hcs_$status_ (directory_name, entry_name, 1, addr (status_info_branch), null, error_code);
						/* find out if the seg exists and the access we have to it	*/
	if error_code ^= 0 then goto create_seg;	/* if error, seg probably didn't exist	*/
	if substr (wanted_access, 1, 4) & ^mode then return_code = error_table_$moderr;
						/* make sure he has at least the access requested	*/

initiate_seg:
	call hcs_$initiate_count (directory_name, entry_name, null_string, bit_count, 1, return_ptr, error_code);
						/* initiate the segment with null reference name	*/
	if return_ptr = null then goto error_return;	/* check return_ptr not error_code to avoid "segknown" etc.	*/
	return;

create_seg:
	if error_code ^= error_table_$noentry then goto error_return;
						/* make sure the problem really was that seg didn't exist	*/
	if substr (wanted_access, 6, 1) = "0"b then goto error_return;
						/* don't create the seg unless "create" access specified	*/
create:	call hcs_$append_branch (directory_name, entry_name, fixed (substr (wanted_access, 1, 5), 5, 0), error_code);
						/* create the segment	*/
	if error_code = 0 then goto initiate_seg;	/* if OK then go initiate the segment	*/
						/* else we have an error	*/



error_return:					/* we get here if we have an error return	*/
	bit_count = 0;
	return_ptr = null;
error_return_2:
	return_code = error_code;
	return;
						/*  */
release:
	if bit_count >= 0 then			/* set length only if bit count non-negative	*/
set_length:    do;
						/* get the pathname so we can set bit count	*/
	     call hcs_$fs_get_path_name (seg_ptr, directory_name, len, entry_name, error_code);
	     if error_code ^= 0 then goto error_return_2;

/* set the bit count	*/
	     call hcs_$set_bc (directory_name, entry_name, bit_count, error_code);
	     if error_code ^= 0 then return_code = error_code;

/* truncate any unused pages */
	     word_count = divide (bit_count+35, 36, 24, 0);
	     call hcs_$truncate_seg (seg_ptr, word_count, error_code);
	     if error_code ^= 0 then return_code = error_code;
	     if mod (bit_count, 36) ^= 0 then
		seg_ptr -> segment (word_count) = seg_ptr -> segment (word_count)
		& word_mask (mod (divide (bit_count+8, 9, 24, 0), 4));

	end set_length;





	call hcs_$terminate_noname (seg_ptr, error_code); /* terminate the segment */
	if error_code ^= 0 then goto error_return_2;
						/*  */
     end get_seg_ptr_;




		    teco.pl1                        11/15/82  1907.0rew 11/15/82  1453.6      706824



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


/* format: style3,^indattr,linecom,^indnoniterdo,indnoniterend,indcomtxt,indend,indcom,dclind5,idind23 */
TECO:
teco:
     procedure;

	goto declarations;



/****	This program was written by:
      Richard H. Gumpertz
      4 Ames Street
      Cambridge, Mass. 02142

      It is modelled after the TECO in use on the Digital Equipment Corp. PDP-10
      which was originally written at the MIT Artificial Intelligence project.

      The syntax is as close to the PDP-10 syntax as the Multics environment will
      allow, with the one major exception being the file I/O commands.


      Dates modified and reasons:
      07/08/82 by G. Palter to call cu_$evaluate_active_string instead of command_processor_$af
      05/11/81 by C R Davis to fix bug in P command.
      11/30/77 by David S. Levin: fix bug in n-command.
      11/01/77 by David S. Levin: call command_processor_$af instead of command_processor_$return_val;
      and to print message if too many input args to teco.
      07/27/77 by Larry Johnson for teco$set_prompt entry
      07/30/76 by RGB: to add :J, :R, :C, :F<, F<, and F;
      07/29/76 by RGB: to add :< (errset), :;, :"M, and :M
      07/26/76 by RGB: to add "M command , :=  command, and :(backslash) command
      07/26/76 by RGB: to ignore tabs between commands, to remove 7000 labels
      07/24/76 by RGB: to add ea, to speed up, and to cleanup
      06/21/76 by MJG: add P "append" request like X.
      03/05/76 by DSL (& RGB): add teco$macro entry point;fix bug in -s;fix temp seg usage count for em.
      04/23/75 by DSL: fix introduced bugs; use index and search bifs to speed scanning.
      02/26/75 at 1238 by DSL: 1) add N-search; 2) use internal procedures; 3) bug fixes.
      02/07/75 at 1622 by DSL to: 1) fix ; skip over >, 2) any length seg, 3) fast reverse searching, 4) fast \.
      04/21/72 at 1900 by PBB to change teco_no_ES entry to just be another entry for teco that doesn't have
      the ES command implemented
      04/21/72 at 1800 by PBB to fix bug in ES command
      04/19/72 at 1300 by PBB to add ES command
      03/25/72 at 1400 by PBB to make S with two args use arg1 as a line limit for search and
      :' to skip to the next ' - this makes :' an else command
      03/25/72 at 1035 by PBB to make U with no args use 34359738367.
      03/25/72 at 1005 by PBB to fix bugs in \ and improve error messages
      03/24/72 at 1355 by PBB to fix bug in T command
      03/23/72 at 1710 by PBB to add better error messages and prevent % from incrementing a text register
      03/23/72 at 1230 by PBB to add backslash command
      03/23/72 at 1030 by PBB to fix bug in g command when converting numeric register and to
      implement :T command
      10/18/71 at 1245 by RHG to fix bug in restoring base_iteration_level in :X
      07/21/71 at 0016 by RHG to fix bug in EO caused by separation out of EO_X_common (7/18/71)
      07/18/71 at 1720 by RHG to use new get_temp_seg_ and to implement :X
      07/10/71 at 1704 by RHG to call get_temporary_segment_ and release_temporary_segment_
      to add more use of "hbound" builtin
      06/29/71 at 0332 by RHG to rename startup as start_up
      06/28/71 at 1434 by RHG to fix bug in EI//J, to allow command_buffer 100000 chars
      to put args in _r_e_a_l  Q-registers.
      06/28/71 at 0349 by RHG to fix bugs in EM, get_args, 0<..>
      06/28/71 at 0052 by RHG to add EM, optimization of EI/name/J, startup EM,
      to allow quoted string in Q-register
      to move scratch_segment out to a temp seg
      to allow "%" to work on Q-register containing text
      06/08/71 at 0145 by RHG to fix bugs in U, ?, and :
      06/07/71 at 2335 by RHG to handle pl1_bug about char(262144)
      to allow commands within parentheses
      to implement get_character_fail_handler
      to allow U to take multiple arguments
      02/18/71 at 1644 by RHG to fix the last fix to %
      02/18/71 at 1459 by RHG to implement :VW and let U take 0 args
      02/18/71 at 1429 by RHG to neaten file_errors
      02/18/71 at 1408 by RHG to fix bug in question_mark
      02/16/71 at 1326 by RHG to fix bug in %
      to use fixed_to_char_offset
      to use trace off during skip
      to call com_err_ on file errors
      02/02/71 at 1325 by RHG to fix potential bug in O which unwinds
      02/02/71 at 0337 by RHG to use the variable "max_Q_register_length" in :I
      to fix a bug in "revert_command_level"
      02/02/71 at 0214 by RHG to allow O to unwind command level
      to make M at end of one macro do a "goto" not a "call"
      to fix a bug in M with no args
      01/31/71 at 0510 by RHG to fix bug in get_character if only nl is typed
      01/31/71 at 0230 by RHG to fix bug in :S and rename TED as TECO
      01/25/72 at 1525 by RHG to fix bug in M
      01/24/71 at 2305 by RHG to add the M, [, and ] commands
      01/23/71 at 0300 by RHG to add the G, :I, X, VW, and ? commands
      earlier changes  by RHG went unrecorded.
****/

	/* condition names */

declare	(cleanup, fixedoverflow, program_interrupt, teco_abort) condition;

	/* builtin functions */

declare	(addr, bit, convert, copy, divide, fixed, hbound, index, lbound, length, max, min, multiply, null, reverse,
	search, substr, unspec, verify) builtin;

	/* automatic variables */

declare	EO_X_common_return label variable;
declare	get_character_fail_handler label variable;
declare	(arg_address, b1, b2, command_line_address, file_address, io_char_address, p) pointer;
declare	1 error_structure aligned,
	  2 error_message char (8),
	  2 nl char (1);
declare	cvb picture "(11)-9";
declare	string char (12);
declare	(backup_flag, immediate_interrupt_ok, no_ES_flag, no_number, match, program_interrupt_flag, search_successful,
	trace_flag, trace_flag_copy) bit (1) aligned;
declare	my_id bit (36) aligned;
declare	(current_character, delimiter, io_char) char (1) aligned;
declare	search_chars char (2) aligned;
declare	(Q_register_pushdown_level, arg_length, command_level) fixed bin (17);
declare	arg1_stack (0:20) fixed bin (17);
declare	colon_stack (0:20) fixed bin (17);
declare	command_char_stack (0:20) fixed bin (17);
declare	command_iteration_stack (0:20) fixed bin (17);
declare	command_length_stack (0:20) fixed bin (17);
declare	command_seg_stack (0:20) fixed bin (17);
declare	macro_entry fixed bin (17);
declare	num_arg_stack (0:20) fixed bin (17);
declare	pushdown_Q_register_seg_number (1:20) fixed bin (17);
declare	pushdown_Q_register_value (1:20) fixed bin (17);
declare	arg (0:2) fixed bin (24);
declare	(backup_command_line_1_char, base_iteration_level, colon_X_save_command_level, colon_flag, tag_char_number,
	command_char_number, command_line_length, count, current_Q_register_number, current_expression, current_sign,
	dot1, dot2, end_buffer, i, iteration_level, return_iteration_level, j, max_seg_size, max_dot1, min_dot2, n1, n2,
	num_arg, number, octal_number, paren_level, start, read_count, search_answer, iteration_answer, search_length,
	skip_count, temp_dot, which_operator) fixed bin (24);
declare	expression_stack (1:20) fixed bin (24);
declare	operator_stack (1:20) fixed bin (24);
declare	sign_stack (1:20) fixed bin (24);
declare	error_code fixed bin (35);
declare	1 iteration (1:20) aligned,
	  2 begin fixed bin (24),
	  2 end fixed bin (24),
	  2 count fixed bin (24),
	  2 begin_tag fixed bin (24),
	  2 errset bit (1);
declare	1 temp_seg_info structure aligned,
	  2 Q_register_value (32:127) fixed bin (24),
	  2 Q_register_seg_number (32:127) fixed bin (17),
	  2 temp_seg_address (-100:100) pointer,
	  2 temp_seg_usage_count (-100:100) fixed bin (17);

	/* based variables */

declare	argument based (arg_address) char (arg_length);
declare	current_Q_register based (current_Q_register_address) aligned char (current_Q_register_value);
declare	file based (file_address) aligned char (count);
declare	quoted_string based (quoted_string_address) aligned char (quoted_string_length);
declare	buffer1 based (b1) aligned char (dot1);
declare	buffer2 based (b2) aligned char (end_buffer);
declare	command_line based (command_line_address) aligned char (command_line_length);

	/* external entries */

declare	assign_temp_seg_id_ entry (char (*) aligned, bit (36) aligned, fixed bin (35));
declare	com_err_ entry options (variable);
declare	cu_$arg_count entry () returns (fixed bin (17));
declare	cu_$arg_ptr entry (fixed bin (17), pointer, fixed bin (17), fixed bin (35));
declare	cu_$cp entry (pointer, fixed bin (24), fixed bin (35));
declare	cu_$ptr_call entry options (variable);
declare	cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed binary (24));
declare	find_command_$fc_no_message entry (pointer, fixed bin (24), pointer, fixed bin (35));
declare	get_seg_ptr_ entry (char (*) aligned, bit (6) aligned, fixed bin (24), pointer, fixed bin (35));
declare	get_temp_seg_ entry (bit (36) aligned, bit (5) aligned, pointer, fixed bin (35));
declare	(
	ioa_,
	ioa_$rsnnl
	) entry options (variable);
declare	iox_$get_chars entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35));
declare	iox_$get_line entry (pointer, pointer, fixed bin (24), fixed bin (24), fixed bin (35));
declare	iox_$put_chars entry (pointer, pointer, fixed bin (24), fixed bin (35));
declare	release_seg_ptr_ entry (pointer, fixed bin (17), fixed bin (35));
declare	release_temp_segs_all_ entry (bit (36) aligned, fixed bin (35));
declare	search_file_
	     entry (pointer, fixed bin (24), fixed bin (24), pointer, fixed bin (24), fixed bin (24), fixed bin (24),
	     fixed bin (24), fixed bin (24));
declare	teco_backup_file_ entry (char (*) aligned);
declare	teco_error entry (char (*) aligned);
declare	teco_get_macro_ entry (char (*) aligned, pointer, fixed bin (24), fixed bin (35));

	/* defined variables */

declare	current_Q_register_seg_number fixed bin (17) defined (Q_register_seg_number (current_Q_register_number));
declare	current_Q_register_value fixed bin (24) defined (Q_register_value (current_Q_register_number));
declare	current_Q_register_address pointer defined (temp_seg_address (current_Q_register_seg_number));
declare	current_Q_register_usage_count fixed bin (17) defined (temp_seg_usage_count (current_Q_register_seg_number));
declare	quoted_string_seg_number fixed bin (17) defined (Q_register_seg_number (34));
declare	quoted_string_length fixed bin (24) defined (Q_register_value (34));
declare	quoted_string_address pointer defined (temp_seg_address (Q_register_seg_number (34)));
declare	arg1 defined (arg (1)) fixed bin (24);
declare	arg2 defined (arg (2)) fixed bin (24);

	/* external static */

declare	error_table_$too_many_args fixed bin (35) ext static;
declare	sys_info$max_seg_size external static fixed bin (24);
declare	iox_$user_input external static pointer;
declare	iox_$user_output external static pointer;

	/* constants */

declare	new_line_char int static options (constant) char (1) aligned initial ("
");
declare	blanks int static options (constant) char (12) aligned initial ("");
declare	white_space int static options (constant) char (2) aligned initial (" 	");
						/* space & tab */
declare	start_up_name int static options (constant) char (8) aligned initial ("start_up");
declare	char_0_code int static options (constant) fixed bin (09) initial (000110000b);
declare	dummy_Q_register_number int static options (constant) fixed bin (17) initial (127);
declare	number_reserved_temp_segs int static options (constant) fixed bin (17) initial (2);
declare	quoted_string_Q_register_number int static options (constant) fixed bin (17) initial (34);
declare	radix int static options (constant) fixed bin (17) initial (10);
declare	max_positive_integer int static options (constant) fixed bin (35)
	     initial (11111111111111111111111111111111111b);
declare	rwa_access int static options (constant) bit (5) aligned initial ("01011"b);
declare	r_access int static options (constant) bit (6) aligned initial ("010000"b);
declare	rwac_access int static options (constant) bit (6) aligned initial ("010111"b);
declare	program_name int static options (constant) char (4) aligned initial ("teco");

	/* internal static */

declare	signature_length int static fixed bin (24) init (3);
declare	signature int static char (8) aligned initial ("NZ");
declare	error_mode int static char (4) aligned initial ("shor");

%include cp_active_string_types;

teco_error_mode:
     entry (new_error_mode);
dcl  new_error_mode char (*) unal;
	error_mode = new_error_mode;
	return;

	/* entry to set the prompt string */

set_prompt:
     entry;

	call cu_$arg_ptr (1, arg_address, arg_length, error_code);
	if error_code = 0
	then do;
	     signature = argument;
	     signature_length = min (length (argument), length (signature));
	     end;
	else do;
	     signature = "NZ";
	     signature_length = 3;
	     end;
	return;

teco_no_ES:
     entry;
	no_ES_flag = "1"b;
	macro_entry = 0;
	goto no_ES_declarations;

abort:
ABORT:
     entry;
	signal teco_abort;

macro:
     entry;
	no_ES_flag = "0"b;
	macro_entry = 1;
	goto no_ES_declarations;

declarations:
	no_ES_flag = "0"b;
	macro_entry = 0;

no_ES_declarations:
	command_level = 0;
	Q_register_pushdown_level = 0;
	io_char_address = addr (io_char);
	error_structure.nl = new_line_char;
	unspec (temp_seg_info) = ""b;
	temp_seg_address (*) = null;			/* If this is removed, the marked line */
						/* in "allocate_Q_register" must be changed. */
	max_seg_size = sys_info$max_seg_size * 4;
	read_count = cu_$arg_count ();

	/* If number of args exceeds size of pushdown stack, this invokation of teco is aborted. */

	if read_count - macro_entry > hbound (pushdown_Q_register_value, 1) - 1
	then do;
	     call com_err_ (error_table_$too_many_args, program_name, "Maximum number of arguments is ^d.",
		hbound (pushdown_Q_register_value, 1) - 1);
	     return;
	     end;

	call assign_temp_seg_id_ (program_name, my_id, error_code);
	if error_code ^= 0
	then do;
	     call com_err_ (error_code, program_name, "temporary_segment_id");
	     return;
	     end;
	on cleanup call release_bufs;
	do i = 0 to number_reserved_temp_segs + (read_count - macro_entry) + 1;
	     call get_temp_seg_ (my_id, rwa_access, p, error_code);
	     if error_code ^= 0
	     then do;
		call com_err_ (error_code, program_name, "temporary segment number ^d", (i));
		goto EQ;
		end;
	     temp_seg_address (i) = p;
	     end;
	command_line_address = temp_seg_address (0);
	Q_register_pushdown_level = (read_count - macro_entry) + 1;
	pushdown_Q_register_seg_number (Q_register_pushdown_level) = 0;
	pushdown_Q_register_value (Q_register_pushdown_level) = (read_count - macro_entry);
	do i = 1 to read_count - macro_entry;
	     call cu_$arg_ptr (read_count - i + 1, arg_address, arg_length, error_code);
	     temp_seg_address (i + 3) -> argument = arg_address -> argument;
	     temp_seg_usage_count (i + 3) = 1;
	     pushdown_Q_register_value (i) = arg_length;
	     pushdown_Q_register_seg_number (i) = i + 3;
	     end;
	command_seg_stack (0) = -1;
	temp_seg_usage_count (-1) = 1;
	temp_seg_address (-1) = command_line_address;
	quoted_string_seg_number = 3;
	temp_seg_usage_count (3) = 1;
	n1, n2 = 0;
	b1 = null;
	dot1, dot2, end_buffer = 0;
	max_dot1, min_dot2 = 0;
	base_iteration_level = 0;
	paren_level = 0;
	trace_flag, trace_flag_copy = "0"b;
	command_char_number, command_line_length, backup_command_line_1_char = 0;
	search_answer = 0;
	iteration_level = 0;
	immediate_interrupt_ok = "1"b;
	num_arg = 0;
	colon_flag = 0;
	which_operator = -1;
	program_interrupt_flag = "0"b;
	on program_interrupt
	     begin;
		if immediate_interrupt_ok
		then goto command_abort;
		else program_interrupt_flag = "1"b;
		end;
	on teco_abort goto command_abort;
	current_Q_register_number = quoted_string_Q_register_number;
						/* determine initial macro. */
	if macro_entry = 0				/* Use default. */
	then do;
	     quoted_string_length = length (start_up_name);
	     quoted_string = start_up_name;
	     end;
	else do;
	     call cu_$arg_ptr (1, arg_address, arg_length, error_code);
	     if error_code ^= 0
	     then do;
		call com_err_ (error_code, program_name);
		goto EQ;
		end;
	     quoted_string_length = arg_length;
	     quoted_string = arg_address -> argument;
	     end;
	goto EM_have_name;

command_abort:
	program_interrupt_flag = "0"b;
	immediate_interrupt_ok = "0"b;
	do while (command_level > 0);			/* Handle each command level separately. */
	     call unwind_command_level;
	     end;
	base_iteration_level, iteration_level = 0;
	paren_level = 0;
	command_line_length, backup_command_line_1_char = 0;
	if macro_entry ^= 0				/* Error while in macro mode is fatal. */
	then do;
	     call com_err_ (0, program_name, "Command aborted.");
	     goto EQ;
	     end;
	trace_flag = trace_flag_copy;
command_complete:
COMMAND (36):
COMMAND (10):					/* NEWLINE and $ - Do Nothing */
	num_arg = 0;
command_return_value:
	colon_flag = 0;
	if num_arg = 0
	then
new_arg:
	     which_operator = -1;
	else
arg_loop:
	     which_operator = 0;
M_return:
	if program_interrupt_flag
	then goto command_abort;
	immediate_interrupt_ok = "1"b;
	get_character_fail_handler = command_string_completed;
get_number:					/* computes number, current_sign, no_number */
	current_sign = 0;
	number = 0;
	no_number = "0"b;
COMMAND_PREFIX (1):
COMMAND_PREFIX (24):				/* Blank and Tab - ignored between commands */
continue_scan:
	call get_character;
	goto COMMAND_PREFIX (index (" (:?0123456789-.zZqQ%bB	", current_character));

COMMAND_PREFIX (0):					/* Not a Numeric Argument */
	if current_sign = 0
	then if which_operator < 0
	     then goto check_command;
	     else if which_operator = 0
	     then goto check_operator;
	number = 1;
	no_number = "1"b;
backup_com_line:
	backup_command_line_1_char = 1;


got_number:
COMMAND_PREFIX (22):
COMMAND_PREFIX (23):				/* B - Note: value all set */
	if current_sign < 0
	then number = -number;
	goto OPERATOR (which_operator);

command_string_completed:
	if iteration_level ^= 0
	then goto unfinished_iteration;
	if paren_level ^= 0
	then goto unbalanced_parentheses;
	macro_entry = 0;				/* If we reach teco cmd level, macro mode is ended. */

	if signature_length > 0
	then call WRITE (addr (signature), 0, signature_length);
	do while (Q_register_pushdown_level ^= 0);
	     Q_register_pushdown_level = Q_register_pushdown_level - 1;
	     temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) =
		temp_seg_usage_count (pushdown_Q_register_seg_number (Q_register_pushdown_level + 1)) - 1;
	     end;
	command_line_length = 0;
	command_char_number = 0;
	search_answer = 0;
	call read_line;
	go to command_complete;

COMMAND_PREFIX (15):
	if which_operator = 0
	then goto COMMAND_PREFIX (0);			/* unary minus */
	current_sign = -current_sign;
	if current_sign = 0
	then current_sign = -1;
	goto continue_scan;


COMMAND (43):					/* Leading Plus */
	current_sign = 1;
	goto continue_scan;


COMMAND_PREFIX (5):
COMMAND_PREFIX (6):
COMMAND_PREFIX (7):
COMMAND_PREFIX (8):
COMMAND_PREFIX (9):
COMMAND_PREFIX (10):
COMMAND_PREFIX (11):
COMMAND_PREFIX (12):
COMMAND_PREFIX (13):
COMMAND_PREFIX (14):				/* 0,1,2,3,4,5,6,7,8,9 */
	octal_number = 0;
	do i = fixed (unspec (io_char), 9, 0) - char_0_code repeat (fixed (unspec (io_char), 9, 0) - char_0_code)
	     while (i >= 0 & i < radix);
	     number = multiply (number, radix, 15, 0) + i;
	     octal_number = octal_number * 8 + i;
	     call get_character;
	     end;
	if current_character ^= "."
	then goto backup_com_line;
	number = octal_number;
	goto got_number;


COMMAND_PREFIX (16):				/* . - Get Dot Value */
	number = dot1;
	goto got_number;


COMMAND_PREFIX (17):
COMMAND_PREFIX (18):				/* Z - End Value */
	number = dot1 + end_buffer - dot2;
	goto got_number;


COMMAND_PREFIX (19):
COMMAND_PREFIX (20):				/* Q - Q Register value */
	current_Q_register_number = get_Q_register_number ();
	number = current_Q_register_value;
	goto got_number;


COMMAND_PREFIX (21):				/* % - Increment Command */
	current_Q_register_number = get_Q_register_number ();
	if current_Q_register_seg_number ^= 0
	then goto percent_cant_increment;
	current_Q_register_value, number = current_Q_register_value + 1;
	goto got_number;


COMMAND_PREFIX (3):					/* : - Command Modifier */
	colon_flag = 1;
	goto continue_scan;

COMMAND_PREFIX (4):					/* ? - Trace */
	trace_flag = "1"b;
	get_character_fail_handler = question_mark_alone;
	call get_character;
	if current_character = "?"
	then trace_flag = "0"b;
	else backup_command_line_1_char = 1;
question_mark_alone:
	trace_flag_copy = trace_flag;
	get_character_fail_handler = command_string_completed;
	goto continue_scan;

OPERATOR (-1):
	which_operator = 0;
two_commas:
	if num_arg >= hbound (arg, 1)
	then goto too_many_args;
	num_arg = num_arg + 1;
	current_expression = number;
	goto arg_loop;
OPERATOR (0):
OPERATOR (1):
	current_expression = current_expression + number;
	goto arg_loop;


OPERATOR (2):
	current_expression = current_expression - number;
	goto arg_loop;


OPERATOR (3):
	if no_number
	then goto missing_right_operand;
	current_expression = current_expression * number;
	goto arg_loop;


OPERATOR (4):
	if no_number
	then goto missing_right_operand;
	current_expression = divide (current_expression, number, 15, 0);
	goto arg_loop;


OPERATOR (5):
	if no_number
	then goto missing_right_operand;
	unspec (current_expression) = unspec (current_expression) & unspec (number);
	goto arg_loop;


OPERATOR (6):
	if no_number
	then goto missing_right_operand;
	unspec (current_expression) = unspec (current_expression) | unspec (number);
	goto arg_loop;

COMMAND_PREFIX (2):					/* ( */
	if paren_level >= hbound (expression_stack, 1)
	then goto parenthesis_overflow;
	operator_stack (paren_level + 1) = which_operator;
	sign_stack (paren_level + 1) = current_sign;
	expression_stack (paren_level + 1) = current_expression;
	num_arg_stack (paren_level + 1) = num_arg;
	colon_stack (paren_level + 1) = colon_flag;
	arg1_stack (paren_level + 1) = arg1;		/* we don't have to save arg2 because max 2 args anyways */
	paren_level = paren_level + 1;
	goto command_complete;


COMMAND (41):					/* ) */
	if paren_level = 0
	then goto unbalanced_parentheses;
	if num_arg >= 2
	then goto strange_parentheses;
	paren_level = paren_level - 1;
	number = arg1;
	which_operator = operator_stack (paren_level + 1);
	current_sign = sign_stack (paren_level + 1);
	current_expression = expression_stack (paren_level + 1);
	arg1 = arg1_stack (paren_level + 1);
	colon_flag = colon_stack (paren_level + 1);
	i = num_arg;
	num_arg = num_arg_stack (paren_level + 1);
	if i = 0
	then goto get_number;
	goto got_number;


check_operator:					/* OPERATOR DISPATCH */
	which_operator = index ("+-*/&|", current_character);
	if which_operator ^= 0
	then goto get_number;

check_command:					/* COMMAND DISPATCH */
	arg (num_arg) = current_expression;
	goto COMMAND (fixed (unspec (current_character) & "001111111"b, 9));


COMMAND (44):					/* , - Next Argument Separator */
	if which_operator >= 0
	then goto new_arg;
	number = 0;
	goto two_commas;


COMMAND (61):					/* = - Print Value Command */
	if colon_flag = 1
	then call ioa_ ("^v(^o^x^)", num_arg, arg1, arg2);
	else call ioa_ ("^v(^d^x^)", num_arg, arg1, arg2);
	goto command_complete;

COMMAND (60):					/* < - Open Iteration */
	tag_char_number = 0;
iteration_common:
	if num_arg >= 2
	then goto too_many_args;
	if num_arg = 0
	then arg1 = max_positive_integer;
	if arg1 < 0
	then goto bad_negative_argument;
	if iteration_level >= hbound (iteration.count, 1)
	then goto iteration_overflow;
	iteration.errset (iteration_level + 1) = (colon_flag ^= 0);
	iteration.begin_tag (iteration_level + 1) = tag_char_number;
	if arg1 = 0
	then do;
	     call skip ("<>");
	     goto iteration_done;
	     end;
	iteration_level = iteration_level + 1;
	iteration.begin (iteration_level) = command_char_number;
	iteration.end (iteration_level) = -1;
	iteration.count (iteration_level) = arg1;
	goto command_complete;



COMMAND (62):					/* > - End Iteration */
	if num_arg ^= 0
	then goto too_many_args;
	if iteration_level = base_iteration_level
	then goto iteration_underflow;
	iteration.count (iteration_level) = iteration.count (iteration_level) - 1;
	if iteration.count (iteration_level) ^= 0
	then do;
	     iteration.end (iteration_level) = command_char_number;
	     command_char_number = iteration.begin (iteration_level);
	     goto command_complete;
	     end;
	iteration_level = iteration_level - 1;
iteration_done:
	iteration_answer = -1;			/* succeed */
get_out_of_iteration:
	if iteration.errset (iteration_level + 1) | iteration.begin_tag (iteration_level + 1) ^= 0
	then do;
	     num_arg = 1;
	     current_expression = iteration_answer;
	     goto command_return_value;
	     end;
	else goto command_complete;


COMMAND (59):					/* ; - Return if Positive */
	if num_arg >= 2
	then goto too_many_args;
	if iteration_level = 0
	then goto semi_colon_out_of_iteration;
	if num_arg = 0
	then arg1 = search_answer;
	if colon_flag = 0
	then if arg1 < 0
	     then goto command_complete;
	     else ;
	else if arg1 >= 0
	then goto command_complete;
	call unwind_iteration (iteration_level - 1);
	goto iteration_done;

COMMAND (34):					/* " - Quote Command Dispatch */
	if num_arg >= 3
	then goto too_many_args;
	if num_arg = 1
	then arg2 = 0;
	get_character_fail_handler = missing_double_quote_command;
	call get_character;
	goto QUOTE_COMMAND (index ("cCeEgGlLnNmM", current_character));


QUOTE_COMMAND (1):
QUOTE_COMMAND (2):					/* "C */
	if num_arg = 0
	then goto too_few_args;
	if num_arg = 2
	then goto too_many_args;
	unspec (io_char) = bit (fixed (arg1, 9, 0));
	if io_char >= "a"
	then if io_char <= "z"
	     then goto command_complete;
	if io_char >= "A"
	then if io_char <= "Z"
	     then goto command_complete;
	if io_char >= "0"
	then if io_char <= "9"
	     then goto command_complete;
	if io_char = "_"
	then goto command_complete;
	if io_char = "$"
	then goto command_complete;
	if io_char = "."
	then goto command_complete;
	goto quote_skip;

QUOTE_COMMAND (3):
QUOTE_COMMAND (4):					/* "E Equal Command */
	if num_arg = 0
	then goto too_few_args;
	if arg1 = arg2
	then goto command_complete;
	else goto quote_skip;

QUOTE_COMMAND (5):
QUOTE_COMMAND (6):					/* "G - Greater Than Command */
	if num_arg = 0
	then goto too_few_args;
	if arg1 > arg2
	then goto command_complete;
	else goto quote_skip;

QUOTE_COMMAND (7):
QUOTE_COMMAND (8):					/* "L - Less Than Command */
	if num_arg = 0
	then goto too_few_args;
	if arg1 < arg2
	then goto command_complete;
	else goto quote_skip;

QUOTE_COMMAND (9):
QUOTE_COMMAND (10):					/* "N - Not Equal Command */
	if num_arg = 0
	then goto too_few_args;
	if arg1 ^= arg2
	then goto command_complete;
	else goto quote_skip;


QUOTE_COMMAND (11):
QUOTE_COMMAND (12):					/* "M - Match String Command */
	if num_arg ^= 0
	then goto too_many_args;
	call get_quoted_string;
	if end_buffer - dot2 < quoted_string_length
	then match = "0"b;
	else match = quoted_string = substr (buffer2, dot2 + 1, quoted_string_length);
	if colon_flag ^= 0
	then match = ^match;
	if match
	then goto command_complete;
	else goto quote_skip;



quote_skip:
	call skip ("""'");
	goto command_complete;


COMMAND (39):					/* ' - Apostrophe */
	if colon_flag = 1
	then goto quote_skip;			/* a :' forms an else statement */
	goto command_complete;			/* Ignore any apostrophes we are just passing by. */


COMMAND (33):					/* ! - Label Delimiter */
	call skip_with_trace ("!!");
	goto command_complete;


COMMAND (91):					/* [ - Push */
	if Q_register_pushdown_level >= hbound (pushdown_Q_register_value, 1)
	then goto Q_register_pushdown_overflow;
	current_Q_register_number = get_Q_register_number ();
	pushdown_Q_register_value (Q_register_pushdown_level + 1) = current_Q_register_value;
	pushdown_Q_register_seg_number (Q_register_pushdown_level + 1) = current_Q_register_seg_number;
	immediate_interrupt_ok = "0"b;
	if current_Q_register_seg_number ^= 0
	then current_Q_register_usage_count = current_Q_register_usage_count + 1;
	Q_register_pushdown_level = Q_register_pushdown_level + 1;
	goto command_complete;


COMMAND (93):					/* ] - Pop */
	if Q_register_pushdown_level = 0
	then goto Q_register_pushdown_underflow;
	current_Q_register_number = get_Q_register_number ();
	i = current_Q_register_seg_number;
	immediate_interrupt_ok = "0"b;
	Q_register_pushdown_level = Q_register_pushdown_level - 1;
	current_Q_register_value = pushdown_Q_register_value (Q_register_pushdown_level + 1);
	current_Q_register_seg_number = pushdown_Q_register_seg_number (Q_register_pushdown_level + 1);
	if i ^= 0
	then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
	goto command_complete;

COMMAND (65):
COMMAND (97):					/* A - Ascii Command */
	if num_arg >= 2
	then goto too_many_args;
	if num_arg = 0
	then goto unimplemented_feature;
	if arg1 > 0
	then do;
	     i = dot2 + arg1 - 1;
	     if i >= end_buffer
	     then goto A_1_arg_beyond_Z;
	     io_char = substr (buffer2, i + 1, 1);
	     end;
	else do;
	     i = dot1 + arg1 - 1;
	     if i < 0
	     then goto A_1_arg_before_0;
	     io_char = substr (buffer1, i + 1, 1);
	     end;
	current_expression = fixed (unspec (io_char), 9, 0);
	num_arg = 1;
	goto command_return_value;


COMMAND (67):
COMMAND (99):					/* C - Characters Forward Command */
	if num_arg = 0
	then arg1 = 1;
C_check:
	if num_arg > 1
	then goto too_many_args;
	call move_dot (arg1, (colon_flag ^= 0));
	goto command_complete;


COMMAND (68):
COMMAND (100):
	if num_arg = 0
	then arg1 = 1;				/* D - Delete */
	if num_arg >= 2
	then goto too_many_args;
	call delete_chars (min (dot1, dot1 + arg1), max (dot2, dot2 + arg1));
	goto command_complete;

COMMAND (69):
COMMAND (101):					/* E command dispach */
	get_character_fail_handler = EXTERNAL_COMMAND (0);
	call get_character;
	goto EXTERNAL_COMMAND (index ("oOiImMcCaAsSbBgGqQ", current_character));


EXTERNAL_COMMAND (9):
EXTERNAL_COMMAND (10):				/* EA - External Active Function */
dcl  ret_string char (10000) varying based (current_Q_register_address),
     cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35));

	current_Q_register_number = get_Q_register_number ();
	call get_quoted_string;
	call allocate_Q_register_have_number (current_Q_register_number);

	ret_string = "";
	begin;
dcl  quoted_string_unal char (quoted_string_length) based (quoted_string_address);
	     call cu_$evaluate_active_string (null (), quoted_string_unal, NORMAL_ACTIVE_STRING, ret_string, error_code)
		;
	     end;
	if error_code ^= 0
	then do;
	     call com_err_ (error_code, program_name, """^a""", quoted_string);
	     goto command_abort;
	     end;

	current_Q_register_value = length (ret_string);

	current_Q_register = copy (ret_string, 1);
	goto command_complete;


EXTERNAL_COMMAND (13):
EXTERNAL_COMMAND (14):				/* EB - External Backup */
	backup_flag = "1"b;
	goto EO_EB_common;


EXTERNAL_COMMAND (7):
EXTERNAL_COMMAND (8):				/* EC - External Command */
	call get_quoted_string;
	call cu_$cp (quoted_string_address, quoted_string_length, error_code);
	goto command_complete;

EXTERNAL_COMMAND (15):
EXTERNAL_COMMAND (16):				/* EG - ??? */
	goto unimplemented_feature;

EXTERNAL_COMMAND (3):
EXTERNAL_COMMAND (4):				/* EI - External Input */
	if num_arg ^= 0
	then goto too_many_args;
	num_arg = colon_flag;			/* indicate if returning a value */
	call get_quoted_string;
	call get_seg_ptr_ (quoted_string, r_access, read_count, file_address, error_code);
	if error_code ^= 0
	then if colon_flag = 1
	     then do;
		current_expression = 0;		/* fail */
		goto command_return_value;
		end;
	     else goto file_error;
	count = divide (read_count + 8, 9, 17, 0);

	if dot1 + end_buffer - dot2 > 0		/* Text in buffer, cannot use source seg. */
	then do;
	     call add_chars (file_address, count);
	     call close_file (file_address);
	     end;
	else do;					/* Buffer is empty, don't copy, use source seg. */
	     immediate_interrupt_ok = "0"b;
	     b1, b2 = file_address;
	     n1, n2 = 0;
	     dot1, dot2, end_buffer, max_dot1 = count;
	     min_dot2 = 0;
	     end;
	if colon_flag = 1
	then do;
	     current_expression = -1;			/* good */
	     goto command_return_value;
	     end;
	else goto command_complete;


EXTERNAL_COMMAND (5):
EXTERNAL_COMMAND (6):				/* EM - External Macro */
	call get_quoted_string;
EM_have_name:
	call teco_get_macro_ (quoted_string, file_address, read_count, error_code);
	if error_code ^= 0
	then goto EM_macro_not_found;
	j = 0;
	do i = -1 to lbound (temp_seg_address, 1) by -1;
	     if temp_seg_address (i) = file_address
	     then goto EM_have_slot;

	     if j = 0
	     then if temp_seg_usage_count (i) = 0
		then j = i;
	     end;
	if j = 0
	then goto EM_no_slot;
	i = j;

EM_have_slot:
	temp_seg_address (i) = file_address;
	current_Q_register_number = dummy_Q_register_number;
	Q_register_value (dummy_Q_register_number) = read_count;
	Q_register_seg_number (dummy_Q_register_number) = i;
	goto M_have_reg;

EXTERNAL_COMMAND (1):
EXTERNAL_COMMAND (2):				/* EO - External Output */
	backup_flag = "0"b;
EO_EB_common:
	if num_arg >= 3
	then goto too_many_args;
	do;
	     call get_quoted_string;
	     if backup_flag
	     then call teco_backup_file_ (quoted_string);
	     call get_seg_ptr_ (quoted_string, rwac_access, read_count, file_address, error_code);
	     if file_address = null
	     then goto file_error;
	     end;
	immediate_interrupt_ok = "0"b;
	if b1 = file_address
	then call copy_source;
	start = 1;
	EO_X_common_return = EO_close_file;
	if num_arg ^= 0
	then goto EO_X_common;
	else do;
	     arg1 = 0;
	     count = dot1 + end_buffer - dot2;
	     goto EO_X_around_dot;
	     end;
EO_close_file:
	call release_seg_ptr_ (file_address, 9 * count, error_code);
	if error_code ^= 0
	then goto file_error;
	goto command_complete;

EO_X_common:
	if num_arg < 2
	then if arg1 >= 1
	     then do;
		call find_line_forward;
		arg1 = dot1;
		goto EO_X_after_dot;
		end;
	     else do;
		call find_line_reverse;
		arg1 = temp_dot;
		count = dot1 - temp_dot;
		goto EO_X_before_dot;
		end;
	else do;					/* (num_arg = 2) */
	     if arg1 < 0
	     then arg1 = 0;
	     if arg2 > dot1 + end_buffer - dot2
	     then arg2 = dot1 + end_buffer - dot2;
	     count = arg2 - arg1;
	     if count < 0
	     then goto args_wrong_order;
	     if start + count > max_seg_size
	     then goto dot_beyond_Z;			/* will overflow Q reg */
	     if dot1 >= arg2
	     then
EO_X_before_dot:
		do;
		     if count ^= 0
		     then substr (file, start, count) = substr (buffer1, arg1 + 1, count);
		     goto EO_X_common_return;
		     end;
	     if arg1 >= dot1
	     then
EO_X_after_dot:
		do;
		     if count ^= 0
		     then substr (file, start, count) = substr (buffer2, (arg1 + dot2 - dot1) + 1, count);
		     goto EO_X_common_return;
		     end;
	     else					/* (arg1<.<arg2) */
EO_X_around_dot:
		do;
		     i = dot1 - arg1;
		     if i ^= 0
		     then substr (file, start, i) = substr (buffer1, arg1 + 1, i);
		     j = count - i;
		     if j ^= 0
		     then substr (file, i + start, j) = substr (buffer2, dot2 + 1, j);
		     goto EO_X_common_return;
		     end;
	     end;

EQ:
EXTERNAL_COMMAND (17):
EXTERNAL_COMMAND (18):				/* EQ - External Quit */
	if trace_flag
	then do;
	     io_char = new_line_char;
	     call WRITE (io_char_address, 0, 1);
	     end;
	call release_bufs;
	return;

release_bufs:
     procedure;
	immediate_interrupt_ok = "0"b;
	call release_temp_segs_all_ (my_id, error_code);
	if error_code ^= 0
	then call com_err_ (error_code, program_name, "trying to release temporary segments");
	if n1 = 0 & b1 ^= null
	then call release_seg_ptr_ (b1, -1, error_code);
     end release_bufs;


EXTERNAL_COMMAND (11):
EXTERNAL_COMMAND (12):				/* ES - External Subroutine */
	if no_ES_flag
	then goto unimplemented_feature;
	if num_arg <= 0
	then arg1 = max_positive_integer;
	if num_arg <= 1
	then arg2 = max_positive_integer;
	current_Q_register_number = get_Q_register_number ();
	if current_Q_register_seg_number = 0
	then goto ES_numeric_Q;
	call get_quoted_string;
	call find_command_$fc_no_message (quoted_string_address, quoted_string_length, file_address, error_code);
	if error_code ^= 0
	then go to ES_subroutine_not_found;
	current_expression = 0;
	call cu_$ptr_call (file_address, current_Q_register, arg1, arg2, current_expression);
	num_arg = 1;
	goto command_return_value;

COMMAND (70):
COMMAND (102):					/* F COMMAND DIAPATCH */
	get_character_fail_handler = F_COMMAND (0);
	call get_character;
	goto F_COMMAND (index ("<;", current_character));


F_COMMAND (1):					/* F<!tag! - Lisp Catch */
	call get_character;
	do while (index (white_space, current_character) ^= 0);
	     call get_character;
	     end;
	if current_character ^= "!"
	then goto F_COMMAND (0);
	tag_char_number = command_char_number;
	call skip_with_trace ("!!");
	goto iteration_common;


F_COMMAND (2):					/* F; - Lisp Throw */
	if num_arg > 1
	then goto too_many_args;
	if num_arg < 1
	then goto too_few_args;
	call get_quoted_string;
	if iteration_level = 0
	then goto semi_colon_out_of_iteration;
	do return_iteration_level = iteration_level by -1 to 1;
	     do while (return_iteration_level <= base_iteration_level);
		call unwind_command_level;
		end;
	     if iteration.begin_tag (return_iteration_level) ^= 0
	     then if quoted_string
		     =
		     substr (command_line, iteration.begin_tag (return_iteration_level) + 1,
		     iteration.begin (return_iteration_level) - 1 - iteration.begin_tag (return_iteration_level))
		then do;
		     call unwind_iteration (return_iteration_level - 1);
		     iteration_answer = arg1;
		     goto get_out_of_iteration;
		     end;
	     end;
	goto label_not_found;

COMMAND (71):
COMMAND (103):					/* G - Get Q Register Command */
	if num_arg ^= 0
	then goto too_many_args;
	current_Q_register_number = get_Q_register_number ();
	if current_Q_register_seg_number ^= 0
	then do;
	     call add_chars (current_Q_register_address, current_Q_register_value);
	     goto command_complete;
	     end;
	else do;					/* (Q_reg contains a number -- convert it to text) */
	     num_arg = 1;
	     arg1 = current_Q_register_value;
	     goto backslash;
	     end;


COMMAND (72):
COMMAND (104):					/* H - wHole Syntax Krock */
	if num_arg ^= 0
	then goto too_many_args;
	arg1 = 0;
	current_expression = dot1 + end_buffer - dot2;
	num_arg = 2;
	goto command_return_value;

COMMAND (73):
COMMAND (105):					/* I -  Insert Command */
	if num_arg >= 2
	then goto too_many_args;
	if colon_flag = 0
	then do;
	     if num_arg = 0
	     then do;
		call get_quoted_string;
		call add_chars (quoted_string_address, quoted_string_length);
		goto command_complete;
		end;
	     else do;
		unspec (io_char) = bit (fixed (arg1, 9, 0));
		call add_chars (io_char_address, 1);
		goto command_complete;
		end;
	     end;
	else do;
	     current_Q_register_number = get_Q_register_number ();
	     if num_arg = 0
	     then do;
		call get_quoted_string;
		immediate_interrupt_ok = "0"b;
		temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1;
		i = current_Q_register_seg_number;
		current_Q_register_seg_number = quoted_string_seg_number;
		current_Q_register_value = quoted_string_length;
		if i ^= 0
		then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
		goto command_complete;
		end;
	     else do;
		immediate_interrupt_ok = "0"b;
		call allocate_Q_register_have_number (current_Q_register_number);
		unspec (substr (current_Q_register_address -> file, 1, 1)) = bit (fixed (arg1, 9, 0));
		current_Q_register_value = 1;
		goto command_complete;
		end;
	     end;


COMMAND (74):
COMMAND (106):					/* J- Jump Command */
	if num_arg = 0
	then arg1 = 0;
	arg1 = arg1 - dot1;
	goto C_check;

COMMAND (75):
COMMAND (107):					/* K - Kill Command */
	if num_arg > 2
	then goto too_many_args;
	if num_arg < 2
	then do;
	     if num_arg = 0
	     then arg1 = 1;
	     if arg1 > 0
	     then do;
		call must_find_line_forward;
		call delete_chars (dot1, temp_dot);
		goto command_complete;
		end;
	     else do;
		call must_find_line_reverse;
		call delete_chars (temp_dot, dot2);
		goto command_complete;
		end;
	     end;
	if arg1 > arg2
	then goto args_wrong_order;
	call move_dot_forward (arg1 - dot1);		/* If dot < arg1; move dot to arg1, else no move. */
	call move_dot_backward (arg2 - dot1);		/* If arg2 < dot; move dot to arg2, else no move. */
	call delete_chars (arg1, dot2 + arg2 - dot1);
	goto command_complete;


COMMAND (76):
COMMAND (108):					/* L - Lines Command */
	if num_arg > 1
	then goto too_many_args;
	if num_arg = 0
	then arg1 = 1;
	if arg1 > 0
	then do;
	     call must_find_line_forward;
	     call move_dot_forward (count - colon_flag);
	     end;
	else do;
	     call must_find_line_reverse;
	     call move_dot_backward (temp_dot - dot1 - colon_flag);
	     end;
	goto command_complete;

COMMAND (77):
COMMAND (109):					/* M - Macro Command */
	current_Q_register_number = get_Q_register_number ();
	if current_Q_register_seg_number = 0
	then goto M_numeric_Q_register;
M_have_reg:
	if (command_level ^= 0 & command_char_number = command_line_length) | colon_flag ^= 0
	then do;
	     call revert_command_level;
	     goto M_get_new_line;
	     end;
	if command_level >= hbound (command_char_stack, 1)
	then goto command_level_overflow;
	command_char_stack (command_level) = command_char_number;
	command_length_stack (command_level) = command_line_length;
	command_iteration_stack (command_level) = base_iteration_level;
M_get_new_line:
	command_seg_stack (command_level + 1) = current_Q_register_seg_number;
	immediate_interrupt_ok = "0"b;
	command_line_length = current_Q_register_value;
	current_Q_register_usage_count = current_Q_register_usage_count + 1;
	command_line_address = current_Q_register_address;
	command_char_number = 0;
	base_iteration_level = iteration_level;
	command_level = command_level + 1;
	goto M_return;

COMMAND (78):
COMMAND (110):					/* N - QEDX type string search. Sets Q". */
	if num_arg = 0
	then arg1 = 1;				/* default is one forward search. */
	if num_arg > 2
	then goto too_many_args;
	if num_arg = 2				/* arg1- line count; arg2- search count. */
	then do;
	     if arg1 <= 0 | arg2 < 0
	     then goto unimplemented_feature;		/* Can't reverse regular expr. */
	     call find_line_forward;
	     arg1 = arg2;				/* make it look like one arg case. */
	     arg2 = temp_dot;			/* Set search limit. */
	     end;
	else if arg1 >= 0				/* One arg. arg1- search count. */
	then arg2 = end_buffer;			/* Search remainder by default. */
	else goto unimplemented_feature;		/* Can't reverse regular expr. */
	num_arg = colon_flag;			/* Indicate whether we return a value. */
	call get_quoted_string;			/* Get the regular expr. */
	if quoted_string_length = 0
	then goto command_complete;			/* Zero len string matches anything. */
	if arg1 = 0
	then goto command_complete;			/* search count = 0. */
	temp_dot = dot2;
	i = quoted_string_length;
	if n1 ^= n2				/* search_file_ requires context for its search. */
	then if dot1 > 0				/* Move char only if there is one. */
	     then do;				/* Copy one character from before dot. */
		call move_dot_backward (-1);		/* This should handle exceptional cases. */
		dot1 = dot1 + 1;			/* This should be transparent. */
		dot2 = dot2 + 1;			/* This should be transparent. */
		end;
	     else if dot2 > 0			/* Must convince search_file_ we have beginning of line. */
	     then substr (buffer2, dot2, 1) = new_line_char;
						/* search_file_ knows about offsets. */
	do arg1 = 1 to arg1;
	     if temp_dot >= arg2
	     then goto S_fail;
	     call search_file_ (quoted_string_address, 1, i, b2, temp_dot + 1, arg2, j, temp_dot, count);
	     if count ^= 0
	     then do;
		current_Q_register_number = quoted_string_Q_register_number;
		call allocate_Q_register_have_number (current_Q_register_number);
		quoted_string_length = 0;
		goto S_fail;
		end;
	     i = 0;				/* Speed up search time. */
	     end;
	current_Q_register_number = quoted_string_Q_register_number;
	call allocate_Q_register_have_number (current_Q_register_number);
	count = temp_dot - j + 1;			/* Length of matched string. */
	if count = 0
	then goto S_succeed_forward;
	substr (quoted_string, 1, count) = substr (buffer2, j, count);
	quoted_string_length = count;
	goto S_succeed_forward;

COMMAND (79):
COMMAND (111):					/* O - gOto Command */
	call get_quoted_string;
	count = quoted_string_length + 1;
	substr (quoted_string, count, 1) = "!";
O_have_label:
	command_char_number = 1;
	do while ("1"b);
	     if command_char_number + count >= command_line_length
	     then goto O_unwind_command;
	     i = index (substr (command_line, command_char_number + 1), substr (quoted_string, 1, count));
	     if i = 0
	     then
O_unwind_command:
		do;
		     if command_level = 0
		     then goto label_not_found;
		     call revert_command_level;
		     goto O_have_label;
		     end O_unwind_command;
	     command_char_number = command_char_number + i + quoted_string_length;
	     if substr (command_line, command_char_number - count, 1) = "!"
	     then goto command_complete;
	     end;


COMMAND (80):
COMMAND (112):					/* P -  aPpend to Q Register */
	immediate_interrupt_ok = "0"b;
	current_Q_register_number = get_Q_register_number ();
	if num_arg = 0
	then arg1 = 1;
	if current_Q_register_seg_number ^= 0
	then do;
	     if current_Q_register_usage_count > 1
	     then do;
		file_address = current_Q_register_address;
		count = current_Q_register_value;
		call allocate_Q_register_have_number (current_Q_register_number);
		current_Q_register_value = count;
		current_Q_register = file;		/* Copy the string */
		end;
	     file_address = current_Q_register_address;
	     start = current_Q_register_value + 1;
	     EO_X_common_return = normal_P_close_Q_reg;
	     goto EO_X_common;

normal_P_close_Q_reg:
	     current_Q_register_value = current_Q_register_value + count;
	     end;
	else do;
	     call allocate_Q_register_have_number (current_Q_register_number);
	     file_address = current_Q_register_address;
	     EO_X_common_return = null_P_close_Q_reg;
	     start = 1;
	     goto EO_X_common;
null_P_close_Q_reg:
	     current_Q_register_value = count;
	     end;
	goto command_complete;


COMMAND (82):
COMMAND (114):					/* R - Reverse Characters */
	if num_arg = 0
	then arg1 = 1;
	arg1 = -arg1;
	goto C_check;

COMMAND (83):
COMMAND (115):
	do;					/* S - Search Text */
	     if num_arg = 0
	     then arg1 = 1;
	     if num_arg > 2
	     then goto too_many_args;
	     if num_arg = 2
	     then do;
		if arg1 >= 1			/* arg1 is the number of lines to search over */
		then do;
		     if arg2 < 0
		     then goto S_fail;
		     call find_line_forward;
		     end;
		else do;
		     if arg2 > 0
		     then goto S_fail;
		     call find_line_reverse;
		     end;
		arg1 = arg2;			/* move search count to arg1. */
		arg2 = temp_dot;			/* put search limit in arg2. */
		end;
	     else					/* num_arg < 2 */
		if arg1 >= 0
	     then arg2 = end_buffer;
	     else arg2 = 0;
	     num_arg = colon_flag;			/* indicate whether a value is being returned or not	*/
	     do;
		call get_quoted_string;
		if quoted_string_length = 0
		then goto command_complete;
		if arg1 = 0
		then goto command_complete;
		if arg1 >= 0
		then do;
		     temp_dot = dot2;
plus_S_loop:
		     do;
			if arg2 = temp_dot
			then goto S_fail;
			j = index (substr (buffer2, temp_dot + 1, arg2 - temp_dot), quoted_string);
			if j = 0
			then
S_fail:
			     do;
				search_answer = 0;
				if colon_flag = 0
				then goto fatal_S_fail;
				else do;
				     current_expression = search_answer;
				     goto command_return_value;
				     end;
				end S_fail;
			temp_dot = temp_dot + (j - 1 + quoted_string_length);
			arg1 = arg1 - 1;
			if arg1 ^= 0
			then goto plus_S_loop;
			end plus_S_loop;
S_succeed_forward:
		     arg1 = temp_dot - dot2;
S_succeed:
		     search_answer = -1;
		     current_expression = search_answer;
		     call move_dot (arg1, "0"b);
		     goto command_return_value;
		     end;

		/* Minus search is done in line. The following code takes advantage of the PL/I compiler's optimizer. */
		/* index(reverse(substr(something)), reverse(char_1_or_2)) is inline if char_1_or_2 is aligned & constant length. */
		/* Also, the reverse(substr(something)) does not move any characters. */

		else do;				/* (arg1 < 0) */
		     temp_dot = dot1;
		     search_chars = substr (quoted_string, 1, 2);
		     if quoted_string_length = 1
		     then do while (arg1 < 0);
			     if temp_dot = arg2
			     then goto S_fail;
			     j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)),
				substr (search_chars, 1, 1));
			     if j = 0
			     then goto S_fail;
			     temp_dot = temp_dot - j;
			     arg1 = arg1 + 1;
			     end;
		     else do;
minus_S_iterate:
			if temp_dot - arg2 < 2
			then go to S_fail;		/* Must have room to search. */
			j = index (reverse (substr (buffer1, arg2 + 1, temp_dot - arg2)), reverse (search_chars));
			if j = 0
			then go to S_fail;
			temp_dot = temp_dot - j;
			if (temp_dot - 1) + quoted_string_length > dot1
			then go to minus_S_iterate;
			if quoted_string_length > 2
			then if substr (buffer1, temp_dot + 2, quoted_string_length - 2)
				^= substr (quoted_string, 3, quoted_string_length - 2)
			     then goto minus_S_iterate;
			temp_dot = temp_dot - 1;
			arg1 = arg1 + 1;
			if arg1 < 0
			then goto minus_S_iterate;
			end;
		     arg1 = temp_dot - dot1;
		     goto S_succeed;
		     end;
		end;
	     end;

COMMAND (84):
COMMAND (116):					/* T - Type Text */
	if colon_flag = 0
	then do;
	     if num_arg = 0
	     then arg1 = 1;
	     if num_arg > 2
	     then goto too_many_args;
	     if num_arg < 2
	     then if arg1 >= 1
		then do;
		     call find_line_forward;
		     arg1 = dot1;
		     arg2 = dot1 + count;
		     end;
		else				/* (arg1 < 1) */
		     do;
		     call find_line_reverse;
		     arg1 = temp_dot;
		     arg2 = dot1;
		     end;
	     else do;				/* (num_arg = 2) */
		if arg1 < 0
		then arg1 = 0;
		if arg2 > dot1 + end_buffer - dot2
		then arg2 = dot1 + end_buffer - dot2;
		end;
	     count = arg2 - arg1;
	     if count < 0
	     then goto args_wrong_order;
	     if count = 0
	     then goto command_complete;
	     i = arg2 - dot1;			/* Number of characters after DOT. */
	     j = dot1 - arg1;			/* Number of characters before DOT. */
	     if j > 0				/* Print characters before DOT. */
	     then do;
		j = 0;				/* In case there are characters after DOT. */
		if i < 0
		then i = 0;			/* Negative numbers don't work. */
		call WRITE (b1, arg1, count - i);
		end;
	     if i > 0
	     then call WRITE (b2, dot2 - j, i + j);
	     goto command_complete;
	     end;
	else do;					/* (colon_flag = 1) */
	     if num_arg ^= 0
	     then goto too_many_args;
	     call get_quoted_string;
	     call WRITE (quoted_string_address, 0, quoted_string_length);
	     goto command_complete;
	     end;

COMMAND (85):
COMMAND (117):					/* U - Update Q Register */
	current_Q_register_number = get_Q_register_number ();
	immediate_interrupt_ok = "0"b;
	i = current_Q_register_seg_number;
	current_Q_register_seg_number = 0;
	if num_arg = 0
	then do;
	     num_arg = 1;
	     arg1 = max_positive_integer;
	     end;
	current_Q_register_value = arg (num_arg);
	if i ^= 0
	then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
	num_arg = num_arg - 1;
	current_expression = arg (num_arg);
	goto command_return_value;


COMMAND (86):
COMMAND (118):					/* V - who knows? */
						/* V not implemented, but let VW work anyways */
	get_character_fail_handler = command_complete;
	call get_character;
	if current_character = "w"
	then goto VW;
	if current_character = "W"
	then goto VW;
	backup_command_line_1_char = 1;
	goto command_complete;


VW:
	if colon_flag = 0
	then do;
	     call READ_CHAR;
	     current_expression = fixed (unspec (io_char), 9, 0);
	     num_arg = 1;
	     goto command_return_value;
	     end;
	else do;
	     call allocate_Q_register (current_Q_register_number);
	     call READ (current_Q_register_address, 0);
	     current_Q_register_value = read_count;
	     goto command_complete;
	     end;


COMMAND (87):
COMMAND (119):
	goto command_complete;			/* W - Wipe */

COMMAND (88):
COMMAND (120):					/* X - eXtract to Q Register */
	if colon_flag = 0
	then do;
	     if num_arg = 0
	     then arg1 = 1;
	     immediate_interrupt_ok = "0"b;
	     call allocate_Q_register (current_Q_register_number);
	     file_address = current_Q_register_address;
	     EO_X_common_return = normal_X_close_Q_register;
	     start = 1;
	     goto EO_X_common;
normal_X_close_Q_register:
	     current_Q_register_value = count;
	     goto command_complete;
	     end;
	else do;
	     if num_arg ^= 0
	     then goto too_many_args;
	     current_Q_register_number = get_Q_register_number ();
	     if command_level = 0
	     then goto colon_X_not_in_macro;
	     colon_X_save_command_level = command_level;
	     command_char_stack (command_level) = command_char_number;
	     command_length_stack (command_level) = command_line_length;
	     command_iteration_stack (command_level) = iteration_level;
	     iteration_level = base_iteration_level;
	     temp_seg_usage_count (command_seg_stack (command_level)) =
		temp_seg_usage_count (command_seg_stack (command_level)) + 1;
	     call revert_command_level;
	     call get_quoted_string;
	     command_char_stack (command_level) = command_char_number;
	     i, command_seg_stack (command_level + 1) = command_seg_stack (colon_X_save_command_level);
	     immediate_interrupt_ok = "0"b;
	     command_line_address = temp_seg_address (i);
	     command_char_number = command_char_stack (colon_X_save_command_level);
	     command_line_length = command_length_stack (colon_X_save_command_level);
	     base_iteration_level = iteration_level;
	     iteration_level = command_iteration_stack (colon_X_save_command_level);
	     command_level = command_level + 1;
	     temp_seg_usage_count (quoted_string_seg_number) = temp_seg_usage_count (quoted_string_seg_number) + 1;
	     i = current_Q_register_seg_number;
	     current_Q_register_seg_number = quoted_string_seg_number;
	     current_Q_register_value = quoted_string_length;
	     if i ^= 0
	     then temp_seg_usage_count (i) = temp_seg_usage_count (i) - 1;
	     goto command_complete;
	     end;

backslash:
COMMAND (92):
	do;
	     if num_arg = 0
	     then					/* read the decimal number found to the right of the pointer */
		do;
		num_arg = 1;
		current_expression = 0;
		if dot2 = end_buffer
		then goto backslash_0_args_number_not_found;
		j = verify (substr (buffer2, dot2 + 1, end_buffer - dot2), white_space) - 1;
		if j < 0
		then goto backslash_0_args_number_not_found;
		temp_dot, i = dot2 + j;
		current_sign = 1;
		j = index ("+-", substr (buffer2, i + 1, 1));
		if j ^= 0
		then do;
		     i = i + 1;
		     if colon_flag ^= 0
		     then do;
			temp_dot = i;
			if j = 2
			then current_sign = -1;
			end;
		     if i = end_buffer
		     then goto backslash_0_args_number_not_found;
		     end;
		if colon_flag = 0
		then j = verify (substr (buffer2, i + 1, end_buffer - i), "0123456789") - 1;
		else j = verify (substr (buffer2, i + 1, end_buffer - i), "01234567") - 1;
		if j < 0
		then j = end_buffer - i;
		if j = 0
		then goto backslash_0_args_number_not_found;
		i = i + j;
		if colon_flag = 0
		then do;
		     on fixedoverflow
			begin;
			     current_expression = max_positive_integer;
			     goto backslash_0_args_done;
			     end;
		     current_expression = convert (current_expression, substr (buffer2, temp_dot + 1, i - temp_dot));
backslash_0_args_done:
		     revert fixedoverflow;
		     end;
		else do;
		     current_expression = cv_oct_check_ (substr (buffer2, temp_dot + 1, i - temp_dot), error_code);
		     if error_code ^= 0
		     then do;
			error_code = 0;
			current_expression = max_positive_integer;
			end;
		     if current_sign < 0
		     then current_expression = -current_expression;
		     end;
		call move_dot_forward (i - dot2);
		goto command_return_value;
		end;
	     else do;				/* insert arg1 into text and pad with arg2-length(arg1) spaces */
		if colon_flag = 0
		then do;
		     cvb = arg1;
		     i = length (cvb) - verify (cvb, white_space) + 1;
		     if num_arg = 2
		     then i = min (max (i, arg2), length (cvb));
		     call add_chars (addr (substr (cvb, length (cvb) - i + 1, i)), i);
		     end;
		else do;
		     call ioa_$rsnnl ("^o", string, i, arg1);
		     if num_arg = 2
		     then call add_chars (addr (blanks), min (arg2 - i, length (blanks)));
		     call add_chars (addr (string), i);
		     end;
		go to command_complete;
		end;
	     end backslash;

no_room:
	error_message = "NO ROOM ";
	goto print_error_message;
unimplemented_feature:
	error_message = "NOT IMPL";
	goto print_error_message;
label_not_found:
	error_message = "NO LABEL";
	goto print_error_message;
backslash_0_args_number_not_found:
	error_message = "\:NUMBR?";
	goto print_error_message;
A_1_arg_beyond_Z:
dot_beyond_Z:
	error_message = "TOO BIG ";
	goto print_error_message;
A_1_arg_before_0:
bad_negative_argument:
dot_before_0:
	error_message = "NEGATIVE";
	goto print_error_message;
unbalanced_parentheses:
strange_parentheses:
parenthesis_overflow:
	error_message = "PARENS  ";
	goto print_error_message;
skip_fail:
	error_message = "BAD SKIP";
	goto print_error_message;
iteration_overflow:
iteration_underflow:
unfinished_iteration:
semi_colon_out_of_iteration:
	error_message = "BAD LOOP";
	goto print_error_message;
too_many_args:
	error_message = "MANY ARG";
	goto print_error_message;
too_few_args:
	error_message = "FEW ARGS";
	goto print_error_message;
Q_register_pushdown_underflow:
	error_message = "CANT POP";
	goto print_error_message;
Q_register_pushdown_overflow:
command_level_overflow:
string_too_long:
EM_no_slot:
	error_message = "IMP.RES.";
	goto print_error_message;
numeric_quoted_in_Q:
ES_numeric_Q:
M_numeric_Q_register:
	error_message = "numericQ";
	goto print_error_message;
percent_cant_increment:
	error_message = "% ?     ";
	goto print_error_message;
missing_double_quote_command:
QUOTE_COMMAND (0):
	error_message = "BAD ""   ";
	goto print_error_message;
EXTERNAL_COMMAND (0):
	error_message = "BAD E   ";
	goto print_error_message;
missing_Q_register_name:
illegal_Q_register_name:
	error_message = "Qreg ?  ";
	goto print_error_message;
COMMAND (0):
COMMAND (1):
COMMAND (2):
COMMAND (3):
COMMAND (4):
COMMAND (5):
COMMAND (6):
COMMAND (7):
COMMAND (8):
COMMAND (9):
COMMAND (11):
COMMAND (12):
COMMAND (13):
COMMAND (14):
COMMAND (15):
COMMAND (16):
COMMAND (17):
COMMAND (18):
COMMAND (19):
COMMAND (20):
COMMAND (21):
COMMAND (22):
COMMAND (23):
COMMAND (24):
COMMAND (25):
COMMAND (26):
COMMAND (27):
COMMAND (28):
COMMAND (29):
COMMAND (30):
COMMAND (31):
COMMAND (32):
COMMAND (35):
COMMAND (37):
COMMAND (38):
COMMAND (40):
COMMAND (42):
COMMAND (45):
COMMAND (46):
COMMAND (47):
COMMAND (48):
COMMAND (49):
COMMAND (50):
COMMAND (51):
COMMAND (52):
COMMAND (53):
COMMAND (54):
COMMAND (55):
COMMAND (56):
COMMAND (57):
COMMAND (58):
COMMAND (63):
COMMAND (64):
COMMAND (66):
COMMAND (81):
COMMAND (89):
COMMAND (90):
COMMAND (94):
COMMAND (95):
COMMAND (96):
COMMAND (98):
COMMAND (113):
COMMAND (121):
COMMAND (122):
COMMAND (123):
COMMAND (124):
COMMAND (125):
COMMAND (126):
COMMAND (127):
	error_message = current_character || ": ?    ";	/* illegal command */
	goto print_error_message;
illegal_delimiter:
	error_message = delimiter || ":DELIM?";
	goto print_error_message;
tty_no_read:
no_more_temp_segs:
	error_message = "DISASTER";
	goto print_error_message;
args_wrong_order:
	error_message = "ORDER ? ";
	goto print_error_message;
missing_right_operand:
colon_X_not_in_macro:
	error_message = "?       ";
	goto print_error_message;
F_COMMAND (0):
	error_message = "BAD F   ";
	goto print_error_message;
EM_macro_not_found:
ES_subroutine_not_found:
file_error:
	call check_errset;
	call com_err_ (error_code, program_name, quoted_string);
	goto command_abort;
fatal_S_fail:
	error_message = "S: fail ";
	goto print_error_message;
print_error_message:
	call check_errset;
	if error_mode = "long"
	then call teco_error (error_message);
	else call WRITE (addr (error_structure), 0, length (error_message) + 1);
	goto command_abort;

read_line:
     procedure;
	do while ("1"b);
	     call READ (command_line_address, command_line_length);
	     command_line_length = command_line_length + read_count;
	     if command_line_length >= 2		/* See if this line ended with "$". */
	     then if substr (command_line, command_line_length - 1, 1) = "$"
		then do;
		     command_line_length = command_line_length - 2;
						/* leave out the $<nl> */
		     return;
		     end;
	     end;
     end read_line;

get_character:
     procedure;					/*  modifies current_character, io_char, and */
						/* command_char_number. */
	command_char_number = command_char_number - backup_command_line_1_char;
	do while (command_char_number >= command_line_length);
	     if command_level = 0
	     then goto get_character_fail_handler;
	     call revert_command_level;
	     end;
	current_character = substr (command_line, command_char_number + 1, 1);
	io_char = current_character;
	if trace_flag
	then if backup_command_line_1_char = 0
	     then call WRITE (io_char_address, 0, 1);
	command_char_number = command_char_number + 1;
	backup_command_line_1_char = 0;
	return;

print_command_line:
     entry;
	search_successful = search_length ^= 0;
	if ^search_successful
	then search_length = command_line_length - command_char_number;
	if trace_flag
	then call WRITE (command_line_address, command_char_number, search_length);
	command_char_number = command_char_number + search_length;
	return;

find_character:
     entry;
	do while (command_char_number >= command_line_length);
	     if command_level = 0
	     then goto get_character_fail_handler;
	     call revert_command_level;
	     end;
     end get_character;

check_errset:
     procedure;
	if iteration_level > 0
	then do;
	     do return_iteration_level = iteration_level by -1 to 1 while (^iteration.errset (return_iteration_level));
		end;
	     if return_iteration_level = 0
	     then return;
	     do while (return_iteration_level <= base_iteration_level);
		call unwind_command_level;
		end;
	     call unwind_iteration (return_iteration_level - 1);
	     iteration_answer = 0;
	     goto get_out_of_iteration;
	     end;
	return;
     end check_errset;

revert_command_level:
     procedure;
dcl  save_interrupt_ok bit (1) aligned;
	if iteration_level ^= base_iteration_level
	then goto unfinished_iteration;
unwind_command_level:
     entry;
	save_interrupt_ok = immediate_interrupt_ok;
	immediate_interrupt_ok = "0"b;
	command_level = command_level - 1;
	temp_seg_usage_count (command_seg_stack (command_level + 1)) =
	     temp_seg_usage_count (command_seg_stack (command_level + 1)) - 1;
	command_line_address = temp_seg_address (command_seg_stack (command_level));
	command_char_number = command_char_stack (command_level);
	command_line_length = command_length_stack (command_level);
	base_iteration_level = command_iteration_stack (command_level);
	immediate_interrupt_ok = save_interrupt_ok;
     end revert_command_level;


unwind_iteration:
     procedure (return_iteration_level);
dcl  return_iteration_level fixed bin (24);
	iteration_level = return_iteration_level;
	if iteration_level < base_iteration_level
	then goto unfinished_iteration;
	if iteration.end (iteration_level + 1) >= 0
	then command_char_number = iteration.end (iteration_level + 1);
	else do;
	     command_char_number = iteration.begin (iteration_level + 1);
	     call skip ("<>");
	     end;
	return;
     end unwind_iteration;


skip:
     procedure (search_chars);
dcl  search_chars char (2) aligned;
	trace_flag = "0"b;
skip_with_trace:
     entry (search_chars);
	skip_count = 0;
	get_character_fail_handler = skip_fail;
	do while ("1"b);
	     search_length = search (substr (command_line, command_char_number + 1), search_chars);
	     call print_command_line;
	     if search_successful
	     then if substr (command_line, command_char_number, 1) = substr (search_chars, 2, 1)
		then do;				/* Must search ending character first or "!" search fails. */
		     skip_count = skip_count - 1;
		     if skip_count < 0		/* First unmatched end wins. */
		     then do;
			trace_flag = trace_flag_copy;
			return;
			end;
		     end;
		else skip_count = skip_count + 1;
	     call find_character;
	     end;
     end skip;

	/* These entry points count lines either forward or in reverse. They change j, arg1, temp_dot, and count. */

must_find_line_forward:
     procedure;
dcl  must_find bit (1) aligned;

	must_find = "1"b;
	if "0"b
	then do;
find_line_forward:
     entry;
	     must_find = "0"b;
	     end;
	temp_dot = dot2;
	count = end_buffer - dot2;			/* Length if not all lines are found. */
	do arg1 = 1 to arg1;			/* arg1 is count of lines. */
	     if temp_dot >= end_buffer		/* Obviously no more lines. */
	     then if must_find
		then goto dot_beyond_Z;
		else return;
	     j = index (substr (buffer2, temp_dot + 1, end_buffer - temp_dot), new_line_char);

	     if j = 0
	     then temp_dot = end_buffer;
	     else temp_dot = temp_dot + j;
	     end;
	count = temp_dot - dot2;			/* Length of characters included. */
	return;

must_find_line_reverse:
     entry;
	must_find = "1"b;
	if "0"b
	then do;
find_line_reverse:
     entry;
	     must_find = "0"b;
	     end;
	temp_dot = dot1;
	do arg1 = 1 to 1 - arg1;			/* arg1 is negative count. */
	     j = 1;
	     if temp_dot > 0
	     then do;
		j = index (reverse (substr (buffer1, 1, temp_dot)), new_line_char);
		if j = 0
		then j = temp_dot + 1;
		end;
	     temp_dot = temp_dot - j;
	     end;
	temp_dot = temp_dot + 1;
	if temp_dot >= 0
	then return;
	if must_find
	then goto dot_before_0;
	temp_dot = 0;
     end /* find_line */;

get_quoted_string:
     procedure;					/* procedure returns quoted_string */
dcl  save_immediate_interrupt_ok bit (1) aligned,
     (quote_name, quote_seg, old_seg) fixed bin (24);

	call get_character;
	delimiter = current_character;
	if delimiter = "q"
	then goto quoted_string_in_Q_register;
	if delimiter = "Q"
	then goto quoted_string_in_Q_register;
	if delimiter >= "a"
	then if delimiter <= "z"
	     then goto illegal_delimiter;
	if delimiter >= "0"
	then if delimiter <= "9"
	     then goto illegal_delimiter;
	if delimiter >= "A"
	then if delimiter <= "Z"
	     then goto illegal_delimiter;
	quote_name = quoted_string_Q_register_number;
	call allocate_Q_register_have_number (quote_name);
	get_character_fail_handler = no_quoting_delimiter;
	do while ("1"b);
	     j = command_char_number;			/* command_char_number is changed by "print_command_line". */
	     search_length = index (substr (command_line, j + 1, command_line_length - j), delimiter);
	     call print_command_line;
	     i = search_length - fixed (search_successful, 1, 0);
						/* Don't count delimiter. */
	     if i > 0
	     then do;
		if quoted_string_length + i > max_seg_size
		then goto string_too_long;
		substr (quoted_string, quoted_string_length + 1, i) = substr (command_line, j + 1, i);
		quoted_string_length = quoted_string_length + i;
		end;
	     if search_successful
	     then return;
	     call find_character;
	     if "0"b
	     then do;
no_quoting_delimiter:
		command_line_length = command_line_length + 2;
		call read_line;
		end;
	     end;

quoted_string_in_Q_register:
	quote_name = get_Q_register_number ();
	quote_seg = Q_register_seg_number (quote_name);
	if quote_seg = 0
	then goto numeric_quoted_in_Q;
	save_immediate_interrupt_ok = immediate_interrupt_ok;
	immediate_interrupt_ok = "0"b;
	temp_seg_usage_count (quote_seg) = temp_seg_usage_count (quote_seg) + 1;
	old_seg = quoted_string_seg_number;
	quoted_string_seg_number = quote_seg;
	quoted_string_length = Q_register_value (quote_name);
	temp_seg_usage_count (old_seg) = temp_seg_usage_count (old_seg) - 1;
	immediate_interrupt_ok = save_immediate_interrupt_ok;
     end get_quoted_string;

	/* Procedure gets and checks the Q-register specified. */
get_Q_register_number:
     procedure () returns (fixed bin (24));
dcl  Q_number fixed bin (24);
	get_character_fail_handler = missing_Q_register_name;
	call get_character;
	Q_number = fixed (unspec (io_char), 9, 0);
	if Q_number < lbound (Q_register_value, 1)
	then goto illegal_Q_register_name;
	if Q_number >= hbound (Q_register_value, 1)
	then goto illegal_Q_register_name;
	return (Q_number);
     end get_Q_register_number;


	/* procedure allocates a string register when required. */
allocate_Q_register:
     procedure (alloc_name);				/* Enter here if Q-reg name is unknown. */
dcl  (alloc_name, alloc_seg) fixed bin (24),
     save_immediate_interrupt_ok bit (1) aligned;
	alloc_name = get_Q_register_number ();

allocate_Q_register_have_number:
     entry (alloc_name);				/* Enter here if Q-reg name is known. */
	save_immediate_interrupt_ok = immediate_interrupt_ok;
	immediate_interrupt_ok = "0"b;
	alloc_seg = Q_register_seg_number (alloc_name);
	if alloc_seg = 0
	then goto must_allocate_Q_register;
	temp_seg_usage_count (alloc_seg) = temp_seg_usage_count (alloc_seg) - 1;
	if temp_seg_usage_count (alloc_seg) ^= 0
	then do;
must_allocate_Q_register:
	     alloc_seg = number_reserved_temp_segs;
find_free_seg:
	     do;
		if alloc_seg >= hbound (temp_seg_address, 1)
		then goto no_more_temp_segs;
		alloc_seg = alloc_seg + 1;
		if temp_seg_usage_count (alloc_seg) ^= 0
		then goto find_free_seg;
		end find_free_seg;
	     Q_register_seg_number (alloc_name) = alloc_seg;
	     if temp_seg_address (alloc_seg) = null
	     then					/* Formerly test for zero. See its dcl. */
		do;
		call get_temp_seg_ (my_id, rwa_access, temp_seg_address (alloc_seg), error_code);
		if error_code ^= 0
		then goto no_more_temp_segs;
		end;
	     end;
	temp_seg_usage_count (alloc_seg) = 1;
	Q_register_value (alloc_name) = 0;
	immediate_interrupt_ok = save_immediate_interrupt_ok;
     end allocate_Q_register;

READ:
     procedure (buffer_pointer, offset);
dcl  buffer_pointer ptr,
     (offset, length) fixed bin (24);

	p = buffer_pointer;
	if offset ^= 0
	then p = addr (substr (p -> file, offset + 1, 1));
	call iox_$get_line (iox_$user_input, p, max_seg_size - offset, read_count, error_code);
in_chk:
	if error_code ^= 0
	then goto io_diaster;
	if read_count = 0
	then goto tty_no_read;
	return;

READ_CHAR:
     entry;
	call iox_$get_chars (iox_$user_input, io_char_address, 1, read_count, error_code);
	goto in_chk;

WRITE:
     entry (buffer_pointer, offset, length);
	p = buffer_pointer;
	if offset ^= 0
	then p = addr (substr (p -> file, offset + 1, 1));
	call iox_$put_chars (iox_$user_output, p, length, error_code);
	if error_code = 0
	then return;
io_diaster:
	call com_err_ (error_code, program_name);
	goto tty_no_read;
     end READ;


move_dot:
     procedure (char_count, a_accept_error);
dcl  a_accept_error bit (1) aligned,
     accept_error bit (1) aligned init ("0"b),
     (char_count, cc, tc) fixed bin (24);
	accept_error = a_accept_error;
	if char_count > 0				/* Move forward if positive, backward if negative. */
	then do;
move_dot_forward:
     entry (char_count);				/* Count must be positive or a nop. */
	     cc = char_count;
	     if dot2 + cc > end_buffer
	     then if accept_error
		then cc = end_buffer - dot2;
		else goto dot_beyond_Z;
	     if cc <= 0
	     then return;
	     immediate_interrupt_ok = "0"b;
	     if max_dot1 - dot1 < cc			/* Range of shared chars less than move count? */
	     then do;				/* Yes, must move some or all of them. */
		if max_dot1 - dot1 > 0		/* Some chars already moved? */
		then do;				/* Yes, indicate they were moved. */
		     tc = max_dot1 - dot1;
		     dot1 = max_dot1;
		     dot2 = dot2 + tc;
		     cc = cc - tc;
		     end;
		substr (buffer1, dot1 + 1, cc) = substr (buffer2, dot2 + 1, cc);
		max_dot1 = dot1 + cc;		/* Increase upper bound of shared chars. */
		if dot2 + cc = end_buffer
		then goto move_to_b1;		/* If move empties buf2, share buf1. */
		end;
	     end;
	else do;					/* Move count is <0 */
move_dot_backward:
     entry (char_count);				/* Count must be negative or nop. */
	     cc = char_count;
	     if -cc > dot1
	     then if accept_error
		then cc = -dot1;
		else goto dot_before_0;
	     if cc >= 0
	     then return;
	     immediate_interrupt_ok = "0"b;
	     if dot2 - min_dot2 < -cc			/* Range of shared chars less than move count? */
	     then do;				/* Yes, must move some or all of them. */
		if -cc <= dot2			/* Enough room in buf2 to make move? */
		then do;				/* Yes, prefix text to buf2. */
		     if dot2 - min_dot2 > 0		/* Some chars already moved? */
		     then do;			/* Yes, indicate they were moved. */
			tc = dot2 - min_dot2;
			dot1 = dot1 - tc;
			dot2 = min_dot2;
			cc = cc + tc;
			end;
		     substr (buffer2, dot2 + (cc + 1), -cc) = substr (buffer1, dot1 + (cc + 1), -cc);
		     min_dot2 = dot2 + cc;		/* Decrease lower bound of shared chars. */
		     if min_dot2 + (dot1 + cc) = 0	/* Is buf1 empty and new buf2 offset zero? */
		     then do;			/* Yes, share buffer2. */
			max_dot1 = end_buffer;
			b1 = b2;
			n1 = n2;
			end;
		     end;
		else do;				/* No, move all of buf2 to buf1 and share buf1. */
		     if end_buffer - dot2 > 0
		     then substr (buffer1, dot1 + 1, end_buffer - dot2) =
			     substr (buffer2, dot2 + 1, end_buffer - dot2);
move_to_b1:
		     end_buffer, max_dot1 = dot1 + (end_buffer - dot2);
						/* Share buffer1. */
		     b2 = b1;
		     n2 = n1;
		     min_dot2 = 0;
		     dot2 = dot1;
		     end;
		end;
	     end;
	dot1 = dot1 + cc;				/* Indicate move is complete. */
	dot2 = dot2 + cc;
     end move_dot;

	/* Only call this entry to copy from the original segment to teco buffers. */
copy_source:
     procedure;
dcl  ichar char (ic) based unaligned,
     (source, in_ptr) ptr,
     (new_dot1, new_dot2, insert_count, n0, s1, s2, nd2, ic, new_end) fixed bin (24);

	ic = 0;					/* Just copy segment without adding text and */
	s1 = dot1;				/* without deleting text. */
	nd2 = dot2;
	goto copy_text;

	/* Call this entry to delete characters. */
delete_chars:
     entry (new_dot1, new_dot2);
	s1 = new_dot1;				/* Number of characters to be left in buffer1. */
	if s1 < 0
	then goto dot_before_0;			/* Validate our input. */
	nd2 = new_dot2;				/* New value of dot2. */
	if nd2 > end_buffer
	then goto dot_beyond_Z;			/* Validate our input. */
	if s1 = dot1 & nd2 = dot2
	then return;				/* Delete count is zero. Do not change anything. */
	ic = 0;					/* Not adding text. */
	goto copy_text;

	/* Call this entry to add characters. */
add_chars:
     entry (in_ptr, insert_count);
	ic = insert_count;				/* Pick up length of text to be added. */
	if ic = 0
	then return;				/* Length is zero. Do not change anything. */
	s1 = dot1;				/* Existing text will not be changed. */
	nd2 = dot2;
	if s1 + end_buffer - nd2 + ic > max_seg_size
	then goto no_room;				/* Can't add if segment size exceeded. */

copy_text:					/* Text is moved only if b1 = b2. (Shared segment) */
	s2 = end_buffer - nd2;			/* Number of characters to be left in buffer2. */
	immediate_interrupt_ok = "0"b;
	n0 = n1;					/* Useful only if n1 = n2. (b1 = b2) */
	if s2 = 0 | (s1 + ic + nd2) = 0		/* Buf2 empty or (buf1 empty and buf2 starts at 0). */
	then do;
	     n0 = n1;				/* Indicates whether a close is required. */
	     end_buffer, max_dot1 = s1 + s2 + ic;	/* Prepare to share a segment. */
	     min_dot2 = 0;				/* Set total length and range of shared characters. */
	     if n1 = 0				/* Segment is user's segment. Copy it. */
	     then do;				/* The copy will be shared. */
		n1, n2 = 1;			/* Pick an arbitrary temp seg. */
		source = b1;			/* Save pointer to user's segment. */
		b1, b2 = temp_seg_address (1);	/* Get pointer to new buffer. */
		substr (b1 -> buffer1, 1, s1 + s2) = substr (source -> buffer1, 1, s1 + s2);
						/* Copy text. */
		end;
	     else do;				/* Text is in two temp segs. Share one. */
		if s2 > 0				/* All text in second buffer? */
		then n1 = n2;			/* Yes, share it. */
		else n2 = n1;			/* No, all in first so share it. */
		b1, b2 = temp_seg_address (n1);	/* Set both buffer pointers. */
		end;
	     end;
	else do;					/* Text in both buffers or can't share buffer2. */
	     max_dot1 = s1 + ic;			/* Shared text limits are current text position. */
	     min_dot2 = nd2;			/* nd2 is still correct (end_buffer has not changed). */
	     if n1 = n2				/* Text must be move only if sharing a segment. */
	     then do;
		if n1 = 0				/* Shared segment is not temp seg. Move all text. */
		then do;
		     n1 = 1;
		     n2 = 2;
		     end;
		else if s1 < s2			/* Otherwise, move shorter piece of text. */
		then n1 = 3 - n2;
		else n2 = 3 - n1;
		source = b1;			/* Save pointer to original segment. */
		b1 = temp_seg_address (n1);		/* Assign new temp segments. */
		b2 = temp_seg_address (n2);
		if s1 > 0 & n0 ^= n1		/* New seg for buf1 and text in buf1. */
		then do;
		     substr (b1 -> buffer1, 1, s1) = substr (source -> buffer1, 1, s1);
		     end;
		if s2 > 0 & n0 ^= n2		/* New seg for buf2 and text in buf2. */
		then do;
		     new_end = min (divide (s1 + s2 + ic + 512 + 4095, 4096, 17, 0) * 4096, max_seg_size);
		     if n1 ^= n2
		     then min_dot2 = new_end - s2;	/* Change shared limit only if not shared. */
		     substr (b2 -> buffer2, new_end - s2 + 1, s2) =
			substr (source -> buffer2, end_buffer - s2 + 1, s2);
		     end_buffer = new_end;
		     end;
		end;
	     end;

	dot1 = s1 + ic;
	dot2 = end_buffer - s2;			/* Works even if end_buffer is changed. */

	if ic > 0
	then substr (b1 -> buffer1, s1 + 1, ic) = substr (in_ptr -> ichar, 1, ic);

	if n0 = 0
	then goto close_a_file;
	return;

close_file:
     entry (in_ptr);
	source = in_ptr;

close_a_file:
	if source = null
	then return;
	call release_seg_ptr_ (source, -1, error_code);
	if error_code ^= 0
	then goto file_error;
     end copy_source;
     end TECO;




		    teco_backup_file_.pl1           11/15/82  1907.0rew 11/15/82  1526.7       23643



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


teco_backup_file_: proc (file);

/* Recoded by REMullen 8/20/73 to replicate
   call copy (file, file||.bak) */

dcl  file char (*);

dcl (d1, d2) char (168) aligned;			/* dirnames */
dcl  bdir char (168) aligned based;
dcl (dirptr, entptr) ptr;
dcl (e1, e2) char (32) aligned;			/* entrynames */
dcl  bent char (32) aligned based;
dcl  code fixed bin (35);				/* standard system status code */
dcl  e1_len fixed bin;				/* length of first ename */
dcl  dot_len fixed bin;				/* length of first component of same */

dcl  errname char (4) aligned init ("TECO");		/* for nd_handler's question */


dcl  com_err_ ext entry options (variable);
dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl  copy_seg_ ext entry (char (*) aligned, char (*) aligned, char (*) aligned,
     char (*) aligned, char (*) aligned, bit (1) aligned, fixed bin (35));

dcl  get_wdir_ ext entry () returns (char (168) aligned);
dcl  which_bit bit (1) aligned;			/* 0 means err in d1>e1, 1 means d2>e2 */


dcl (min, substr, index, addr, length) builtin;

/* --------------------------------------------------------- */


	call expand_path_ (addr (file), length (file), addr (d1), addr (e1), code);
	if code ^= 0 then do;
	     call com_err_ (code, errname, file);
	     return;
	end;

	e1_len = index (e1, " ");
	if e1_len = 0 then e1_len = 32;		/* were no blanks */
	else e1_len = e1_len -1;			/* last char was just before blank */

	dot_len = index (e1, ".");			/* only want first component in any case */
	if dot_len = 0 then dot_len = 32;
	else dot_len = dot_len -1;

	e1_len = min (e1_len, dot_len);

	e2 = substr (e1, 1, e1_len) || ".bak";		/* make backup files name */

	d2 = get_wdir_ ();				/* it will go in working directory */

	call copy_seg_ (d1, e1, d2, e2, errname, which_bit, code); /* try to make copy */
	if code ^= 0 then do;
	     if which_bit = "1"b then do;
		dirptr = addr (d2);
		entptr = addr (e2);
	     end;
	     else do;
		dirptr = addr (d1);
		entptr = addr (e1);
	     end;
	     call com_err_ (code, errname, "^a>^a", dirptr -> bdir, entptr -> bent); /* lose */
	end;
	return;
     end;




		    teco_error.pl1                  11/15/82  1907.0rew 11/15/82  1526.7       22536



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


teco_error: proc (error_string);

dcl  error_string char (*) unal;
declare	error_messages(22) char(64) internal static initial(
/*	 <-  8 -><-		      56			   -> */
	"S: fail Search failed.",
	"NO ROOM Text insertion would exceed maximum segment size.",
	"NOT IMPLUnimplemented feature or command.",
	"NO LABELLabel not found.",
	"TOO BIG Reference is beyond end of text.",
	"NEGATIVEReference is before beginning of text.",
	"PARENS  Too many parentheses, or misplaced parenthesis.",
	"BAD LOOPInfinite loop, or misplaced <, >, or ;.",
	"MANY ARGToo many arguments.",
	"FEW ARGSToo few arguments.",
	"IMP.RES.Too many pushes or macros, or quoted string too long.",
	"numericQThis Q-register must contain text.",
	"% ?     This Q-register must not contain text.",
	"BAD ""   Illegal double quote command.",
	"BAD E   Illegal external command.",
	"Qreg ?  Missing or illegal Q-register name.",
	"DISASTERCannot read from teletype or out of storage.",
	"ORDER ? Arguments given in the wrong order.",
	"?       Syntax error in expression or :X not in macro.",
	"\:NUMBR?Number does not appear following text pointer.",
	"CANT POPPushdown stack empty - cannot pop.",
	"BAD SKIPCharacter not found. Could not skip to >, ', or !.");

dcl  (hbound, length, substr) builtin;
dcl	message char(56);
dcl	name char(8) aligned;
dcl  i fixed bin;
dcl  ioa_ ext entry options (variable);

	name = error_string;			/* Get exactly eight characters. */
	if substr (name, 2) = ": ?    " then do;
	     message = "^a: illegal command.";
	     goto print_message;
	end;
	if substr (name, 2) = ":DELIM?" then do;
	     message = "^a: illegal quoting character.";
	     goto print_message;
	end;

	do i = 1 to hbound(error_messages, 1);

	     if name = substr(error_messages(i), 1, length(name)) then do;
		message = substr(error_messages(i), length(name)+1);
		goto print_message;
	     end;
	end;

	message = "Error message not recognized.";
print_message:
	call ioa_(message, substr(name, 1, 1));
	return;
     end;




		    teco_get_macro_.pl1             11/15/82  1907.0rew 11/15/82  1526.7       40716



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


teco_get_macro_: procedure (macro_name, macro_address, macro_length, return_code);

/*	This procedure implements teco's search rules. There are several entry points:

teco_get_macro_ - This entry point is called by teco to get a pointer to an external macro
   for an "em" command.

teco_search - This entry point may be called using an "es" command and returns the full pathname
   of an external macro.

teco_ssd - This entry point may be invoked as a command to change the second directory searched.
   If this entry point is not invoked or if the argument is a null string, the user's home directory
   will be searched.

The directories searched by teco_get_macro_ are:

		1. the current working directory
		2. the user's  directory, or any user specified directory
		3. the containing directory for teco (called the teco library directory)

   Date last modified and reasons:
   06/19/75 by David Levin to clean up and fix bugs
   04/18/75 by David Levin to remove imbedded pathnames
   04/21/72 by Peter Bishop to add teco_search and teco_ssd entries
   06/27/71 by Richard H. Gumpertz for initial implementation
   */


	get_macro_entry_flag = "1"b;
	arglen = length(macro_name);
	goto start_work;

/* Secondary entry points. */
teco_ssd: entry;
	call cu_$arg_ptr(1, argptr, arglen, code);
	if code ^= 0
	then do;
	     call com_err_(code, "teco_ssd");
	     return;
	     end;
	dir_name(2) = search_dir;
	return;


teco_search: entry (macro_name, arg1, arg2, current_expression);
	get_macro_entry_flag = "0"b;
	arglen = index(macro_name, " ") - 1;

/* Parameters - teco_get_macro_ */
dcl
	macro_name	char(*) aligned,		/* Macro name without "teco" suffix. (input) */
	macro_address	pointer,			/* Pointer to segment containing the macro. (output) */
	macro_length	fixed bin(24),		/* Character length of segment. (output) */
	return_code	fixed bin(35);		/* Error code. (output) */

/* Parameters - teco_search */
dcl
						/* First argument declared above. (input/output) */
						/* Macro name without "teco" suffix. (input) */
						/* Full pathname of segment. (output) */
	(arg1, arg2)	fixed bin(24),		/* not used */
	current_expression	fixed bin(24);		/* Length of pathname. (output) */

/* Based */
dcl
	search_dir char(arglen) based(argptr);

/* Automatic */
dcl
	arglen		fixed bin,
	argptr		ptr,
	bit_count		fixed bin(24),
	code		fixed bin(35),
	entry_name	char(32) aligned,
	get_macro_entry_flag bit(1) aligned,
	i		fixed bin,
	temp_ptr		ptr;

/* External Entries */
dcl
	com_err_ entry options(variable),
	cu_$arg_ptr entry(fixed bin, ptr, fixed bin, fixed bin(35)),
	get_seg_ptr_full_path_ entry(char(*), char(*) aligned, bit(6) aligned, fixed bin(24), ptr, fixed bin(35)),
	get_wdir_ entry() returns(char(168)),
	hcs_$fs_get_path_name entry(entry, char(*), fixed bin, char(*) aligned, fixed bin(35)),
	ioa_$rsnnl entry options(variable),
	user_info_$homedir entry(char(*));

/* Internal Static */
dcl
	r_access bit(6) aligned initial("010000"b) internal static,
	dir_name(3) char(168) initial((3) (168) " ") internal static;

dcl	(divide, hbound, index, length, null, reverse, substr) builtin;

start_work:
	dir_name(1) = get_wdir_();

	if substr(dir_name(2), 1, 4) = "    " then call user_info_$homedir(dir_name(2));

	if substr(dir_name(3), 1, 4) = "    "
	then call hcs_$fs_get_path_name(teco_get_macro_, dir_name(3), i, entry_name, code);

	entry_name = substr(macro_name, 1, arglen);
	substr(entry_name, arglen+1, 5) = ".teco";

	do i = 1 to hbound(dir_name, 1);
	     call get_seg_ptr_full_path_ (dir_name (i), entry_name, r_access, bit_count, temp_ptr, code);
	     if temp_ptr ^= null
	     then if get_macro_entry_flag
		then do;
		     macro_address = temp_ptr;
		     macro_length = divide(bit_count+8, 9, 17, 0);
		     return_code = code;
		     return;
		     end;
		else do;
		     call ioa_$rsnnl("^a>^a", macro_name, current_expression, dir_name(i), entry_name);
		     return;
		     end;
	     end;
	if get_macro_entry_flag then return_code = code;
     end teco_get_macro_;




		    get_temp_seg_.pl1               11/05/86  1509.8r w 11/04/86  1042.7       71370



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




/****^  HISTORY COMMENTS:
  1) change(86-10-17,Margolin), approve(86-10-17,MCR7549),
     audit(86-10-21,Lippard), install(86-10-30,MR12.0-1203):
     Module moved to bound_teco_ without change, but the installation tools
     demand a history comment.  Better not to anger the gods.
                                                   END HISTORY COMMENTS */


get_temp_seg_: procedure (a_id, a_acl, a_ptr, a_code);

/*	This procedure manages scratch segments in the user's
   process directory. It is absolutely immune to "quit"s
   and other methods of getting unexpected recursion. That
   is, one may quit out of get_temp_seg_, hold, and
   then call get_temp_seg_ again without risk of using
   the same segment twice.
   */
/*	Last modified (Date and reason):
   by RHG on 17 July 1971 to redefine calls to be more usable by recursive procedures
   by Richard H. Gumpertz on 10 July 1971 for initial implementation
   */
/*  */
	declare a_id bit (36) aligned,
	a_acl bit (5) aligned,
	a_ptr ptr,
	a_code fixed bin (35);

	declare name_buffer char (32) aligned,
	name_len fixed bin,
	name based (addr (name_buffer)) aligned char (name_len);

	declare (i, j) fixed bin,
	p pointer,
	first_time bit (1) aligned init ("1"b) int static,
	process_dir char (168) aligned int static,
	error_code fixed bin(35),
	error_code2 fixed bin(35),
	id bit (36) aligned,
	rings (3) fixed bin,
	acl fixed bin (5);

	declare (addr, bit, fixed, hbound, null, stac, substr, unspec) builtin;

	declare temp_seg_list_ptr init (null) int static ptr,
	1 temp_seg_list (0:4095) based (temp_seg_list_ptr) aligned,
	2 temp_seg,
	3 used bit (36) aligned,
	3 acl fixed bin (5),
	3 ptr ptr,
	2 proc_id,
	3 name char (32) aligned,
	3 stack_ptr ptr,
	3 count fixed bin,
	3 used bit (36) aligned;

	declare hcs_$make_seg entry (char(*) aligned, char(*) aligned, char(*) aligned, fixed bin (5), ptr, fixed bin(35)),
	hcs_$add_acl_entries entry(char(*) aligned, char(*) aligned, ptr, fixed bin, fixed bin(35)),
	hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)),
	cu_$level_get entry () returns (fixed bin),
	cu_$stack_frame_ptr entry () returns (pointer),
	get_group_id_$tag_star entry returns(char(32) aligned),
	get_pdir_ entry () returns (char (168) aligned),
	ioa_$rsnnl entry options (variable);

	declare (error_table_$notalloc, error_table_$not_seg_type) external fixed bin(35);

	declare 1 seg_acl aligned,
	2 access_name char(32),
	2 modes bit(36),
	2 zero_pad bit(36),
	2 error_code fixed bin(35);
						/*  */
%include stack_frame;
/*  */
/* get_temp_seg_:	entry (a_id, a_acl, a_ptr, a_code);	/* remember the proc statement above */
	acl = fixed (a_acl, 5);
	id = a_id;
	a_ptr = null;

	if first_time then call init;

	do i = 0 to hbound (temp_seg, 1);
check_new_seg: if i >= proc_id.count (0) then do;
		proc_id.count (0) = proc_id.count (0) + 1;
		goto check_new_seg;
	     end;
	     if stac (addr (temp_seg.used (i)), id) then do;
		if unspec (temp_seg.ptr (i)) = ""b then	/* get a segment if we don't already have one */
		do;
		     call ioa_$rsnnl ("temp_seg_.^d.^d", name_buffer, name_len, cu_$level_get(), (i));
		     temp_seg.acl (i) = acl;
		     call hcs_$make_seg (process_dir, name, "", acl, p, error_code);
		     if p = null then goto error;
		     temp_seg.ptr (i) = p;
		end;
		else if acl ^= temp_seg.acl (i) then do;
		     call change_acl;
		     if error_code ^= 0 then goto error;
		end;
		a_ptr = temp_seg.ptr (i);

		a_code = 0;
		return;
	     end;
	end;

	a_code = error_table_$notalloc;
	return;
						/*  */
assign_temp_seg_id_: entry (a_proc_id, a_id, a_code);

	declare a_proc_id char (*);

	if first_time then call init;

	do i = 1 to hbound (proc_id, 1);		/* note that i = 0 is illegal */
	     if stac (addr (proc_id.used (i)), "1"b) then
	     do;
		proc_id.name (i) = a_proc_id;
		proc_id.stack_ptr (i) = cu_$stack_frame_ptr () -> stack_frame.prev_sp;
		a_id = bit (fixed (proc_id.count (i), 18), 18) || bit (fixed (i, 18));
		a_code = 0;
		return;
	     end;
	end;

	a_code = error_table_$notalloc;
	a_id = "1"b;				/* just in case he uses it anyways */
	return;
						/*  */
release_temp_seg_: entry (a_id, a_ptr, a_code);

	if first_time then call init;
	id = a_id;
	if id = ""b then id = "1"b;
	p = a_ptr;

	do i = 0 to proc_id.count (0)+1;
	     if temp_seg.ptr (i) = p then		/* release it if this is the one */
	     do;
		if temp_seg.used (i) = id then
		do;
		     acl = 01011b;
		     if temp_seg.acl (i) ^= acl then do;
			call change_acl;
			if error_code ^= 0 then goto error;
		     end;
		     call hcs_$truncate_seg (p, 0, error_code);
		     if error_code ^= 0 then goto error;
		     temp_seg.used (i) = ""b;
		end;
		a_code = 0;
		return;
	     end;
	end;

	a_code = error_table_$not_seg_type;
	return;
						/*  */
release_temp_segs_all_: entry (a_id, a_code);

	a_code = 0;
	id = a_id;
	j = fixed (substr (id, 19, 18), 18);
	if j = 0 then return;
	if first_time then call init;

	do i = 0 to proc_id.count (0)+1;
	     if temp_seg.used (i) = id then
	     do;
		error_code, error_code2 = 0;
		if unspec (temp_seg.ptr (i)) then do;
		     acl = 01011b;
		     if temp_seg.acl (i) ^= acl then call change_acl;
		     if error_code ^= 0 then a_code = error_code;
		     call hcs_$truncate_seg (temp_seg.ptr (i), 0, error_code2);
		     if error_code2 ^= 0 then if error_code = 0 then a_code = error_code2;
		end;
		if error_code = 0 then if error_code2 = 0 then temp_seg.used (i) = ""b;
	     end;
	     if a_code = 0 then if fixed (substr (id, 1, 18), 18) = proc_id.count (j) then do;
		proc_id.count (j) = proc_id.count (j) + 1;
		proc_id.used (j) = ""b;
	     end;
	end;
	return;
						/*  */
list_temporary_segments: list_temp_segs: lts: entry;

	declare none_used bit (1) aligned,
	ioa_ external entry options (variable);

	if first_time then call init;

	none_used = "1"b;
	do i = 0 to proc_id.count (0)+1;
	     if temp_seg.used (i) then		/* print it only if it is in use */
	     do;
		if none_used then			/* print the header the first time only */
		do;
		     call ioa_ ("name		seg_ptr	proc_id		stack	proc_name");
		     none_used = "0"b;
		end;
		j = fixed (substr (temp_seg.used (i), 19, 18), 18);
		call ioa_ ("temp_seg_.^d.^d	^p	^w	^p	^a",
		cu_$level_get(), (i), temp_seg.ptr (i), temp_seg.used (i),
		proc_id.stack_ptr (j), proc_id.name (j));
	     end;
	end;

	if none_used then call ioa_ ("no temporary segments in use");
	return;
						/*  */
init:	proc;
	     process_dir = get_pdir_ ();
	     call ioa_$rsnnl ("temp_seg_.^d.list", name_buffer, name_len, cu_$level_get());
	     call hcs_$make_seg (process_dir, name, "", 1011b, temp_seg_list_ptr, error_code);
	     if temp_seg_list_ptr = null then goto error;
	     proc_id.name (0) = "****no name given***";
	     proc_id.stack_ptr (0) = null;
	     first_time = ""b;
	end init;





change_acl: proc;
	     rings (1), rings (2), rings (3) = cu_$level_get ();
	     call ioa_$rsnnl ("temp_seg_.^d.^d", name_buffer, name_len, cu_$level_get(), (i));
	     temp_seg.acl (i) = -1;			/* just in case we get quit out of */
	     seg_acl.access_name = get_group_id_$tag_star();
	     seg_acl.modes = substr(bit(acl,5), 2, 3);
	     seg_acl.zero_pad = "0"b;
	     call hcs_$add_acl_entries(process_dir, name, addr(seg_acl), 1, error_code);
	     if error_code = 0 then temp_seg.acl (i) = acl;
	end;





error:	a_code = error_code;
	return;
						/*  */
     end;





		    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
