



		    abs_io_.pl1                     08/11/87  1003.9r w 08/11/87  0926.1      257877



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


/* format: style3,idind30,ll122,ifthenstmt */

abs_io_$abs_io_attach:
     procedure (P_iocb_ptr, P_attach_args, P_report_switch, P_status);


/****^  HISTORY COMMENTS:
  1) change(86-03-01,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     Dummy comment for hcom.
     Initial coding: 25 June 1979 by J. Spencer Love
     -no_set_bit_count implemented 07/29/81 S. Herbst
     -login_channel November 1981 Benson I. Margulies
     Added $allocate_abs_data & $initialize_abs_data to be called by absentee_listen_$execute_handler 01/07/83 S. Herbst
     Added -trace, -no_trace, -trace_default to the exec_com command 03/20/84 S. Herbst
  2) change(86-03-27,Gilcrease), approve(86-03-27,MCR7370),
     audit(86-06-23,Lippard), install(86-06-30,MR12.0-1082):
     Add -truncate to absout files. SCP 6297.
  3) change(86-11-11,Gilcrease), approve(86-11-11,PBF7370),
     audit(86-11-12,Fawcett), install(86-11-12,MR12.0-1214):
      PBF: user_info_ should not be called if abs_io_ invoked as
           exec_com.
                                                   END HISTORY COMMENTS */


/* Parameters											*/

declare	P_iocb_ptr		ptr parameter,
	P_attach_args		(*) char (*) varying parameter,
	P_report_switch		bit (1) aligned parameter,
	P_opening_mode		fixed bin parameter,
	P_abs_data_ptr		ptr parameter,
	P_status			fixed bin (35) parameter;

/* Builtins											*/

declare	(addr, addrel, divide, empty, hbound, index, length, ltrim, maxlength, min, null, reverse, rtrim, search, size,
	stackbaseptr, string, substr, unspec, verify)
				builtin;

declare	(any_other, area, bad_area_format, bad_area_initialization, cleanup)
				condition;

/* Automatic											*/

declare	abs_entry			bit (1) aligned,
	arg_count			fixed bin,
	arg_str			char (100),
	attach_description_ptr	ptr,
	first_arg			fixed bin,
	idx			fixed bin,
	initialized		bit (1),
	iocb_ptr			ptr,
	login_channel_sw		bit (1),
	mask			bit (36),
	masked_sw			bit (1) init ("0"b),
	no_set_bc_sw		bit (1),
	output_arg		fixed bin,
	path_arg			fixed bin,
	status			fixed bin (35),
	whoami			char (32) varying;

declare	1 area_data		aligned like area_info;
%page;
/* Constants */

declare	NL			char (1) static options (constant) initial ("
");
declare	WHITE			char (5) static options (constant) initial ("
	 ");					/* FF VT NL TAB SPACE				*/

/* Static												*/

declare	1 unable_to_do_io		aligned static,
	  2 version		fixed bin initial (0),
	  2 status_code		fixed bin (35);

/* Based												*/

declare	attach_descrip		char (400) varying;
declare	attach_description		char (length (attach_descrip)) varying based (attach_description_ptr)
				initial (attach_descrip);
declare	allocated_chars		char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr);
declare	ec_path			char (abs_data.ec_path_len) based (abs_data.ec_path_ptr);
declare	input_file		char (input_string.len) based (input_string.ptr);
declare	sys_area			area based (get_system_free_area_ ());

/* External											*/

declare	abs_io_data_chain_ptr_	ptr external init (null ());

declare	(
	error_table_$noalloc,
	error_table_$notalloc,
	error_table_$bad_mode,
	error_table_$badopt,
	error_table_$badpath,
	error_table_$entlong,
	error_table_$inconsistent,
	error_table_$noarg,
	error_table_$not_detached,
	error_table_$unable_to_do_io,
	error_table_$unimplemented_version
	)			fixed bin (35) external;
%page;
declare	abs_io_control		entry (ptr, char (*), ptr, fixed bin (35));
declare	abs_io_control$close	entry (ptr);
declare	abs_io_control$set_arguments	entry (ptr, (*) char (*) varying, fixed bin, fixed bin (35));
declare	abs_io_put_chars		entry (ptr, ptr, fixed bin (21), fixed bin (35));
declare	abs_io_put_chars$close	entry (ptr, fixed bin (35));
declare	abs_io_put_chars$open	entry (ptr, char (*), char (*), bit (1), bit (1), fixed bin (35));
declare	abs_io_v1_get_line		entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
declare	abs_io_v2_get_line		entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
declare	cv_dec_check_		entry (char (*), fixed bin (35)) returns (fixed bin (35));
declare	cu_$set_cl_intermediary	entry (entry);
declare	define_area_		entry (ptr, fixed bin (35));
declare	expand_pathname_		entry (char (*), char (*), char (*), fixed bin (35));
declare	get_system_free_area_	entry () returns (ptr);
declare	hcs_$initiate_count		entry options (variable);
declare	hcs_$reset_ips_mask		entry (bit (36), bit (36));
declare	hcs_$set_ips_mask		entry (bit (36), bit (36));
declare	hcs_$set_max_length_seg	entry (pointer, fixed bin (19), fixed bin (35));
declare	hcs_$terminate_noname	entry (ptr, fixed bin (35));
declare	iox_$destroy_iocb		entry (ptr, fixed bin (35));
declare	iox_$propagate		entry (ptr);
declare	pathname_			entry (char (*), char (*)) returns (char (168));
declare	release_area_		entry (ptr);
declare	requote_string_		entry (char (*)) returns (char (*));
declare	user_info_$absout		entry (char (*));
declare	user_info_$absin		entry (char (*));
declare	user_info_$login_arg_count	entry (fixed bin, fixed bin (21), fixed bin (21));
declare	user_info_$login_arg_ptr	entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
%page;
/* abs_io_$abs_io_attach:
       procedure (P_iocb_ptr, P_attach_args, P_report_switch, P_status)					*/

	abs_entry = "1"b;
	whoami = "abs_io_";

	go to COMMON;

ec_input_$ec_input_attach:
     entry (P_iocb_ptr, P_attach_args, P_report_switch, P_status);

	abs_entry = "0"b;
	whoami = "ec_input_";

COMMON:
	if unable_to_do_io.status_code = 0 then unable_to_do_io.status_code = error_table_$unable_to_do_io;

	abs_data_ptr = null ();			/* Preset automatic before installing cleanup handler	*/
	initialized = "0"b;
	mask = ""b;

	on cleanup call clean_up ();

	call allocate_abs_data;
%page;
/* Fill in all pointers as null before enabling cleanup of things within abs_data				*/

	call initialize_abs_data;

	abs_data.allocated_chars_ptr, abs_data.else_clause_ptr, abs_data.chars_ptr = null;
	abs_data.instance_chain.prev_ptr, abs_data.instance_chain.next_ptr = null;
	abs_data.expand_data_ptr, abs_data.ec_data_ptr, abs_data.variables_ptr = null;
	abs_data.command_line.iocb, abs_data.comment_line.iocb,
	     abs_data.control_line.iocb, abs_data.input_line.iocb = null;
	abs_data.output_file.fcb_ptr, abs_data.output_file.seg_ptr, abs_data.input_string.ptr = null;

	arg_info.arg_ptr, arg_info.default_arg_ptr, arg_info.ec_name_ptr, arg_info.ec_path_ptr = null;

	initialized = "1"b;
%page;
/* Get some of the arguments */

	arg_count = hbound (P_attach_args, 1);		/* get size of option array				*/

	first_arg, output_arg, path_arg = 0;
	login_channel_sw, no_set_bc_sw = "0"b;

	do idx = 1 to arg_count while (first_arg = 0);

	     arg_str = P_attach_args (idx);
	     if index (arg_str, "-") = 1 then do;	/* control arg */

		if arg_str = "-argument" | arg_str = "-ag" then first_arg = idx + 1;

		else if arg_str = "-no_set_bit_count" | arg_str = "-nsbc" then no_set_bc_sw = "1"b;
		else if arg_str = "-set_bit_count" | arg_str = "-sbc" then no_set_bc_sw = "0"b;

		else if abs_entry & arg_str = "-login_channel" then login_channel_sw = "1"b;
		else if arg_str = "-output_file" | arg_str = "-of"
		then if output_arg ^= 0 then call error (0, whoami, "-output_file specified twice.");
		     else if idx = arg_count then call error (0, whoami, "No value specified for -output_file");
		     else output_arg, idx = idx + 1;

		else if arg_str = "-pathname" | arg_str = "-pn"
		then if path_arg ^= 0 then call error (0, whoami, "More than one pathname specified.");
		     else if idx = arg_count then call error (0, whoami, "No value specified for -pathname");
		     else path_arg, idx = idx + 1;

		else if abs_entry & (arg_str = "-single_segment_file" | arg_str = "-ssf") then open_data.ssf = "1"b;

		else if abs_entry & (arg_str = "-truncate" | arg_str = "-tc") then open_data.truncate = "1"b;

		else call error (error_table_$badopt, whoami, "^a", arg_str);
	     end;

	     else if path_arg = 0 then path_arg = idx;
	     else first_arg = idx;
	end;

	if login_channel_sw
	then if path_arg > 0 | first_arg > 0 | output_arg > 0
	     then call error (error_table_$inconsistent, whoami, "-login_channel and other arguments.");
	     else ;
	else if path_arg = 0 then call error (error_table_$noarg, whoami, "Input file pathname.");

	if first_arg = 0 then first_arg = arg_count + 1;

	on area call error (error_table_$noalloc, whoami, "In per-invocation area.");

	if abs_entry
	then do;
		if login_channel_sw
		then call initiate_input_file_login_channel;
		else do;
			if first_arg > arg_count then call error (error_table_$noarg, whoami, "Input file.");
			call initiate_input_path (first_arg);
			first_arg = first_arg + 1;
		     end;
	     end;
	else call initiate_input_path (path_arg);

/* Determine version of input file */

	if substr (input_file, 1, min (8, input_string.len)) ^= "&version" | search (input_file, WHITE) ^= 9
	then do;
		open_data.parser_version = 1 /* Default_version */;
		input_string.start, input_string.limit = 0;
	     end;
	else do;
		idx = index (substr (input_file, 9), NL);
		if idx = 0
		then call error (error_table_$unimplemented_version, whoami, "Newline must end &version statement.");
		if verify (substr (input_file, 9, idx - 1), WHITE) = 0
		then call error (error_table_$unimplemented_version, whoami,
			"No version given in &version statement.");
		open_data.parser_version =
		     cv_dec_check_ (ltrim (rtrim (substr (input_file, 10, idx - 2), WHITE), WHITE), status);
		if status ^= 0 | open_data.parser_version < 1 /* Lowest_version */ | open_data.parser_version > 2
						/* Highest_version */
		then call error (error_table_$unimplemented_version, whoami, "&version ""^a""",
			substr (input_file, 10, idx - 2));
		if open_data.parser_version = 1 then input_string.start, input_string.limit = idx + 8;
		else input_string.start, input_string.limit = idx + 9;  /* v2 likes to start at first char */
	     end;
%page;
	if ^login_channel_sw
	then if first_arg > 0 & first_arg <= arg_count
	     then do;
		     call abs_io_control$set_arguments (abs_data_ptr, P_attach_args (*), first_arg, status);
		     if status ^= 0
		     then call error (status, whoami, "Setting arguments:^vs^(^/^a^)", first_arg - 1,
			     P_attach_args (*));
		end;
	     else ;
	else call process_login_arguments;

/* Fill in defaults											*/

	abs_data.absentee = abs_entry;
	abs_data.login_channel = login_channel_sw;
	open_data.sio = abs_data.absentee;
	open_data.si = ^abs_data.sio;

	call set_trace_defaults ();

/* generate attach description									*/

	attach_descrip = whoami;
	if ^login_channel_sw then attach_descrip = attach_descrip || " " || requote_string_ (ec_path);
	if output_arg > 0
	then do;
		attach_descrip = attach_descrip || " -of ";
		if abs_data.output_dir ^= ">" then attach_descrip = attach_descrip || rtrim (abs_data.output_dir);
		attach_descrip = attach_descrip || ">";
		attach_descrip = attach_descrip || rtrim (abs_data.output_entry);
	     end;
	if open_data.truncate then attach_descrip = attach_descrip || " -truncate";
	if open_data.ssf then attach_descrip = attach_descrip || " -ssf";
	if login_channel_sw then attach_descrip = attach_descrip || " -login_channel";

	allocate attach_description in (abs_data.work_area);

	revert area;
%page;
/* Now mask down and diddle with IOCB...								*/

	on any_other call any_other_handler;

	call hcs_$set_ips_mask (mask, mask);
	masked_sw = "1"b;

	revert cleanup;

	iocb_ptr = P_iocb_ptr;

	if iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	then call error (error_table_$not_detached, whoami, "IOCB ""^a"" at ^p already attached.",
		iocb_ptr -> iocb.name, iocb_ptr);

	iocb_ptr -> iocb.attach_data_ptr = abs_data_ptr;
	iocb_ptr -> iocb.control = abs_io_control;
	iocb_ptr -> iocb.attach_descrip_ptr = attach_description_ptr;
						/* When this is done, we are attached, sort of		*/

	instance_chain.next_ptr = null ();
	instance_chain.prev_ptr = abs_io_data_chain_ptr_;
	abs_io_data_chain_ptr_ = abs_data_ptr;
	if instance_chain.prev_ptr = null ()
	then instance_chain.level = 1;
	else do;
		instance_chain.prev_ptr -> instance_chain.next_ptr = abs_data_ptr;
		instance_chain.level = instance_chain.prev_ptr -> instance_chain.level + 1;
	     end;

	if no_set_bc_sw
	then do;
		status = 0;
		call abs_io_control (iocb_ptr, "no_set_bc", null (), status);
		if status ^= 0 then call error (status);
	     end;

	iocb_ptr -> iocb.open = abs_io_$abs_io_open;
	iocb_ptr -> iocb.detach_iocb = abs_io_$abs_io_detach;

	call iox_$propagate (iocb_ptr);		/* Tell the world we are attached			*/

	call hcs_$reset_ips_mask (mask, mask);

	P_status = 0;

EGRESS:
	return;
%page;
abs_io_$abs_io_open:
     entry (P_iocb_ptr, P_opening_mode, P_report_switch, P_status);

	mask = ""b;

	on any_other call any_other_handler;

	call hcs_$set_ips_mask (mask, mask);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if ^((P_opening_mode = Stream_input & open_data.si) | (P_opening_mode = Stream_input_output & open_data.sio))
	then call error (error_table_$bad_mode);

	if P_opening_mode = Stream_input_output
	then do;
		call abs_io_put_chars$open (abs_data_ptr, open_data.output_dir, open_data.output_entry,
		     (open_data.truncate), ^open_data.ssf, status);
		if status ^= 0 then call error (status);
		open_data.truncate = "0"b;		/* Only truncate on first opening for stream_input_output	*/
	     end;

	if abs_data.allocated_chars_ptr ^= null () then free allocated_chars;
	unspec (abs_data.if_info) = "0"b;
	abs_data.chars_ptr, abs_data.else_clause_ptr, abs_data.prev_if_ptr = null ();
	abs_data.allocated_chars_len, abs_data.chars_len, abs_data.else_clause_len = 0;
	input_string.position = input_string.start;
	abs_data.unique_name = "";

	iocb_ptr -> iocb.close = abs_io_$abs_io_close;

	if open_data.parser_version = 1
	then iocb_ptr -> iocb.get_line = abs_io_v1_get_line;
	else iocb_ptr -> iocb.get_line = abs_io_v2_get_line;

	if P_opening_mode = Stream_input_output then iocb_ptr -> iocb.put_chars = abs_io_put_chars;

	abs_data.open_description = iox_modes (P_opening_mode);
	iocb_ptr -> iocb.open_descrip_ptr = addr (abs_data.open_description);
						/* When this is done, we are open			*/
	call iox_$propagate (iocb_ptr);		/* So tell the world, already				*/

	call hcs_$reset_ips_mask (mask, mask);

	P_status = 0;

	if abs_data.absentee & abs_data.login_channel
	then begin;				/* do special absentee environment stuff */
declare	print_abs_msg_$login	entry;

		call print_abs_msg_$login;

		call hcs_$set_max_length_seg (stackbaseptr (), (248 * 1024), (0));
		call cu_$set_cl_intermediary (reenter_environment);
	     end;

	return;
%page;
abs_io_$abs_io_close:
     entry (P_iocb_ptr, P_status);

	mask = ""b;

	on any_other call any_other_handler;

	call hcs_$set_ips_mask (mask, mask);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;

	if output_file.seg_ptr ^= null ()
	then do;
		call abs_io_put_chars$close (abs_data_ptr, status);
		if status ^= 0 then call error (status);
	     end;

	if abs_data.attach.target_ptr ^= null () then call abs_io_control$close (abs_data_ptr);

	abs_data.active, abs_data.eof = "0"b;		/* Reinit per opening variables in case new opening	*/
	abs_data.nest_level, abs_data.expected_nest_level = 0;
						/* for Version 1 &if-&then-&else nesting */

	iocb_ptr -> iocb.open = abs_io_$abs_io_open;
	iocb_ptr -> iocb.detach_iocb = abs_io_$abs_io_detach;

	iocb_ptr -> iocb.open_descrip_ptr = null ();	/* When this is done, we are closed			*/

	call iox_$propagate (iocb_ptr);		/* So tell the world, already				*/

	call hcs_$reset_ips_mask (mask, mask);

	P_status = 0;

	return;
%page;
abs_io_$abs_io_detach:
     entry (P_iocb_ptr, P_status);

	mask = ""b;

	on any_other call any_other_handler;

	call hcs_$set_ips_mask (mask, mask);

	iocb_ptr = P_iocb_ptr;
	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;

	iocb_ptr -> iocb.attach_descrip_ptr = null ();	/* When this is done, we are detached			*/

	call iox_$propagate (iocb_ptr);		/* So tell the world, already				*/

	if instance_chain.prev_ptr ^= null ()
	then instance_chain.prev_ptr -> instance_chain.next_ptr = instance_chain.next_ptr;
	if instance_chain.next_ptr ^= null ()
	then instance_chain.next_ptr -> instance_chain.prev_ptr = instance_chain.prev_ptr;
	else abs_io_data_chain_ptr_ = instance_chain.prev_ptr;

	initialized = "1"b;				/* For clean_up					*/

	on cleanup call clean_up ();			/* Do BEFORE unmasking to prevent race window		*/

	call hcs_$reset_ips_mask (mask, mask);

	call clean_up ();

	P_status = 0;

	return;
%page;
abs_io_$allocate_abs_data: entry (P_abs_data_ptr);

	call allocate_abs_data;

	P_abs_data_ptr = abs_data_ptr;

	return;




abs_io_$initialize_abs_data: entry (P_abs_data_ptr);

	abs_data_ptr = P_abs_data_ptr;
	whoami = "ec_input_";

	call initialize_abs_data;

	return;
%page;
reenter_environment: entry;

	call reenter ();
	return;
%page;
allocate_abs_data: proc;

	on area call error (error_table_$noalloc, whoami, "In system area.");
	on bad_area_format call error (error_table_$notalloc, whoami, "In system area.");
	on bad_area_initialization call error (error_table_$notalloc, whoami, "In system area.");

	allocate abs_data in (sys_area);

	revert area;
	revert bad_area_format;
	revert bad_area_initialization;

	unspec (abs_data) = "0"b;

	abs_data.version = abs_data_version_1;		/* This is version of STRUCTURE			*/

end allocate_abs_data;
%page;
any_other_handler:
     procedure ();

declare	continue_to_signal_		entry (fixed bin (35));
declare	terminate_process_		entry (char (*), ptr);

	if substr (mask, 36, 1)
	then call terminate_process_ ("fatal_error", addr (unable_to_do_io));
	else call continue_to_signal_ ((0));

	return;

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

declare	p			ptr;

	if abs_data_ptr ^= null ()
	then do;
		if initialized
		then do;
			if abs_data.attach.save_ptr ^= null ()
			then call iox_$destroy_iocb (abs_data.attach.save_ptr, status);
			p = input_string.ptr;	/* TEMP: this can be removed when terminate_noname is fixed */
			input_string.ptr = null ();
			if p ^= null () then call hcs_$terminate_noname (p, status);
			call release_area_ (addr (abs_data.work_area));
		     end;
		free abs_data;
	     end;

	return;

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

declare	status_ptr		ptr;
declare	status_arg		fixed bin (35) based (status_ptr);
declare	arg_list_arg_count		fixed bin;
declare	message			character (256);

declare	com_err_			entry () options (variable);
declare	sub_err_			entry () options (variable);
declare	ioa_$general_rs		entry (pointer, fixed binary, fixed binary, character (*), fixed binary,
				bit (1) aligned, bit (1) aligned);
declare	cu_$arg_count		entry (fixed bin, fixed bin (35));
declare	cu_$arg_list_ptr		entry () returns (ptr);
declare	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin (35));
declare	cu_$generate_call		entry (entry, ptr);

	if masked_sw then call hcs_$reset_ips_mask (mask, mask);
						/* prevent calling com_err_ while masked */

	call cu_$arg_ptr (1, status_ptr, (0), (0));
	call cu_$arg_count (arg_list_arg_count, (0));
	P_status = status_arg;
	if arg_list_arg_count = 1 & P_report_switch then call com_err_ (P_status, whoami);
	else if P_report_switch then call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
	else do;
		call ioa_$general_rs (cu_$arg_list_ptr (), 3, 4, message, (0), "1"b, "0"b);
		call sub_err_ (P_status, (whoami), "s", null (), (0), "^a", message);
	     end;
	call clean_up ();

	go to EGRESS;

end error;
%page;
initialize_abs_data: proc;

dcl (user_info_$absentee_restarted, user_info_$absout_truncation) entry (bit (1) aligned);
dcl (restarted, truncate) bit (1) aligned;

/* Initializes just the things that need to be initialized for any ec execution, including the
   execution of an &on unit by absentee_listen_$execute_handler. */

	abs_data.io_module_name = whoami;

	abs_data.labels_ptr, abs_data.first_xlabel_ptr, abs_data.last_xlabel_ptr = null;
	abs_data.current_lex_block_ptr, abs_data.current_proc_block_ptr = null;
	abs_data.last_block_ptr, abs_data.current_loop_ptr, abs_data.last_loop_ptr, abs_data.saved_state_ptr = null;
	abs_data.attach.target_ptr, abs_data.attach.victim_ptr, abs_data.attach.save_ptr = null;
	abs_data.cleanup_handler_ptr, abs_data.first_handler_ptr = null;
	if abs_entry then do;	/* Only call user_info_ if not exec_com invocation */
	     call user_info_$absentee_restarted (restarted);
	     call user_info_$absout_truncation (truncate);
	     if truncate then if ^restarted then abs_data.truncate = "1"b;
	end;

/* Fill in structure for call to make abs_data.work_area extensible						*/

	area_data.version = area_info_version_1;
	string (area_data.control) = ""b;
	area_data.extend = "1"b;
	area_data.zero_on_free = "1"b;
	area_data.owner = whoami;
	area_data.size = Work_area_size;
	area_data.areap = addr (abs_data.work_area);

	call define_area_ (addr (area_data), status);
	if status ^= 0 then call error (status, whoami, "Initializing work area.");

end initialize_abs_data;
%page;
initiate_input_path:
     procedure (path_idx);

declare	path_idx			fixed bin parameter;

declare	absin_len			fixed bin,
	arg_len			fixed bin (21),
	arg_ptr			ptr,
	arg			char (arg_len) based (arg_ptr),
	bit_count			fixed bin (24),
	input_dir			char (168),
	input_dir_len		fixed bin (21),
	input_entry		char (32),
	input_entry_len		fixed bin (21);

	arg_ptr = addrel (addr (P_attach_args (path_idx)), 1);
	arg_len = length (rtrim (P_attach_args (path_idx)));
	if arg_len = 0 then call error (error_table_$badpath, whoami, "Input filename blank.");
	call expand_pathname_ (arg, input_dir, input_entry, status);
	if status ^= 0 then call error (status, whoami, "Input file:  ^a", arg);
	go to common;

initiate_input_file_login_channel:
     entry;

declare	absin_path		character (168);
	call user_info_$absin (absin_path);

	call expand_pathname_ (absin_path, input_dir, input_entry, status);
	if status ^= 0 then call error (status, whoami, "Input file:  ^a", absin_path);

common:
	call hcs_$initiate_count (input_dir, input_entry, "", bit_count, 0, input_string.ptr, status);
	if input_string.ptr = null ()
	then call error (status, whoami, "Input file: ^a", pathname_ (input_dir, input_entry));

	input_string.len = divide (bit_count, 9, 21, 0);

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

	abs_data.ec_path_quotes, abs_data.ec_name_quotes = -1;

	input_dir_len = length (rtrim (input_dir));
	input_entry_len = length (rtrim (input_entry));
	if input_dir_len = 1
	then abs_data.ec_path_len = 1 + input_entry_len;
	else abs_data.ec_path_len = input_dir_len + 1 + input_entry_len;

	allocate ec_path in (abs_data.work_area);

	substr (ec_path, 1, input_dir_len) = substr (input_dir, 1, input_dir_len);
	if input_dir_len > 1
	then do;
		substr (ec_path, input_dir_len + 1, 1) = ">";
		input_dir_len = input_dir_len + 1;
	     end;
	abs_data.ec_name_ptr = addr (substr (ec_path, input_dir_len + 1));
	substr (ec_path, input_dir_len + 1, input_entry_len) = substr (input_entry, 1, input_entry_len);
	input_dir_len = input_dir_len + input_entry_len;

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

/* Fill in pathname of output file, in case needed.							*/

	if abs_entry
	then if login_channel_sw | output_arg > 0
	     then do;
		     if output_arg > 0
		     then call expand_pathname_ ((P_attach_args (output_arg)), open_data.output_dir,
			     open_data.output_entry, status);
		     else do;
			     call user_info_$absout (absin_path);
			     call expand_pathname_ (absin_path, open_data.output_dir, open_data.output_entry,
				status);
			end;
		     if status ^= 0
		     then call error (status, whoami, "Output file ""^a""", P_attach_args (output_arg));
		end;
	     else do;
		     abs_data.output_dir = input_dir;
		     input_entry_len =
			input_entry_len - index (reverse (substr (input_entry, 1, input_entry_len)), ".");
		     absin_len = length (".absin");
		     if input_entry_len > absin_len
		     then /* prevent name.absin.absout */
			if substr (input_entry, input_entry_len - absin_len + 1, absin_len) = ".absin"
			then input_entry_len = input_entry_len - absin_len;
		     if input_entry_len + length (".absout") > maxlength (input_entry)
		     then call error (error_table_$entlong, whoami);
		     substr (open_data.output_entry, 1, input_entry_len) = substr (input_entry, 1, input_entry_len);
		     substr (open_data.output_entry, input_entry_len + 1) = ".absout";
		end;
	else open_data.output_dir, open_data.output_entry = "";

	return;

end initiate_input_path;
%page;
process_login_arguments:
     procedure;

declare	n_args			fixed bin;
declare	arg_len			fixed bin (21);
declare	max_arg_len		fixed bin (21);
declare	argx			fixed bin;

	call user_info_$login_arg_count (n_args, max_arg_len, (0));
	if n_args = 0 then return;			/* Nuthin to do */

	begin;
declare	args			(n_args) char (max_arg_len) varying;
declare	arg_ptr			pointer;
declare	arg			character (arg_len) based (arg_ptr);

	     do argx = 1 to n_args;
		call user_info_$login_arg_ptr (argx, arg_ptr, arg_len, (0));
		args (argx) = arg;

	     end;
	     call abs_io_control$set_arguments (abs_data_ptr, args, 1, status);
	     if status ^= 0 then call error (status, whoami, "Setting arguments:^(^/^a^)", args);
	end;

end process_login_arguments;
%page;
reenter:
     procedure;

/* this procedure intercepts all attempts to reenter the environment
in an absentee process, the process is logged out with a
special message */

/* THERE IS CODE HERE COPIED FROM LOGOUT */
/* so that the special error code can be put in the structures. */
/* someday there should be logout_ */

declare	error_table_$abs_reenter	fixed bin (35) ext;
declare	convert_status_code_	entry (fixed binary (35), character (8) aligned, character (100) aligned);
declare	execute_epilogue_		entry (bit (1) aligned);
declare	print_abs_msg_$logout	entry;
declare	ioa_			entry () options (variable);
declare	terminate_process_		entry (character (*), pointer);
declare	signal_			entry options (variable);

declare	try_message		bit (1) aligned internal static init ("1"b);
declare	long			character (100) aligned;
declare	1 FINISH_INFO		aligned like finish_info;
dcl	1 term_structure		aligned,		/* action for process termination */
	  2 version		fixed bin init (0), /* indicates version of structure */
	  2 ec			fixed bin (35);

	if try_message
	then do;
		try_message = "0"b;
		call convert_status_code_ (error_table_$abs_reenter, "", long);
		call ioa_ ("^/^a", long);
		call print_abs_msg_$logout;
	     end;
	FINISH_INFO.length = size (FINISH_INFO);
	FINISH_INFO.version = 1;
	FINISH_INFO.info_string = "";
	unspec (FINISH_INFO.action_flags) = ""b;
	FINISH_INFO.status_code = error_table_$abs_reenter;
	call signal_ ("finish", null (), addr (FINISH_INFO));
	call execute_epilogue_ ("0"b);		/* The "0"b says not just a run unit */
	term_structure.ec = error_table_$abs_reenter;
	call terminate_process_ ("fatal_error", addr (term_structure));
						/* log the process out */
end reenter;
%page;
set_trace_defaults: proc;

/* Fills in default tracing modes */

dcl default_mode bit (1);

	if abs_data.ec_data_ptr = null then default_mode = "1"b;
	else if abs_data.ec_data_ptr -> ec_data.active_function then default_mode = "0"b;
	else default_mode = "1"b;

	call set_default (abs_data.command_line, default_mode, EXPANDED);
	call set_default (abs_data.comment_line, "0"b, UNEXPANDED);
	call set_default (abs_data.control_line, "0"b, UNEXPANDED);
	call set_default (abs_data.input_line, default_mode, EXPANDED);

	return;


set_default: proc (P_line, P_mode, P_expand);

dcl 1 P_line aligned like abs_data.command_line;
dcl P_mode bit (1);
dcl P_expand fixed bin;

	P_line.on = P_mode;
	P_line.expand = P_expand;
	P_line.prefix = "";

end set_default;

end set_trace_defaults;
%page;
%include abs_io_data;
%page;
%include area_info;
%page;
%include condition_info_header;
%page;
%include ec_data;
%page;
%include finish_info;
%page;
%include iocb;
%page;
%include iox_modes;


     end abs_io_$abs_io_attach;




		    abs_io_control.pl1              08/11/87  1003.9r w 08/11/87  0925.9      150966



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


/* format: style3,idind30,ll122,ifthenstmt */

abs_io_control:
     procedure (P_iocb_ptr, P_order, P_info_ptr, P_status);

/* Initial coding: 25 June 1979 by J. Spencer Love							*/
/* Modified: 12 June 1980 by J. Spencer Love to add sleep and close entrypoints, and to handle io_call orders		*/
/* Control order "no_set_bc" added for "ear -no_set_bit_count" 07/29/81 S. Herbst */
/* Incorrect COMMAND and FUNCTION labels sorted out 07/28/82 S. Herbst */
/* Recompiled for changed abs_data structure 04/12/83 S. Herbst */
/* Added "set_trace" control order to implement ec -trace 05/03/84 S. Herbst */

/* Parameters											*/

declare	P_iocb_ptr		ptr parameter,
	P_attach_data_ptr		ptr parameter,
	P_order			char (*) parameter,
	P_arg_array		(*) char (*) varying parameter,
	P_info_ptr		ptr parameter,
	P_first_arg		fixed bin parameter,
	P_status			fixed bin (35) parameter;

/* Builtin											*/

declare	(addr, fixed, hbound, lbound, length, null, substr, unspec)
				builtin;

declare	(area, any_other, bad_area_format, bad_area_initialization)
				condition;

/* Automatic											*/

declare	arg_array_ptr		ptr,
	arg_array_size		fixed bin,
	arg_idx			fixed bin,
	factor			float bin,
	first_arg			fixed bin,
	info_ptr			ptr,
	iocb_ptr			ptr,
	mask			bit (36),
	order			fixed bin,
	sleep_time		fixed bin (71),
	status			fixed bin (35);

/* External											*/

declare	(
	error_table_$badcall,
	error_table_$badopt,
	error_table_$no_operation,
	error_table_$noalloc,
	error_table_$notalloc,
	error_table_$unable_to_do_io,
	error_table_$undefined_order_request
	)			fixed bin (35) external,
	iox_$user_input		ptr external;
%page;
/* Based												*/

declare	attach_descrip		char (256) varying based;

declare	1 timed_input		based (info_ptr),
	  2 low_sleep_time		fixed bin (35),
	  2 sleep_time_range	fixed bin (35),
	  2 seed			fixed bin (35);

declare	1 arg_array		(arg_array_size) aligned based (arg_array_ptr),
	  2 ptr			ptr,
	  2 len			fixed bin (21),
	  2 quotes		fixed bin (21);

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

declare	1 set_args		aligned based (info_ptr),
	  2 count			fixed bin,
	  2 e			(0 refer (set_args.count)),
	    3 ptr			ptr unaligned,
	    3 len			fixed bin (21);
%page;
/* Constants											*/

declare	Orders			(11) char (32) varying static options (constant)
				initial ("attach", "detach", "set_ec_data_ptr", "set_argument_ptrs",
				"set_arguments", "timed_input", "io_call", "io_call_af", "no_set_bc", "set_bc",
				"set_trace");

declare	Active			(11) bit (1) aligned static options (constant)
				initial ((3) ("1"b), (2) ("0"b), (6) ("1"b));

declare	Open			(11) bit (1) aligned static options (constant) initial ((11) ("1"b));

declare	Closed			(11) bit (1) aligned static options (constant) initial ((2) ("0"b), (9) ("1"b));

declare	Info			(0:11) bit (1) aligned static options (constant) initial ((3) ("0"b), (9) ("1"b));

declare	Null			(0:11) bit (1) aligned static options (constant)
				initial ((4) ("1"b), (5) ("0"b), (2) ("1"b), "0"b);

declare	Command			(0:11) bit (1) aligned static options (constant)
				initial ((3) ("1"b), (2) ("0"b), (7) ("1"b));

declare	Function			(0:11) bit (1) aligned static options (constant)
				initial ("1"b, (6) ("0"b), (5) ("1"b));

/* Entries											*/

declare	continue_to_signal_		entry (fixed bin (35)),
	hcs_$reset_ips_mask		entry (bit (36), bit (36)),
	hcs_$set_ips_mask		entry (bit (36), bit (36)),
	iox_$attach_ptr		entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$detach_iocb		entry (ptr, fixed bin (35)),
	iox_$find_iocb		entry (char (*), ptr, fixed bin (35)),
	iox_$move_attach		entry (ptr, ptr, fixed bin (35)),
	random_$uniform		entry (fixed bin (35), float bin),
	terminate_process_		entry (char (*), ptr),
	timer_manager_$sleep	entry (fixed bin (71), bit (2));
%page;
/* abs_io_control:
        procedure (P_iocb_ptr, P_order, P_info_ptr, P_status);						*/

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;
	info_ptr = P_info_ptr;
	mask = ""b;
	status = 0;

	order = interpret_order (P_order);
	if (info_ptr ^= null () & Info (order)) | (info_ptr = null () & Null (order)) then go to ORDER (order);

ORDER (0):					/* 0 subscript is for undefined order			*/
COMMAND (0):
FUNCTION (0):
COMMAND (7):					/* io_call order may not specify io_call or io_call_af	*/
FUNCTION (7):
COMMAND (8):					/* io_call_af order may not specify io_call or io_call_af	*/
FUNCTION (8):
FUNCTION (9):
FUNCTION (10):
NO_OPERATION:					/* Come here if operation cannot be performed now		*/
	status = error_table_$no_operation;

	go to EGRESS;

CALL_BACK_LATER:
	status = error_table_$undefined_order_request;

	go to EGRESS;

BAD_CALL:						/* Come here to reject input data structure		*/
	status = error_table_$badcall;

	go to EGRESS;

AREA_FULL:					/* come here for area condition			*/
	status = error_table_$noalloc;

	go to EGRESS;

BAD_AREA:						/* come here for bad_area_format or bad_area_initialization */
	status = error_table_$notalloc;

EGRESS:
	if substr (mask, 36, 1) then call hcs_$reset_ips_mask (mask, mask);

	P_status = status;

	return;
%page;
interpret_order:
     procedure (P_order) returns (fixed bin);

declare	P_order			char (*),
	order			fixed bin;

	do order = lbound (Orders, 1) to hbound (Orders, 1);
	     if Orders (order) = P_order
	     then if (iocb_ptr -> iocb.open_descrip_ptr = null () & ^Closed (order))
		     | (iocb_ptr -> iocb.open_descrip_ptr ^= null () & ^abs_data.active & ^Open (order))
		     | (abs_data.active & ^Active (order))
		then return (0);
		else return (order);
	end;

	return (0);

     end interpret_order;
%page;
/* ORDER = "set_ec_data_ptr"  This order is used to estabish communication between listeners and abs_io_.		*/

ORDER (3):
	if info_ptr ^= null
	then do;
		if info_ptr -> ec_data.version ^= ec_data_version_1 then go to BAD_CALL;
		if info_ptr -> ec_data.version_id ^= ec_data_version_id then go to BAD_CALL;
	     end;

	abs_data.ec_data_ptr = info_ptr;

	go to EGRESS;
%page;
/* ORDER = "timed_input"  This is used to simulate interactive usage by going blocked on each get_line call		*/

ORDER (6):
	if timed_input.sleep_time_range < 0 then go to BAD_CALL;

	abs_data.timed_input = (timed_input.low_sleep_time + timed_input.sleep_time_range > 0);

	if ^abs_data.timed_input then go to EGRESS;

	abs_data.low_sleep_time = timed_input.low_sleep_time;
	abs_data.sleep_time_range = timed_input.sleep_time_range;
	abs_data.seed = timed_input.seed;

	go to EGRESS;

COMMAND (6):
	if io_call_info.nargs ^= 1
	then do;
		call io_call_info.error (0, io_call_info.caller_name, "One of ""-on"" or ""-off"" must be given.");
		go to EGRESS;
	     end;

	if io_call_info.args (1) = "-off" then abs_data.timed_input = "0"b;
	else if io_call_info.args (1) = "-on"
	then abs_data.timed_input = (abs_data.low_sleep_time + abs_data.sleep_time_range > 0);
	else call io_call_info.error (error_table_$badopt, io_call_info.caller_name, "^a", io_call_info.args (1));

	go to EGRESS;

/* This entrypoint is used to simulate interactive waits.  Waits are uniformly distributed over a range.  The range can
   overlap zero so that some specified percentage of calls will result in no wait (to simulate type ahead).  The only
   thing it lacks is the priority boost that is caused by a real interaction.  This feature is used for benchmarking.	*/

abs_io_control$sleep:
     entry (P_attach_data_ptr);

	abs_data_ptr = P_attach_data_ptr;

	call random_$uniform (abs_data.seed, factor);
	sleep_time = fixed (factor * abs_data.sleep_time_range, 71) + abs_data.low_sleep_time;
	if sleep_time > 0 then call timer_manager_$sleep (sleep_time, "10"b);

	return;
%page;
attach:
     entry (P_attach_data_ptr, P_info_ptr, P_status);

	abs_data_ptr = P_attach_data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;
	info_ptr = P_info_ptr;
	mask = ""b;
	status = 0;

ORDER (1):
	on any_other call any_other_handler ();

	call hcs_$set_ips_mask (mask, mask);

	if ec_data_ptr = null () then go to NO_OPERATION;

	if abs_data.attach.target_ptr ^= null () then go to NO_OPERATION;

	if abs_data.attach.save_ptr = null ()
	then do;
		call iox_$find_iocb (ec_data.id_string || "." || abs_data.io_module_name, abs_data.attach.save_ptr,
		     status);
		if status ^= 0 then go to EGRESS;
	     end;

	abs_data.attach.victim_ptr = iox_$user_input;
	call iox_$move_attach (abs_data.attach.victim_ptr, abs_data.attach.save_ptr, status);
	if status ^= 0 then go to EGRESS;

	abs_data.attach.target_ptr = ec_data.switch_ptr;
	call iox_$attach_ptr (abs_data.attach.victim_ptr, "syn_ " || abs_data.attach.target_ptr -> iocb.name, null (),
	     status);
	if status ^= 0
	then do;
		call iox_$move_attach (abs_data.attach.save_ptr, abs_data.attach.victim_ptr, (0));
		abs_data.attach.target_ptr = null ();
		go to EGRESS;
	     end;

	call hcs_$reset_ips_mask (mask, mask);

	go to EGRESS;

COMMAND (1):
	if io_call_info.nargs > 0
	then do;
		call io_call_info.error (0, io_call_info.caller_name, "No arguments are permitted for ""attach"".");
		go to EGRESS;
	     end;

	go to ORDER (1);
%page;
abs_io_control$detach:
     entry (P_attach_data_ptr, P_info_ptr, P_status);

	abs_data_ptr = P_attach_data_ptr;
	info_ptr = P_info_ptr;
	mask = ""b;
	status = 0;

ORDER (2):
	on any_other call any_other_handler ();

	call hcs_$set_ips_mask (mask, mask);

	status = detach ();

	call hcs_$reset_ips_mask (mask, mask);

	go to EGRESS;



COMMAND (2):					/* "io control &ec_switch detach" */
	if io_call_info.nargs > 0
	then do;
		call io_call_info.error (0, io_call_info.caller_name, "No arguments are permitted for ""detach"".");
		go to EGRESS;
	     end;

	on any_other call any_other_handler ();

	call hcs_$set_ips_mask (mask, mask);

	status = detach ();

	call hcs_$reset_ips_mask (mask, mask);

	if status ^= 0 then call io_call_info.error (status, io_call_info.caller_name, "Detaching.");
	status = 0;

	go to EGRESS;



abs_io_control$close:
     entry (P_attach_data_ptr);

	abs_data_ptr = P_attach_data_ptr;

	status = detach ();

	call iox_$detach_iocb (abs_data.attach.save_ptr, (0));

	return;
%page;
detach:
     procedure () returns (fixed bin (35));

	if abs_data.attach.target_ptr = null () then return (error_table_$no_operation);

	if abs_data.attach.victim_ptr -> iocb.attach_descrip_ptr -> attach_descrip
	     ^= "syn_ " || abs_data.attach.target_ptr -> iocb.name
	then return (error_table_$badcall);

	call iox_$detach_iocb (abs_data.attach.victim_ptr, status);
	if status ^= 0 then return (status);

	call iox_$move_attach (abs_data.attach.save_ptr, abs_data.attach.victim_ptr, status);
	if status ^= 0
	then do;
		call iox_$attach_ptr (abs_data.attach.victim_ptr, "syn_ " || abs_data.attach.target_ptr -> iocb.name,
		     null (), (0));
		return (status);
	     end;

	abs_data.attach.target_ptr, abs_data.attach.victim_ptr = null ();

	return (0);

     end detach;
%page;
/* ORDER = "set_argument_ptrs"  Set ptrs and lengths of arguments from info structure without copying for efficiency	*/

ORDER (4):
	call release_args ();

	arg_array_size = set_args.count;
	call allocate_arg_array ();

	arg_array (*).len = set_args (*).len;
	arg_array (*).ptr = set_args (*).ptr;
	arg_array (*).quotes = -1;

	abs_data.arg_count = arg_array_size;
	abs_data.args_copied = "0"b;
	abs_data.arg_ptr = arg_array_ptr;

	go to EGRESS;

/* ORDER = "set_arguments"  Used to set arguments from structure of pointers and lengths, copying them into work_area	*/

ORDER (5):
	call release_args ();

	arg_array_size = set_args.count;
	call allocate_arg_array ();

	do arg_idx = 1 to arg_array_size;
	     arg_array (arg_idx).len = set_args (arg_idx).len;
	     arg_array (arg_idx).quotes = -1;
	     allocate arg_string in (abs_data.work_area);
	     arg_string = set_args (arg_idx).ptr -> arg_string;
	end;

	abs_data.arg_count = arg_array_size;
	abs_data.args_copied = "1"b;
	abs_data.arg_ptr = arg_array_ptr;

	go to EGRESS;

COMMAND (5):
	call release_args ();

	arg_array_size = io_call_info.nargs;
	call allocate_arg_array ();

	do arg_idx = 1 to arg_array_size;
	     arg_array (arg_idx).len = length (io_call_info.args (arg_idx));
	     arg_array (arg_idx).quotes = -1;
	     allocate arg_string in (abs_data.work_area);
	     arg_string = io_call_info.args (arg_idx);
	end;

	abs_data.arg_count = arg_array_size;
	abs_data.args_copied = "1"b;
	abs_data.arg_ptr = arg_array_ptr;

	go to EGRESS;
%page;
/* This entrypoint is used by abs_io_attach to set arguments which are given on in the attach description		*/

set_arguments:
     entry (P_attach_data_ptr, P_arg_array, P_first_arg, P_status);

	abs_data_ptr = P_attach_data_ptr;
	first_arg = P_first_arg;
	mask = ""b;
	status = 0;

	if first_arg <= 0 then go to EGRESS;

	call release_args ();

	arg_array_size = hbound (P_arg_array, 1) - first_arg + 1;
	call allocate_arg_array ();

	do arg_idx = 1 to arg_array_size;
	     arg_array (arg_idx).len = length (P_arg_array (arg_idx + first_arg - 1));
	     arg_array (arg_idx).quotes = -1;
	     allocate arg_string in (abs_data.work_area);
	     arg_string = P_arg_array (arg_idx + first_arg - 1);
	end;

	abs_data.arg_count = arg_array_size;
	abs_data.args_copied = "1"b;
	abs_data.arg_ptr = arg_array_ptr;

	go to EGRESS;
%page;
/* This internal procedure is used to allocate argument info with condition handlers				*/

allocate_arg_array:
     procedure ();

	if arg_array_size <= 0 then go to EGRESS;

	on area go to AREA_FULL;
	on bad_area_format go to BAD_AREA;
	on bad_area_initialization go to BAD_AREA;

	allocate arg_array in (abs_data.work_area);

	return;

     end allocate_arg_array;

/* This internal procedure is used by the argument setting routines to release storage that previously held arguments	*/

release_args:
     procedure ();

	arg_array_ptr = abs_data.arg_ptr;
	arg_array_size = abs_data.arg_count;
	abs_data.arg_ptr = null ();
	abs_data.arg_count = 0;
	if abs_data.args_copied
	then do arg_idx = 1 to arg_array_size;
		free arg_string;
	     end;
	if arg_array_ptr ^= null () then free arg_array;

	return;
     end release_args;
%page;
/* ORDER = "io_call"										*/

ORDER (7):
	io_call_infop = info_ptr;
	if io_call_info.version ^= 1 then go to NO_OPERATION;

	order = interpret_order ((io_call_info.order_name));
	if Command (order) then go to COMMAND (order);

	go to CALL_BACK_LATER;

/* ORDER = "io_call_af"										*/

ORDER (8):
	io_call_infop = info_ptr;
	if io_call_info.version ^= 1 then go to NO_OPERATION;

	order = interpret_order ((io_call_info.order_name));
	if Function (order) then go to FUNCTION (order);

	go to CALL_BACK_LATER;
%page;
/* ORDER = "no_set_bc" */

ORDER (9):
COMMAND (9):
	abs_data.open_data.no_set_bc = "1"b;

	go to EGRESS;


/* ORDER = "set_bc" */

ORDER (10):
COMMAND (10):
	abs_data.open_data.no_set_bc = "0"b;

	go to EGRESS;
%page;
/* ORDER = "set_trace" */

ORDER (11):
	call set_trace (info_ptr -> ec_trace_info.command_line, abs_data.command_line);
	call set_trace (info_ptr -> ec_trace_info.comment_line, abs_data.comment_line);
	call set_trace (info_ptr -> ec_trace_info.control_line, abs_data.control_line);
	call set_trace (info_ptr -> ec_trace_info.input_line, abs_data.input_line);

	go to EGRESS;
%page;
set_trace: proc (P_info_line, P_abs_line);

/* This internal procedure copies the elements of ec_trace_info into the trace portion of abs_data trace */

dcl 1 P_info_line aligned like ec_trace_info.command_line;
dcl 1 P_abs_line aligned like abs_data.command_line;

	if ^P_info_line.explicit_sw then return;	/* nothing to set for this type of line */

	P_abs_line.by_control_arg = "1"b;
	P_abs_line.on = P_info_line.on;
	P_abs_line.expand = P_info_line.expand;
	if unspec (P_info_line.iocb) = "0"b then P_abs_line.iocb = null;
	else P_abs_line.iocb = P_info_line.iocb;
	P_abs_line.prefix = P_info_line.prefix;

end set_trace;
%page;
any_other_handler:
     procedure ();

declare	1 ts			aligned,
	  2 version		fixed bin,
	  2 status_code		fixed bin (35);

	if substr (mask, 36, 1)
	then do;
		ts.version = 0;
		ts.status_code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ts));
	     end;

	call continue_to_signal_ ((0));		/* We don't want it; pass it on			*/

	return;

     end any_other_handler;
%page;
%include abs_io_data;
%page;
%include ec_data;
%page;
%include ec_trace_info;
%page;
%include io_call_info;
%page;
%include iocb;


     end abs_io_control;




		    abs_io_expand_.pl1              05/17/90  1515.5rew 05/17/90  1510.3      680211



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




/****^  HISTORY COMMENTS:
  1) change(86-03-13,Herbst), approve(86-04-17,MCR7376),
     audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041):
     Fixed bug causing extra null arg for "&||[af_returning_null_string]".
  2) change(86-04-23,Herbst), approve(86-04-23,MCR7376),
     audit(86-04-25,Kissel), install(86-04-29,MR12.0-1041):
     Fixed to consider open and closed parens inside a quoted string as literal
     characters unless a ")" closes a "&(" since variable references &(...) are
     expanded even in quoted strings. Did the same for brackets and "&[".
  3) change(86-04-30,Herbst), approve(86-04-30,MCR7376),
     audit(86-04-30,Kissel), install(86-05-01,MR12.0-1052):
     Fixed ")" inside quoted string to close &q(1) as well as &(foo).
  4) change(86-05-22,Herbst), approve(86-05-22,MCR7376),
     audit(86-05-16,Kissel), install(86-05-22,MR12.0-1058):
     Backed out previous changes to () and [] handling recognizing that all
     except &() and &[] should be ignored by exec_com itself.
  5) change(87-02-16,Parisek), approve(87-07-23,MCR7716),
     audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080):
     If abs_data.noabort is ON then update next statement data.
  6) change(87-08-18,Parisek), approve(87-08-18,PBF7716),
     audit(87-09-03,Farley), install(87-09-10,MR12.1-1104):
     Conditionally get next ec statement when noabort flag is on.
  7) change(89-12-04,LZimmerman), approve(89-12-04,MCR8145),
     audit(89-12-08,Kallstrom), install(90-05-17,MR12.4-1009):
     Add literal &CR.
                                                   END HISTORY COMMENTS */


/* format: off */

abs_io_expand_: proc (A_xd, A_code);

/* Written 09/05/80 by Steve Herbst */

/* Fixed to return blank lines 10/07/81 S. Herbst */
/* Changed &set to see quotes, added &r(var) etc., added &print_switch{_nnl} 10/20/81 S. Herbst */
/* Fixed &q(1) bug, &then&quit bug 02/04/82 S. Herbst */
/* Modified: 16 February 1982 by G. Palter to call ec_data.eval_string when appropriate */
/* Fixed it to handle &ready_proc (as well as &ready), and reject &thenquit but not &then&quit 03/24/82 S. Herbst */
/* Fixed &if-&then-&else to be impervious to recursive get_line 04/20/82 S. Herbst */
/* Removed 1000-char limit on &[...] strings 06/01/82 S. Herbst */
/* Fixed to ignore trailing white space 07/08/82 S. Herbst */
/* Sped up the label search, changed to use addcharno 10/06/82 S. Herbst */
/* Fixed &set foo "" and arg parsing with <SP><NL>&+ 12/07/82 */
/* Fixed &+ continuation interrupted by one or more comment lines 12/14/82 S. Herbst */
/* Fixed fault taken parsing white space 01/03/83 S. Herbst */
/* Fixed get_next_statement to skip leading white space on line after &-comment 02/07/83 S. Herbst */
/* Fixed not to skip every other blank line 02/10/83 S. Herbst */
/* Fixed to skip trailing white space before returning, to distinguish it from blank line 02/24/83 S. Herbst */
/* Fixed to not rtrim variable values 03/01/83 S. Herbst */
/* Fixed to handle &then || NL || &+ 03/07/83 S. Herbst */
/* Added keywords &on, &begin, &revert, etc. 04/07/83 S. Herbst */
/* Changed to look at abs_data.trim_whitespace_sw for input lines (&attach &trim off) 06/02/83 S. Herbst */
/* Added &list_variables (&lsv) 06/07/83 S. Herbst */
/* Fixed to recognize &"" as a null string arg, as in: &set a &"" b &"" 11/18/83 S. Herbst */
/* Fixed bug making it possible to overflow allocated region for expansion 12/28/83 S. Herbst */
/* Fixed expansion bug caused by freeing allocated buffer used by pushed state 01/24/84 S. Herbst */
/* Fixed to allocate variables in abs_data.work_area, not system free area 05/16/84 S. Herbst */
/* Fixed to preserve &"" and "" as null arguments 07/18/84 S. Herbst */
/* Fixed to accept &end on same line as handler text 08/10/84 S. Herbst */
/* Fixed to compute quotes for &r and &q correctly when nested inside parens 08/14/84 S. Herbst */
/* Fixed to ignore mismatch of non-ec parentheses, as in (...) 08/20/84 S. Herbst */
/* Fixed bug causing extra null arg parsing 'one &[string " two"]' 08/20/84 S. Herbst */


dcl 1 state,
   2 keyword,
    3 name char (32) varying,
    3 number fixed bin,
    3 paren_sw bit (1) unaligned,
    3 bracket_sw bit (1) unaligned,
    3 af_type fixed bin,
    3 name_switches unaligned,
     4 control_word_sw bit (1),
     4 allow_arg_sw bit (1),
     4 require_arg_sw bit (1),
     4 require_number_sw bit (1),
     4 digit_arg_sw bit (1),
    3 param_switches,
     4 f_sw bit (1),
     4 n_sw bit (1),
     4 q_sw bit (1),
     4 r_sw bit (1),
   2 quote_factor fixed bin,				/* 2**(quote depth up to state.qscan_start)-1 for doubling */
   2 qscan_start fixed bin (21),
   2 iafter_pos fixed bin (21),			/* for tracing */
   2 optr_len,
    3 optr ptr,
    3 omax_len fixed bin (21),
    3 olen fixed bin (21),
    3 opos fixed bin (21);

dcl 1 state_stack (100) like state;


dcl 1 alloc_info aligned,				/* for allocating long lines */
   2 allocated_sw bit (1) aligned,
   2 alloc_ptr ptr,
   2 alloc_len fixed bin (21);

dcl 1 alloc_stack (100) aligned,
   2 allocated_sw_stack bit (1) aligned,
   2 alloc_ptr_stack ptr,
   2 alloc_len_stack fixed bin (21);
%page;
dcl 1 PARAM_KEYWORD int static options (constant),
   2 name char (32) varying init ("&"),
   2 number fixed bin init (1),
   2 paren_sw bit (1) unaligned init ("0"b),
   2 bracket_sw bit (1) unaligned init ("0"b),
   2 af_type fixed bin init (0),
   2 name_switches unaligned,
    3 control_word_sw bit (1) init ("0"b),
    3 allow_arg_sw bit (1) init ("1"b),
    3 require_arg_sw bit (1) init ("1"b),
    3 require_number_sw bit (1) init ("1"b),
    3 digit_arg_sw bit (1) init ("0"b),
   2 param_switches unaligned,
    3 f_sw bit (1) init ("0"b),
    3 n_sw bit (1) init ("0"b),
    3 q_sw bit (1) init ("0"b),
    3 r_sw bit (1) init ("0"b);


dcl (A_pos, A_len) fixed bin (21);			/* for $expand_label */
dcl A_label_val_ptr ptr;				/* for $expand_label */
dcl A_label_val_len fixed bin (21);			/* for $expand_label */
dcl A_vars_ptr ptr;					/* for $set */
dcl (A_var, A_val) char (*);				/* for $set */
dcl A_code fixed bin (35);

dcl 1 A_xd aligned like expand_data;
%page;
/* Based */

dcl xd_area area based (A_xd.area_ptr);

dcl 1 iptr_len,
   2 iptr ptr,
   2 ilen fixed bin (21),
   2 ipos fixed bin (21);

dcl input_overlay char (overlay_len) based (overlay_ptr);
dcl input char (ilen) based (iptr);
dcl output char (state.olen) based (state.optr);
dcl saved_arg char (saved_arg_len) varying based (saved_arg_ptr);


dcl alloc_string char (alloc_len) based (alloc_ptr);
dcl allocated_buffer char (A_xd.allocated_buffer_len) based (A_xd.allocated_ptr);
dcl caller_buffer char (A_xd.caller_buffer_len) based (A_xd.caller_buffer_ptr);


dcl 1 command_args (command_args_count) based (command_args_ptr),
   2 ptr ptr,
   2 len fixed bin (21),
   2 quote_count fixed bin (21);
dcl command_arg char (command_args (arg_index).len) based (command_args (arg_index).ptr);

dcl ec_name char (arg_info.ec_name_len) based (arg_info.ec_name_ptr);
dcl ec_path char (arg_info.ec_path_len) based (arg_info.ec_path_ptr);

dcl parsed_arg char (parsed_args.len (parsed_arg_index)) based (parsed_args.ptr (parsed_arg_index));


/* Constants */

dcl TF (0:1) char (8) varying int static options (constant) init ("false", "true");
dcl DEFAULT_ARG char (1) int static options (constant) init ("
");						/* no arg specified to a keyword */
dcl (CONTROL init ("1"b), NONCONTROL init ("0"b)) bit (1) int static options (constant);
dcl (QDOUBLE init ("0"b), REQUOTE init ("1"b)) bit (1) int static options (constant);
dcl UNDEFINED fixed bin int static options (constant) init (-1);
dcl (BK_TYPE init (1), BAR_BK_TYPE init (2), BAR_BAR_BK_TYPE init (3)) fixed bin int static options (constant);
dcl (PARAM_REF init (1), VAR_REF init (2), AF_REF init (3), MAX_KEY init (100)) fixed bin int static options (constant);

dcl DIGITS char (10) int static options (constant) init ("0123456789");
dcl ALPHA char (27) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz_");
dcl DELIMS char (4) int static options (constant) init ("() 	");
dcl SP char (1) int static options (constant) init (" ");
dcl HT char (1) int static options (constant) init ("	");
dcl BS char (1) int static options (constant) init ("");
dcl NL char (1) int static options (constant) init ("
");
dcl VT char (1) int static options (constant) init ("");
dcl FF char (1) int static options (constant) init ("");
dcl CR char (1) int static options (constant) init ("
");

/* The control statement keywords */
/* NOTE: Do not change this array without changing the ACTION() and SKIP() labels in abs_io_v2_get_line */
/*	Also change abs_io_v2_get_line vars ELSE_ACTION, IF_ACTION, and THEN_ACTION */

dcl STMTS_STRING char (STMTS_LEN) aligned based (addr (STMTS));
dcl STMTS (39) char (32) aligned int static options (constant) init
	("&attach",	"&begin",		"&call",		"&default",	"&detach",
	 "&do",		"&else",		"&end",		"&exit",		"&entry",
	 "&function",	"&goto",		"&if",		"&label",		"&leave",
	 "&list_variables",	"&lsv",		"&on",		"&print",		"&print_nnl",
	 "&print_switch",	"&print_switch_nnl","&procedure",	"&proc",		"&quit",
	 "&ready",	"&ready_mode",	"&ready_proc",	"&repeat",	""/*"&resignal*/,
	 "&return",	"&revert",	"&set",		"&signal",	"&then",
	 "&trace",	"&until",		"&version",	"&while");

dcl STMT_SWITCHES (39) bit (3) int static options (constant) init
						/* parse_args, no_args, then_else_allowed */
	("100"b,		"110"b,		"100"b,		"100"b,		"100"b,
	 "110"b,		"010"b,		"110"b,		"100"b,		"100"b,
	 "100"b,		"000"b,		"001"b,		"000"b,		"100"b,
	 "100"b,		"100"b,		"100"b,		"000"b,		"000"b,
	 "000"b,		"000"b,		"100"b,		"100"b,		"010"b,
	 "100"b,		"100"b,		"100"b,		"100"b,		"100"b,
	 "000"b,		"100"b,		"100"b,		"000"b,		"011"b,
	 "100"b,		"100"b,		"100"b,		"100"b);

dcl 1 STMT_SW_OVERLAY (39) based (addr (STMT_SWITCHES)),
   2 (PARSE_ARGS_SW, NO_ARGS_SW, THEN_ELSE_ALLOWED_SW) bit (1) unaligned;

/* The expandable keywords */
/* NOTE: Do not change this array without changing the labels in expand internal procedure */

dcl NAMES_STRING char (NAMES_LEN) aligned based (addr (NAMES));
dcl NAMES (38) char (32) aligned int static options (constant) init
	("&condition_info_ptr",  "&cond_info_ptr",  "&condition_name",  "&cond_name",	"&ec_dir",
	 "&ec_name",	"&ec_path",	"&ec_switch",	"&handlers",	"&in_handler",
	 "&is_absin",	"&is_active_function",  "&is_af",	"&is_attached",	"&is_defined",
	 "&is_input_line",	"&n",		""/*&quote*/,	""/*&requote*/,	""/*&unquote*/,
	 "&was_attached",	"&AMP",		"&BS",		"&CR",		"&FF",
	"&HT",		"&LF",		"&NL",		"&NP",		"&QT",
	"&SP",		"&VT",		"&begin",		"&do",		"&else",
	"&end",		"&if",		"&then");

dcl NAME_SWITCHES (38) bit (5) int static options (constant) init
					/* control_wd, allow_arg, require_arg, require_num, digit_ok (params) */
(	"00000"b,		"00000"b,		"00000"b,		"00000"b,		"00000"b,
	"00000"b,		"00000"b,		"00000"b,		"00000"b,		"00000"b,
	"00000"b,		"00000"b,		"00000"b,		"00000"b,		"01100"b,
	"00000"b,		"00000"b,		"01100"b,		"01100"b,		"01100"b,
	"00000"b,		"01010"b,		"01010"b,		"01010"b,		"01010"b,
	"01010"b,		"01010"b,		"01010"b,		"01010"b,		"01010"b,
	"01010"b,		"01010"b,		"10000"b,		"10000"b,		"10000"b,
	"10000"b,		"10000"b,		"10000"b);

/* The &words not to be expanded (stmt control-args) */

dcl DONT_EXPAND_STRING char (DONT_EXPAND_LEN) aligned based (addr (DONT_EXPAND));
dcl DONT_EXPAND (22) char (32) aligned int static options (constant) init
	("&all", "&both", "&command", "&comment", "&continue", "&control", "&ex", "&exclude", "&expanded",
	 "&input", "&match", "&osw", "&output_switch", "&prefix", "&trim", "&undef", "&undefined",
	 "&unexpanded", "&val", "&value", "&var", "&variable");

/* The parameter prefixes */

dcl PARAMS_STRING char (PARAMS_LEN) aligned based (addr (PARAMS));
dcl PARAMS (10) char (8) aligned int static options (constant) init
	("&q", "&qf", "&q&n", "&qf&n",
	 "&r", "&rf", "&r&n", "&rf&n",
	 "&f", "&f&n");
dcl PARAM_SWITCHES (10) bit (4) int static options (constant) init  /* f, n, q, r */
	("0010"b, "1010"b, "0110"b, "1110"b,
	 "0001"b, "1001"b, "0101"b, "1101"b,
	 "1000"b, "1100"b);

/* Static */

dcl WHITE char (4) int static;			/* to be initialized to SP || HT || VT || FF */
dcl init_sw bit (1) int static init ("0"b);
dcl MAX_CHARS fixed bin (21) int static options (constant) init (261120 * 4);  /* max chars in a seg */
dcl (DONT_EXPAND_LEN, NAMES_LEN, PARAMS_LEN, STMTS_LEN) fixed bin int static;
dcl (ELSE_ACTION, IF_ACTION, SET_ACTION, THEN_ACTION) fixed bin int static;


/* Automatic */

dcl 1 trace aligned like abs_data.command_line;

dcl (auto_saved_arg, trace_buffer) char (1000) varying;
dcl search_chars char (12) varying;
dcl tf_string char (8) varying;

dcl char5 char (5);
dcl char3 char (3);
dcl char2 char (2);
dcl (next_char, next_next_char, searched_char) char (1);

dcl (added_arg_inside_quotes_sw, control_line_sw, delete_sw, eof_sw, expand_label_sw, found_sw) bit (1);
dcl (got_next_stmt, inside_quotes_sw, label_search_sw, no_args_sw, null_arg_sw, parse_args_sw, saved_arg_allocated_sw) bit (1);
dcl (skip_sw, then_else_allowed_sw, trace_sw) bit (1);

dcl (command_args_ptr, overlay_ptr, saved_arg_ptr) ptr;

dcl (arg_index, arg_limit, arg_max, arg_start, command_args_count, nest_level, parsed_arg_index) fixed bin;
dcl (i, istart, j, no_args_ipos, overlay_len, saved_arg_len, saved_ilen, saved_ipos, skip_count) fixed (21);
dcl (temp_i, temp_istart, temp_white_len, white_len) fixed bin (21);
dcl ic (6) fixed bin (21);
dcl code fixed bin (35);

dcl error_table_$badsyntax fixed bin (35) ext;
dcl error_table_$command_line_overflow fixed bin (35) ext;
dcl error_table_$end_of_info fixed bin (35) ext;
dcl error_table_$oldnamerr fixed bin (35) ext;

dcl iox_$user_output ptr ext;

dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35));
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl (ioa_$ioa_switch_nnl, ioa_$rsnnl) entry options (variable);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl unique_chars_ entry (bit (*)) returns (char (15));
dcl value_$defined entry (ptr, bit (36), char (*), fixed bin (35)) returns (bit (1) aligned);
dcl value_$delete entry (ptr, bit (36), char (*), fixed bin (35));
dcl value_$get_alloc entry (ptr, bit (36), char (*), ptr, ptr, fixed bin (21), fixed bin (35));
dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin (19), fixed bin (35));
dcl value_$set entry options (variable);

dcl (addcharno, addr, codeptr, copy, divide, fixed, hbound, index, length) builtin;
dcl (max, maxlength, min, mod, null, rtrim, search, substr, unspec, verify) builtin;

dcl (area, bad_area_format, bad_area_initialization) condition;
%page;
	trace_sw = "1"b;
	expand_label_sw, got_next_stmt, label_search_sw, skip_sw = "0"b;
	go to COMMON;

expand_label: entry (A_xd, A_pos, A_len, A_label_val_ptr, A_label_val_len, A_code);  /* expands a &label for search */

	expand_label_sw = "1"b;
	got_next_stmt, label_search_sw, skip_sw, trace_sw = "0"b;
	A_code = 0;
	abs_data_ptr = A_xd.abs_data_ptr;
	overlay_ptr = input_string.ptr;
	overlay_len = input_string.len;
	iptr = addcharno (overlay_ptr, A_pos + length ("&label ") - 1);  /* position to rest of line */
	ilen = A_len - length ("&label ");
	ipos, istart, nest_level = 1;
	no_args_sw, parse_args_sw = "0"b;
	state.optr = A_xd.caller_buffer_ptr;
	state.omax_len = A_xd.caller_buffer_len;
	state.olen = 0;
	go to START_EXPANDING;

label_search: entry (A_xd, A_code);

	label_search_sw = "1"b;			/* executing a &goto */
	expand_label_sw, got_next_stmt, skip_sw, trace_sw = "0"b;
	go to COMMON;

skip:	entry (A_xd, A_code);

	skip_sw = "1"b;				/* skipping &then or &else clause */
	expand_label_sw, label_search_sw, trace_sw = "0"b;
COMMON:
	if ^init_sw then do;
	     init_sw = "1"b;
	     STMTS_LEN = length (STMTS (1)) * hbound (STMTS, 1);
	     NAMES_LEN = length (NAMES (1)) * hbound (NAMES, 1);
	     DONT_EXPAND_LEN = length (DONT_EXPAND (1)) * hbound (DONT_EXPAND, 1);
	     PARAMS_LEN= length (PARAMS (1)) * hbound (PARAMS, 1);

	     IF_ACTION = lookup_stmt ("&if");
	     THEN_ACTION = lookup_stmt ("&then");
	     ELSE_ACTION = lookup_stmt ("&else");
	     SET_ACTION = lookup_stmt ("&set");

	     WHITE = SP || HT || VT || FF;		/* white space */
	end;

	A_code = 0;

	nest_level, state.quote_factor, state.qscan_start = 1;
	added_arg_inside_quotes_sw, inside_quotes_sw, null_arg_sw, parse_args_sw = "0"b;

	abs_data_ptr = A_xd.abs_data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;

	saved_arg_ptr = addr (auto_saved_arg);
	saved_arg_len = maxlength (auto_saved_arg);
	saved_arg_allocated_sw = "0"b;

	overlay_ptr = input_string.ptr;
	overlay_len = input_string.len;
SKIP_LOOP:					/* label for $skip to ignore some keywords */
	iptr = addcharno (overlay_ptr, A_xd.input_pos - 1);
	ilen = overlay_len - A_xd.input_pos + 1;

	i = index (input, NL);			/* skip prev line's trailing whitespace and NL */
	if i ^= 0 then do;
	     if i = 1 then skip_count = 0;		/* just a blank line; don't skip it */
	     else if verify (substr (input, 1, i - 1), WHITE) = 0 then skip_count = i;
	     else skip_count = 0;
	     A_xd.input_pos = A_xd.input_pos + skip_count;
	     iptr = addcharno (iptr, skip_count);
	     ilen = ilen - skip_count;
	end;

	if ilen = 0 then do;
	     A_code = error_table_$end_of_info;
	     return;
	end;

	if label_search_sw then do;
	     char3 = substr (input, 1, 3);
	     if char3 ^= "&be" & char3 ^= "&do" & char3 ^= "&en" & char3 ^= "&la" then do;
						/* not at a &begin, &do, &end or &label stmt */
		call find_next_occurrence ("&begin", A_xd.next_begin_pos, ic (1));
		call find_next_occurrence ("&do", A_xd.next_do_pos, ic (2));
		call find_next_occurrence ("&end", A_xd.next_end_pos, ic (3));
		call find_next_occurrence ("&label", A_xd.next_label_pos, ic (4));
		call find_next_occurrence ("&""", A_xd.next_quote_pos, ic (5));
		call find_next_occurrence ("&-", A_xd.next_comment_pos, ic (6));
		i = MAX_CHARS;
		do j = 1 to hbound (ic, 1);
		     if ic (j) ^= 0 then i = min (i, ic (j));
		end;
		if i = 0 | i = MAX_CHARS then
NO_LABEL:		     if abs_data.in_handler_sw then do;
			A_code = error_table_$end_of_info;
			go to RETURN;
		     end;
		     else do;
			A_xd.this_statement.pos = abs_data.goto_statement_pos;
			A_xd.this_statement.len = abs_data.goto_statement_len;
			call error ("Searching for label """ || rtrim (A_xd.searching_for) || """");
		     end;
		char3 = substr (input_overlay, i, 3);
		if substr (char3, 1, 2) = "&""" then do;  /* skip &"..." */
		     inside_quotes_sw = "1"b;
		     i = i + 2;			/* first skip the &" */
		     do while (inside_quotes_sw);
			j = index (substr (input_overlay, i), """");
			if j = 0 then call error ("Missing end quote for &""");
			if substr (input_overlay, i + j, 1) = """" then  /* imbedded double quote */
			     i = i + j + 1;		/* skip over it and continue inside string */
			else inside_quotes_sw = "0"b;
		     end;
		end;
		else if substr (char3, 1, 2) = "&-" then do;  /* skip comment */
		     j = index (substr (input_overlay, i + 1), NL);  /* skip past end of line */
		     if j = 0 then go to NO_LABEL;
		     i = i + j;
		end;
		A_xd.input_pos = i;
		go to SKIP_LOOP;
	     end;
	end;

	istart = 1;

	A_xd.this_statement.pos = A_xd.input_pos;
	abs_data.next_action = UNDEFINED;

NL_LOOP:	i = index (substr (input, istart), NL);		/* find end of this line */
	if i = 0 then
	     if abs_data.in_handler_sw then i = ilen;	/* tolerate partial line in handler; must be followed by &end */
	     else call error ("Last line does not end in newline; ignored.");
	else if i = 1 then do;			/* null line */
	     A_xd.input_pos = A_xd.input_pos + 1;
	     A_xd.caller_actual_len, A_xd.this_statement.len = 0;
RETURN_NULL_LINE:
	     if trace_sw & command_line.on then call print_trace ("", command_line, NONCONTROL);

	     abs_data.this_action = 0;
	     go to GET_NEXT_STMT;
	end;
	else if i + istart + 1 < ilen then do;		/* not the last line */
	     if substr (input, i + istart - 1, 1) = NL then do;  /* include continuation lines */
		white_len = verify (substr (input, i + istart), WHITE) - 1;
		if white_len = -1 then white_len = 0;
		char2 = substr (input, i + istart + white_len, 2);
		if char2 = "&-" then do;		/* might be continuation broken by comment line */
		     temp_istart = istart;
		     temp_i = i;
		     temp_white_len = white_len;
		     do while (char2 = "&-");		/* or any number of comment lines */
			temp_istart = temp_istart + temp_i + temp_white_len;
			temp_i = index (substr (input, temp_istart), NL);
			temp_white_len = verify (substr (input, temp_i + temp_istart), WHITE) - 1;
			if temp_white_len = -1 then temp_white_len = 0;
			char2 = substr (input, temp_i + temp_istart + temp_white_len, 2);
		     end;
		     if char2 = "&+" then do;		/* yes, it is part of a continuation */
			istart = temp_istart;
			i = temp_i;
			white_len = temp_white_len;
		     end;
		end;
		if char2 = "&+" then do;
		     istart = istart + i + white_len;	/* skip to after the &+ */
		     go to NL_LOOP;
		end;
	     end;
	end;
	saved_ilen = ilen;
	ilen = i + istart - 2;			/* leave off last NL */
	if A_xd.is_input & ^abs_data.trim_whitespace_sw then ipos = 1;
	else do;
	     ipos = verify (input, WHITE);	     	     	     /* skip leading whitespace */
	     if ipos = 0 then do;	     	     	     /* all whitespace */
		A_xd.input_pos = A_xd.input_pos + ilen + 1;
		A_xd.caller_actual_len, A_xd.this_statement.len = ilen;
		substr (caller_buffer, 1, ilen) = substr (input, 1, ilen);
		go to RETURN_NULL_LINE;
	     end;
	end;

	A_xd.this_statement.pos = A_xd.input_pos;
	A_xd.this_statement.len = ilen;

	state.optr = A_xd.caller_buffer_ptr;
	state.omax_len = A_xd.caller_buffer_len;
	state.olen = 0;
	allocated_sw = "0"b;

/* Find out whether it's a control line */

	if substr (input, ipos, 1) = "&" then		/* begins with & */
	     if ilen = ipos then do;			/* & on line by itself = error */
		state.keyword.name = "&";
		go to BAD_AMP_WORD;
	     end;
	     else if substr (input, ipos + 1, 1) = "&" then do;  /* && = & */

		call add_output (state.optr_len, "&");

		ipos = ipos + 2;
		abs_data.this_action = 0;
		go to NOT_CONTROL;
	     end;
	     else if substr (input, ipos + 1, 1) = "-" then do;  /* &-  (comment) */
		if abs_data.comment_line.on & trace_sw & ipos + 1 < ilen then

		     call trace_comment (substr (input, ipos + 2));

		A_xd.input_pos = A_xd.input_pos + ilen + 1;
		go to SKIP_LOOP;
	     end;
	     else do;

		state.keyword.name = "&";		/* prepare to look up a stmt keyword */
		do i = ipos + 1 to ilen while (index (WHITE || "&", substr (input, i, 1)) = 0);
		     state.keyword.name = state.keyword.name || substr (input, i, 1);

		     abs_data.this_action = lookup_stmt ((state.keyword.name));

		     if abs_data.this_action ^= 0 then go to CONTROL_STMT;  /* yes, a statement keyword */
		end;
		go to NOT_CONTROL;

/* A control statement */

CONTROL_STMT:

/* So far we only know it STARTS with a valid control word; it might be the &ready of &ready_proc, or &thenfoo */

		state.keyword.name = "&";		/* make sure we get the whole keyword */
		do i = ipos + 1 to ilen while (index (ALPHA, substr (input, i, 1)) ^= 0);
		     state.keyword.name = state.keyword.name || substr (input, i, 1);
		end;

		abs_data.this_action = lookup_stmt ((state.keyword.name));

		if abs_data.this_action = 0 then	/* could be "&thenfoo", for example */
		     call error ("Invalid statement keyword " || state.keyword.name);

		control_line_sw = CONTROL;
		trace = abs_data.control_line;	/* get trace info for control lines */

		ipos = ipos + length (state.keyword.name);  /* skip the control statement keyword */
		i = verify (substr (input, ipos), WHITE);  /* and the following whitespace */
		if i = 0 then do;			/* done (no args) */
		     ipos, no_args_ipos = ilen + 1;

CONTROL_NOARG:	     if trace_sw & trace.on & (trace.expand = UNEXPANDED | trace.expand = BOTH) then

			call trace_unexpanded (input, trace);

		     go to RETURN_STRING;
		end;
		ipos = ipos + i - 1;		/* skip the whitespace */
		if i = 1 then no_args_ipos = ipos - 1;	/* no white space following control word */
		else no_args_ipos = ipos - 2;		/* restore later if no_args_sw */

		no_args_sw = NO_ARGS_SW (abs_data.this_action);
						/* whether no args is acceptable for this stmt */
		if no_args_sw &
		     (abs_data.this_action = THEN_ACTION | abs_data.this_action = ELSE_ACTION) then
			go to CONTROL_NOARG;	/* don't even look for a comment */

		then_else_allowed_sw = THEN_ELSE_ALLOWED_SW (abs_data.this_action);
						/* whether this stmt can be followed by &then or &else */

		if trace_sw & abs_data.if_sw then do;	  /* test whether to trace */
		     if (abs_data.this_action = THEN_ACTION & ^abs_data.true_sw)
						/* don't trace &then after "&if false" */
		      | (abs_data.this_action = ELSE_ACTION & abs_data.true_sw) then 
						/* don't trace &else after "&if true" */
			     trace_sw = "0"b;
		end;

		parse_args_sw = ^skip_sw & PARSE_ARGS_SW (abs_data.this_action);
		if parse_args_sw then do;		/* parse args separated by whitespace */

		     parsed_args_count = 20;		/* grow later if necessary */
		     if A_xd.area_ptr = null then A_xd.area_ptr = get_system_free_area_ ();

		     allocate parsed_args in (xd_area) set (parsed_args_ptr);

		     parsed_args.count = 0;
		     A_xd.parsed_args_ptr = parsed_args_ptr;
		end;

		else A_xd.parsed_args_ptr, A_xd.arg_ptr = null;  /* take rest of line as single arg */
	     end;

	else do;
	     abs_data.this_action = 0;
NOT_CONTROL:					/* either command line, input line, or comment */
	     no_args_sw, parse_args_sw = "0"b;
	     A_xd.parsed_args_ptr, A_xd.arg_ptr = null;

	     trace = A_xd.trace_lines;
	     control_line_sw = NONCONTROL;
	end;

	if parse_args_sw | then_else_allowed_sw then search_chars = "&()[]" || NL || WHITE;
	else search_chars = "&()[]" || NL;

	inside_quotes_sw = "0"b;
	if abs_data.this_action = SET_ACTION then search_chars = search_chars || """";
						/* see quotes only for &set statement */

	if trace_sw & trace.on then do;
	     if trace.iocb = null then trace.iocb = iox_$user_output;
	     if trace.expand = UNEXPANDED | trace.expand = BOTH then call trace_unexpanded (input, trace);
	end;

START_EXPANDING:
	A_xd.expanded_sw = "0"b;			/* assume until var or param is expanded */

	eof_sw, null_arg_sw = "0"b;

	do while (^eof_sw);

	     i = search (substr (input, ipos), search_chars);  /* next & ) NL also WHITE if parsing args */
	     if i = 0 then do;			/* no more ampersands */
		if nest_level > 1 then		/* see if any unclosed construct */
		     do j = nest_level - 1 by -1 to 1;
			if state_stack (j).keyword.number ^= 0 then
			     if state_stack (j).keyword.number = AF_REF then call error ("No closing bracket.");
			     else call error ("No closing parenthesis.");
		     end;
		if ipos <= ilen then call add_output (state.optr_len, substr (input, ipos));

		ipos = ilen + 1;
		go to RETURN_STRING;
	     end;

	     if i > 1 then call add_output (state.optr_len, substr (input, ipos, i - 1));

	     ipos = ipos + i;

	     searched_char = substr (input, ipos - 1, 1);

	     if searched_char = NL then do;		/* NL || &+ */
CONTIN:		ipos = ipos + verify (substr (input, ipos), WHITE) - 1;
						/* skip white space on next line before &+ or &- */
		if substr (input, ipos, 2) = "&+" then ipos = ipos + 2;  /* if it's &+, skip that too */
	     end;

	     else if searched_char = """" then do;	/* only for parsing &set args */

		if nest_level > 1 then call add_output (state.optr_len, """");
						/* only strip quotes from &set args */

		if ^inside_quotes_sw then do;
		     inside_quotes_sw = "1"b;
		     added_arg_inside_quotes_sw = "0"b;
		end;
		else if substr (input, ipos, 1) = """" then do;  /* double quote is a " inside string */

		     call add_output (state.optr_len, """");
		     ipos = ipos + 1;
		end;
		else do;				/* single quote ends it */
		     if output = "" & parse_args_sw & ^added_arg_inside_quotes_sw then null_arg_sw = "1"b;

		     inside_quotes_sw, added_arg_inside_quotes_sw = "0"b;
		end;
	     end;

	     else if searched_char = ")" then do;

		if nest_level = 1 then call add_output (state.optr_len, ")");
		else do;

		     call save_arg;			/* allocate bigger if necessary */

		     call pop_state (nest_level, state);

		     if state.keyword.number = 0 then
			call add_output (state.optr_len, saved_arg || ")");  /* just (...) */

		     else if state.keyword.number = AF_REF then  /* &[...) */
			call error ("Mismatched brackets.");

		     else do;		     		     /* &(...) or &keyword(...) */

EXPAND_ONE:		if trace.on then state.iafter_pos = ipos;

			if ^skip_sw then call expand (state, saved_arg);	/* add expansion to output */
		     end;
		end;
	     end;

	     else if searched_char = "]" then do;	/* end of &[...] or [...] */

		if nest_level = 1 then call add_output (state.optr_len, "]");
		else do;

		     call save_arg;			/* allocate bigger if necessary */

		     call pop_state (nest_level, state);

		     if state.keyword.number = 0 then
			call add_output (state.optr_len, saved_arg || "]");  /* just [...] */

		     else if nest_level < 1 then call error ("Excess right bracket.");

		     else if state.keyword.number = AF_REF then go to EXPAND_ONE;  /* &[...] */
		     else call error ("Mismatched bracket.");
		end;
	     end;

	     else if searched_char = "(" then do;	/* just plain (...) */

		unspec (state.keyword) = "0"b;
		state.keyword.number = 0;		/* not an exec_com construct */
						/* but have to parse it because ) closes either it or &( */
		call push_state (nest_level, state);

		call add_output (state.optr_len, "(");
	     end;

	     else if searched_char = "[" then do;	/* just plain [...] */

		unspec (state.keyword) = "0"b;
		state.keyword.number = 0;		/* not an exec_com construct */
						/* but we have to parse it because ] closes either it or &[ */
		call push_state (nest_level, state);

		call add_output (state.optr_len, "[");
	     end;

	     else if searched_char = "&" then do;	/* start of a stmt or expandable construct */

		if i >= ilen then call error ("Invalid construct ""&""");

		state.keyword.paren_sw = "0"b;	/* assume till ( encountered */
		if trace.on then do;
		     state.iafter_pos = ipos - 1;
		end;

		next_char = substr (input, ipos, 1);

		if next_char = "-" then do;		/* &-  (comment) */

		     if ipos > 2 & state.olen > 0 & (^A_xd.is_input | abs_data.trim_whitespace_sw) then
						/* strip preceding whitespace from expanded line */
			state.olen = length (rtrim (output, WHITE));

		     i = index (substr (input, ipos + 1), NL);  /* end of line */

		     if i = 0 then do;		/* no continuation */
			if abs_data.comment_line.on & trace_sw then

			     call trace_comment (substr (input, ipos + 1));

			ipos = ilen + 1;		/* skip over comment */
			go to RETURN_STRING;
		     end;
		     else do;			/* continued on next line */
			if abs_data.comment_line.on & trace_sw then

			     call trace_comment (substr (input, ipos + 1, i - 1));

			ipos = ipos + i + 1;	/* position of the &+ or &- */
			go to CONTIN;
		     end;
		end;

/* Not a comment */

		if no_args_sw then go to RETURN_STRING;

		else if next_char = """" then do;	/* &"..." */
		     ipos = ipos + 1;		/* position to after first quote */

		     if trace_sw & trace.on & trace.expand = ALL then do;  /* trace before expanding quoted string */

			call trace_expanded (state, trace_buffer);

			trace_buffer = trace_buffer || substr (input, state.iafter_pos);

			call print_trace ((trace_buffer), trace, control_line_sw);
		     end;

		     call get_quoted_string (input, iptr_len.ipos, state, "0"b);
		end;

		else if next_char = "&" then do;	/* && */

		     if trace.on & trace.expand = ALL then do;  /* trace before expanding && */
			if state.olen > 0 then	/* not beginning of line */
			     trace_buffer = output || substr (input, state.iafter_pos);
			else trace_buffer = substr (input, state.iafter_pos);

			call print_trace ((trace_buffer), trace, control_line_sw);
		     end;

		     call add_output (state.optr_len, "&");  /* translates to a single ; */

		     ipos = ipos + 1;
		end;

		else if next_char = "!" then do;	/* &! = unique name, same for every instance */
		     if abs_data.unique_name = "" then
			abs_data.unique_name = rtrim (unique_chars_ ("0"b));

		     call add_output (state.optr_len, (abs_data.unique_name));

		     ipos = ipos + 1;
		end;

		else do;				/* &CONSTRUCT */
		     if next_char = "(" then do;	/* &(...) */
			unspec (state.keyword) = "0"b;
			state.keyword.number = VAR_REF;
			state.keyword.name = "&";
OPEN_PAREN:		ipos = ipos + 1;		/* skip the ( */
			state.keyword.paren_sw = "1"b;

			call push_state (nest_level, state);
		     end;

		     else if next_char = "[" then do;	/* &[...] */
			ipos = ipos + 1;		/* skip past it */
			unspec(state.keyword) = "0"b;
			state.keyword.af_type = BK_TYPE;
OPEN_AF:			state.keyword.number = AF_REF;
			state.keyword.name = "&";
			state.keyword.bracket_sw = "1"b;

			call push_state (nest_level, state);
		     end;

		     else if next_char = "|" then do;  /* might be &|[ or &||[ */
			if ipos = ilen then go to BAD_AMP_WORD;  /* just &| by itself */
			next_next_char = substr (input, ipos + 1, 1);
			if next_next_char = "[" then do;  /* &|[ */
			     ipos = ipos + 2;	/* skip past it */
			     unspec (state.keyword) = "0"b;
			     state.keyword.af_type = BAR_BK_TYPE;
			     go to OPEN_AF;
			end;
			else if next_next_char = "|" then  /* &||... */
			     if ipos + 2 <= ilen then
				if substr (input, ipos + 2, 1) = "[" then do;  /* &||[ */
				     ipos = ipos + 3;  /* skip past it */
				     unspec (state.keyword) = "0"b;
				     state.keyword.af_type = BAR_BAR_BK_TYPE;
				     go to OPEN_AF;
				end;

			go to BAD_AMP_WORD;		/* some other &|string */
		     end;

		     else do;
			if index (DIGITS, next_char) ^= 0 then do;  /* &1, &2, etc. */
			     ipos, state.iafter_pos = ipos + 1;
			     state.keyword = PARAM_KEYWORD;
			     saved_arg = next_char;
			     go to EXPAND_ONE;
			end;

			else if index ("fqr", next_char) ^= 0 then do;  /* &q1, &rf&n, etc. */
			     i = search (substr (input, ipos), DIGITS || "( " || DELIMS || NL);
			     if i = 0 then do;
				state.keyword.name = substr (input, ipos - 1);
				i = ilen - ipos + 2;
			     end;
			     else state.keyword.name = substr (input, ipos - 1, i);

			     if known_param (state.keyword, (state.keyword.name)) then do;

				ipos, state.iafter_pos = ipos + i - 1;

				if state.n_sw then	/* &q&n, &rf&n, etc. */
				     go to EXPAND_ONE;  /* no need to get numeric arg */

				next_char = substr (input, ipos, 1);
				if index (DIGITS, next_char) ^= 0 then do;  /* &qf1, etc. */
				     saved_arg = next_char;
				     ipos, state.iafter_pos = ipos + 1;  /* skip the digit */
				     go to EXPAND_ONE;
				end;
				else go to KNOWN;
			     end;
			end;

			state.keyword.name = "&";	/* &keyword to look up a char at a time */
			saved_ipos = ipos - 2;	/* to be restored if keyword is &then, &else, etc. */
			found_sw = "0"b;

			do while (^found_sw);

			     state.keyword.name = state.keyword.name || next_char;

			     ipos = ipos + 1;

			     if known_dont_expand (state.keyword.name) then do;
						/* an &word that's a stmt control-arg */

				call add_output (state.optr_len, (state.keyword.name));

				go to END_AMP_WORD;
			     end;

			     if known (state.keyword) then found_sw = "1"b;

			     else do;
				if ipos > ilen then
BAD_AMP_WORD:			     if index (STMTS_STRING, state.keyword.name || " ") ^= 0 then call error
					("Misused statement keyword """ || state.keyword.name || """");
				     else call error ("Unrecognized keyword """ || state.keyword.name || """");

				next_char = substr (input, ipos);
				if index (DELIMS, next_char) ^= 0 then go to BAD_AMP_WORD;
			     end;
			end;

			if state.keyword.control_word_sw then do;  /* another stmt on line: &then, &else, &do */

			     if nest_level > 1 then
				call error ("Nested control statement keyword """ || state.keyword.name || """");

			     abs_data.next_action = lookup_stmt ((state.keyword.name));

			     A_xd.next_statement.pos = saved_ipos + 1;
			     A_xd.next_statement.len,
				A_xd.next_statement.keyword_len = length (state.keyword.name);

			     ipos = saved_ipos;	/* save next stmt for next call to abs_io_expand_ */
			     go to RETURN_STRING;
			end;

KNOWN:			if ^state.keyword.allow_arg_sw then do;  /* don't look for an argument */
NO_ARG:			     saved_arg = DEFAULT_ARG;
			     go to EXPAND_ONE;
			end;

			else if ipos > ilen then
			     if state.keyword.require_arg_sw then
MISSING_ARG:			call error ("Missing argument for """ || state.keyword.name || """");
			     else go to NO_ARG;

			else if substr (input, ipos, 1) = "(" then go to OPEN_PAREN;  /* argument in parens */

			else if state.keyword.digit_arg_sw then  /* accepts a single digit arg: q1, f1, etc. */
			     if index (DIGITS, next_char) ^= 0 then do;
				saved_arg = next_char;
				ipos = ipos + 1;
				go to EXPAND_ONE;
			     end;
			     else go to MISSING_ARG;
			else if ^state.keyword.require_arg_sw then go to NO_ARG;
			else go to MISSING_ARG;
		     end;
END_AMP_WORD:	end;
	     end;					/* end of (searched_char = "&") case */

	     else do;				/* white space; we're parsing args or finding &then */

		if no_args_sw then go to RETURN_STRING;

		i = verify (substr (input, ipos - 1), WHITE);
		if i ^= 0 then
		     if substr (input, ipos + i - 2, 1) = NL then do;  /* end of line before &+ */
			ipos = ipos + i - 2;		/* just skip white space, don't end arg */
			go to NEXT_DELIM;
		     end;
		     else if ilen > ipos + i then
			if substr (input, ipos + i - 2, 2) = "&-" &  /* before comment */
			     index (substr (input, ipos + i), NL) ^= 0 then do;  /* followed by &+ */
				ipos = ipos + i - 2;  /* same: skip white space and don't end arg */
				go to NEXT_DELIM;
			     end;

		if nest_level = 1 & ^inside_quotes_sw then do;  /* outside (), [], or "", this whitesp delimits an arg */

		     if i = 0 then do;		/* end of statement */
			if ipos - 2 < ilen & A_xd.is_input & ^abs_data.trim_whitespace_sw then

			     call add_output (state.optr_len, substr (input, ipos - 1));

			ipos = ilen + 1;		/* else just skip the trailing whitespace */
			eof_sw = "1"b;
		     end;

		     else do;

			if then_else_allowed_sw & ipos + i + 1 < ilen then do;  /* room for &then or &else */
			     char5 = substr (input, ipos + i - 2, 5);
			     if (char5 = "&then" | char5 = "&else") &  /* IS then or else followed by white */
			       (ipos + i + 2 = ilen | index (WHITE, substr (input, ipos + i + 3, 1)) ^= 0) then do;
				ipos = ipos + i - 3;  /* skip whitespace before &then or &else */
				if char5 = "&then" then abs_data.next_action = THEN_ACTION;
				else abs_data.next_action = ELSE_ACTION;

				if nest_level > 1 then  /* not valid inside () or [] */
				     if state.keyword.number = AF_REF then
					call error ("Missing right bracket.");
				     else call error ("Missing right parenthesis.");
				if state.quote_factor > 1 then call error ("Unbalanced quotes.");
				go to RETURN_STRING;
			     end;
			end;

			if parse_args_sw then do;	/* if separating args */
			     ipos = ipos + i - 2;	/* skip white space */

			     if nest_level = 1 & state.quote_factor = 1 /* outside () [] "" */ then do;

				call add_arg (state);  /* pick up the arg we have delimited */

				null_arg_sw = "0"b;
			     end;
			end;
			else do;			/* pick up whitespace */

ADD_SPACE:		     call add_output (state.optr_len, substr (input, ipos - 1, i - 1));

			     ipos = ipos + i - 2;
			end;
		     end;
		end;

		else if i > 0 then go to ADD_SPACE;	/* leave white space intact inside () [] */
NEXT_DELIM:    end;
	end;

RETURN_STRING:
	if inside_quotes_sw then call error ("Unbalanced quotes in &set statement.");

	do while (nest_level > 1 & state.keyword.number = 0);  /* still inside non-ec construct like ( or [ */
	     saved_arg = output;

	     call pop_state (nest_level, state);

	     call add_output (state.optr_len, (saved_arg));
	end;
	if nest_level > 1 then
	     do j = nest_level - 1 by -1 to 1;
		if state_stack (j).keyword.number ^= 0 then
		     if state_stack (j).keyword.number = AF_REF then call error ("Missing right bracket.");
		     else call error ("Missing right parenthesis.");
	     end;

	if expand_label_sw then do;
	     A_label_val_ptr = state.optr;
	     A_label_val_len = state.olen;
	end;

	if no_args_sw then do;			/* we were just looking for comments */
	     ipos = no_args_ipos;
	     parse_args_sw = "0"b;
	     state.olen = 0;
	     state.quote_factor, state.qscan_start = 1;
	end;

	if trace_sw & trace.on & trace.expand ^= UNEXPANDED
	  & abs_data.this_action ^= THEN_ACTION & abs_data.this_action ^= ELSE_ACTION then
	     if parse_args_sw then do;		/* have to print already parsed args too */
		trace_buffer = "";
		if A_xd.parsed_args_ptr ^= null then
		     do parsed_arg_index = 1 to A_xd.parsed_args_ptr -> parsed_args.count;
			trace_buffer = trace_buffer || parsed_arg || " ";
		     end;

		call print_trace (trace_buffer || output, trace, control_line_sw);
	     end;

	     else call print_trace (output, trace, control_line_sw);

	if parse_args_sw then do;
	     if state.olen > 0 then call add_arg (state);  /* there is a last unsaved arg in output buffer */
	     else if null_arg_sw then do;		/* there is an unsaved null arg */
		null_arg_sw = "0"b;
		call add_arg (state);
	     end;
	end;
	else do;					/* the one arg is all of output */
	     if abs_data.this_action = IF_ACTION & skip_sw & state.olen = 0 then
						/* didn't expand skipped &if clause, so fake it */
		call add_output (state.optr_len, "false");  /* otherwise, caller will say "Malformed conditional" */

	     A_xd.arg_ptr = state.optr;
	     A_xd.arg_len = state.olen;
	end;

	if allocated_sw then			/* not using caller's buffer anymore */
	     if abs_data.this_action ^= 0 then do;	/* have to preserve args */
		A_xd.caller_actual_len = 0;		/* return only allocated storage */
		A_xd.allocated_ptr = alloc_ptr;
		A_xd.allocated_buffer_len = alloc_len;
		A_xd.allocated_len = state.olen;
	     end;
	     else do;				/* command or input line; can copy back */
		if state.olen <= A_xd.caller_buffer_len then do;  /* will all fit in caller's buffer */
		     A_xd.caller_actual_len = state.olen;
		     A_xd.allocated_ptr = null;
		     A_xd.allocated_buffer_len, A_xd.allocated_len = 0;
		end;
		else do;				/* part in caller's part in allocated */
		     A_xd.caller_actual_len = A_xd.caller_buffer_len;  /* as much in caller's as fits */
		     A_xd.allocated_buffer_len, A_xd.allocated_len = state.olen - A_xd.caller_actual_len;

		     allocate allocated_buffer in (xd_area) set (A_xd.allocated_ptr);

		     allocated_buffer = substr (output, A_xd.caller_actual_len + 1);
		end;

		substr (caller_buffer, 1, A_xd.caller_actual_len) = substr (alloc_string, 1, A_xd.caller_actual_len);

		free alloc_string in (xd_area);	/* done with our own copy */
	     end;

	else A_xd.caller_actual_len = state.olen;	/* no copying necessary */

	if ^expand_label_sw then do;
	     A_xd.input_pos = A_xd.input_pos + ipos;

/* Skip trailing white space if any */

	     if substr (input_overlay, A_xd.input_pos - 1, 1) ^= NL then  /* not at end of line */
		if ^A_xd.is_input | abs_data.trim_whitespace_sw then do;
		     i = index (substr (input_overlay, A_xd.input_pos), NL);
		     if i = 1 then A_xd.input_pos = A_xd.input_pos + 1;  /* one char to skip, must be white space */
		     else if i ^= 0 then
			if verify (substr (input_overlay, A_xd.input_pos, i - 1), WHITE) = 0 then
			     A_xd.input_pos = A_xd.input_pos + i;  /* skip however much white space */
		end;

/* Skip continuation sequence if any */

	     i = verify (substr (input_overlay, A_xd.input_pos), WHITE);
	     if i ^= 0 then
		if substr (input_overlay, A_xd.input_pos + i - 1, 1) = "&" then
		     if substr (input_overlay, A_xd.input_pos + i, 1) = "+" then
			A_xd.input_pos = A_xd.input_pos + i + 1;

	end;

GET_NEXT_STMT:
	if abs_data.next_action = UNDEFINED & A_xd.input_pos + 1 < input_string.len then do;
						/* look-ahead for abs_io_v2_get_line's sake */
	     call get_next_stmt (input_string.ptr, input_string.len, A_xd.input_pos, A_xd.next_statement);

	     abs_data.next_action = A_xd.next_statement.action;
	end;

RETURN:
	if saved_arg_allocated_sw then free saved_arg_ptr -> saved_arg in (xd_area);

	if ^got_next_stmt & abs_data.noabort then do;
	     call get_next_stmt (input_string.ptr, input_string.len, A_xd.input_pos, A_xd.next_statement);
	end;

	return;
%page;
add_arg: proc (P_state);

/* Adds another parsed_arg to the structure */

dcl 1 P_state like state;
dcl temp_ptr ptr;

	if parsed_args.count >= parsed_args_count then call grow_parsed_args;

	parsed_args.count = parsed_args.count + 1;
	parsed_args.ptr (parsed_args.count) = P_state.optr;
	parsed_args.len (parsed_args.count) = P_state.olen;

	temp_ptr = P_state.optr;			/* avoids PL/1 addcharno bug involving parameters */
	P_state.optr = addcharno (temp_ptr, P_state.olen);
	P_state.omax_len = P_state.omax_len - P_state.olen;  /* stay within allocated range */
	P_state.olen = 0;
	P_state.quote_factor, P_state.qscan_start = 1;
	if inside_quotes_sw then added_arg_inside_quotes_sw = "1"b;

end add_arg;
%page;
add_output: proc (P_ptr_len, P_str);

/* Appends another parsed part (P_str) to the output buffer */

dcl 1 P_ptr_len like state.optr_len;
dcl P_str char (*);
dcl output char (P_ptr_len.olen) based (P_ptr_len.optr);
dcl str_len fixed bin;

	if skip_sw & abs_data.this_action ^= IF_ACTION then return;

	str_len = length (P_str);

	if P_ptr_len.olen + str_len > P_ptr_len.omax_len then do;  /* need to allocate bigger buffer */
	     alloc_len = P_ptr_len.omax_len + str_len + 200;

	     allocate alloc_string in (xd_area) set (alloc_ptr);

	     substr (alloc_string, 1, P_ptr_len.olen) = substr (output, 1, P_ptr_len.olen);
/*	     if allocated_sw then free P_ptr_len.optr -> alloc_string;  */  /* might destroy pushed state */
	     allocated_sw = "1"b;
	     P_ptr_len.optr = alloc_ptr;
	     P_ptr_len.omax_len = alloc_len;
	end;

	P_ptr_len.olen = P_ptr_len.olen + str_len;
	substr (output, P_ptr_len.olen - str_len + 1, str_len) = P_str;

end add_output;
%page;
add_quoted_output: proc (P_ptr_len, P_str, P_requote_sw);

/* Same as add_output but quotes or requotes P_str */
dcl 1 P_ptr_len like state.optr_len;
dcl P_str char (*);
dcl P_requote_sw bit (1);
dcl (quote_len, quote_pos, scan_len) fixed bin (21);

	if skip_sw then return;

/* Bring quote-level scan up to date first */

	if state.qscan_start <= state.olen then do;	/* quote-level scan not up to date yet */
	     if state.qscan_start = 1 & nest_level > 1 then  /* recurse to scan outer level */
		state.quote_factor = compute_nested_quote_factor (nest_level - 1);
	     call compute_quote_factor (state);		/* now compute factor at current level */
	end;

/* Now knowing the quote level at which P_str is to be inserted, modify P_str */

	if P_requote_sw = REQUOTE then do;
						/* insert right number of leading quotes */
	     call add_output (P_ptr_len, copy ("""", state.quote_factor));

	     state.quote_factor = 2 * state.quote_factor;  /* up one for open quote */
	end;

	scan_len = 0;
DOUBLE_LOOP:					/* perform quote doubling while appending P_str */
	quote_pos = index (substr (P_str, scan_len + 1), """");
	if quote_pos > 0 then do;

	     call add_output (P_ptr_len, substr (P_str, scan_len + 1, quote_pos - 1));

	     scan_len = scan_len + quote_pos;
						/* repeat next quote the right number of times */
	     call add_output (P_ptr_len, copy ("""", state.quote_factor));

	     if scan_len < length (P_str) then go to DOUBLE_LOOP;
	     else go to CLOSE_REQUOTE;
	end;

	quote_pos = length (P_str) - scan_len;		/* length of string yet to be added */
	if quote_pos > 0 then

	     call add_output (P_ptr_len, substr (P_str, scan_len + 1, quote_pos));  /* rest of string */

CLOSE_REQUOTE:
	if P_requote_sw = REQUOTE then do;
	     state.quote_factor = divide (state.quote_factor, 2, 17, 0);  /* down one for close quote */
						/* append right number of trailing quotes */
	     call add_output (P_ptr_len, copy ("""", state.quote_factor));
	end;

	state.qscan_start = state.olen + 1;		/* scan is up to date */

	return;


compute_nested_quote_factor: proc (P_level) returns (fixed bin);

/* This internal procedure completes the quote scan up through nest level P_level */

dcl P_level fixed bin;

	if P_level = 0 then return (1);		/* should never happen */

	if state_stack (P_level).qscan_start <= state_stack (P_level).olen then do;  /* not up to date */
	     if state_stack (P_level).qscan_start = 1 & P_level > 1 then  /* recurse */
		state_stack (P_level).quote_factor = compute_nested_quote_factor (P_level - 1);
	     call compute_quote_factor (state_stack (P_level));
	end;

	return (state_stack (P_level).quote_factor);

end compute_nested_quote_factor;


compute_quote_factor: proc (P_state);

/* This internal procedure does the actual scan for a given level */

dcl 1 P_state like state;
dcl local_output char (P_state.olen) based (P_state.optr);

COUNT_LOOP:
	quote_pos = index (substr (local_output, P_state.qscan_start), """");
	if quote_pos > 0 then do;

	     P_state.qscan_start = P_state.qscan_start + quote_pos - 1;
	     quote_len = verify (substr (local_output, P_state.qscan_start), """") - 1; /* number of consecutive quotes */
	     if quote_len < 0 then quote_len = P_state.olen - P_state.qscan_start + 1;
	     P_state.qscan_start = P_state.qscan_start + quote_len;

	     if mod (quote_len, P_state.quote_factor) = 0 then  /* if a multiple of the depth, then */
						/* keep incrementing depth (doubling factor) */
		do while (mod (quote_len, 2 * P_state.quote_factor) ^= 0);
		     quote_len = quote_len - P_state.quote_factor;
		     P_state.quote_factor = 2 * P_state.quote_factor;
		end;

	     else do while (quote_len ^= 0);		/* else keep decrementing depth (undoubling) */
		P_state.quote_factor = divide (P_state.quote_factor, 2, 17, 0);
		quote_len = mod (quote_len, P_state.quote_factor);
	     end;

	     go to COUNT_LOOP;
	end;

	else P_state.qscan_start = P_state.olen + 1;

end compute_quote_factor;

end add_quoted_output;
%page;
error: proc (P_string);

/* Causes abs_io_v2_get_line to print error message and abort ec */
dcl P_string char (*);

	A_code = error_table_$badsyntax;
	A_xd.error_msg = P_string;
	go to RETURN;

end error;
%page;
expand: proc (P_state, P_arg);

dcl 1 P_state like state;
dcl P_arg char (*) varying;
dcl value_str char (value_len) based (value_ptr);
dcl value_var_str char (value_len) varying based (value_ptr);
dcl based_area area based (A_xd.area_ptr);
dcl value_buffer char (1000) varying;
dcl path_string char (168);
dcl short_string char (32) varying;
dcl switch_name char (32);
dcl (alloc_err_sw, traced_sw) bit (1);
dcl (p, value_ptr) ptr;
dcl value_len fixed bin (21);
dcl (i, numeric_arg) fixed bin;

	if P_state.keyword.number > MAX_KEY then go to BAD_AMP_WORD;

	traced_sw = "0"b;

START:	if P_state.keyword.require_number_sw & ^P_state.keyword.n_sw then do;  /* requires numeric arg */
	     if P_arg = DEFAULT_ARG then numeric_arg = 1;	/* default for &AMP, etc. */
	     else do;
		numeric_arg = cv_dec_check_ ((P_arg), code);
		if code ^= 0 then
		     if P_state.keyword.number = PARAM_REF then
			if P_state.keyword.f_sw then
			     call error ("Invalid parameter number """ || P_arg || """");
			else go to VAR_REF;		/* &r(var), &q(var) */
		     else call error ("Invalid numeric argument """ || P_arg || """ for " || P_state.keyword.name);
	     end;
	end;

	if trace_sw & trace.on & trace.expand = ALL & ^traced_sw then do;  /* trace before each expansion */

	     traced_sw = "1"b;

	     call trace_expanded (P_state, trace_buffer);  /* start with what's already been expanded */

	     trace_buffer = trace_buffer || P_state.keyword.name;
	     if P_arg ^= DEFAULT_ARG then		/* some arg was specified */
		if P_state.keyword.paren_sw then	/* arg is enclosed in parens */
		     trace_buffer = trace_buffer || "(" || P_arg || ")";
		else if P_state.keyword.bracket_sw then do;  /* arg is enclosed in brackets &[...] */
		     if P_state.keyword.af_type = BAR_BAR_BK_TYPE then short_string = "||[";
		     else if P_state.keyword.af_type = BAR_BK_TYPE then short_string = "|[";
		     else short_string = "[";
		     trace_buffer = trace_buffer || short_string || P_arg || "]";
		end;
		else trace_buffer = trace_buffer || P_arg;
	     if P_state.iafter_pos <= ilen then		/* not end of line */
		trace_buffer = trace_buffer || substr (input, P_state.iafter_pos);

	     call print_trace ((trace_buffer), trace, control_line_sw);
	end;

	go to EXPAND (P_state.keyword.number);

EXPAND (1):					/* parameter reference */
	A_xd.expanded_sw = "1"b;
/* OBSOLETE
	if P_arg = "0" then do;		(This is the V1 meaning)
	     if P_state.q_sw | P_state.r_sw then

		call add_quoted_output (P_state.optr_len, ec_path, P_state.r_sw);

	     else call add_output (P_state.optr_len, ec_path);

	     return;
	end;
END OF OBSOLETE */
	if P_arg = "0" then				/* &0 is invalid in Version 2 */
	     call error ("Invalid parameter &0");

	arg_max = max (abs_data.arg_count, abs_data.default_arg_count);

	if P_state.n_sw then arg_start = arg_max;	/* &n = last arg */
	else do;
	     arg_start = numeric_arg;
	     if arg_start > arg_max then return;	/* no arg => null string */
	end;

	if P_state.f_sw & ^P_state.n_sw then arg_limit = arg_max;
	else arg_limit = arg_start;

	command_args_ptr = abs_data.arg_ptr;
	command_args_count = abs_data.arg_count;

	do arg_index = arg_start to arg_limit;		/* append each ec arg in range */
						/* arg_limit = max (#args, #defaults) */
	     if arg_index > abs_data.arg_count then do;	/* see if default is defined */
		command_args_ptr = abs_data.default_arg_ptr;
		command_args_count = abs_data.default_arg_count;
		if command_args (arg_index).ptr = null then  /* &undefined = no default value */
		     go to NEXT_ARG;
	     end;

	     if P_state.r_sw then

		call add_quoted_output (P_state.optr_len, command_arg, P_state.r_sw);

	     else call parse_value (P_state, command_arg);

	     if arg_index < arg_limit then call parse_value (P_state, " ");
NEXT_ARG:	end;

	return;

EXPAND (2):					/* variable reference */
VAR_REF:
	A_xd.expanded_sw = "1"b;
	if P_arg = "" then call error ("Invalid variable reference ""&()""");
	if verify (P_arg, DIGITS) = 0 & P_arg ^= "" then do;  /* &(3), etc. */
	     P_state.keyword = PARAM_KEYWORD;
	     go to START;				/* convert numeric arg and retry as parameter */
	end;

	if abs_data.variables_ptr = null then abs_data.variables_ptr = init_variables ();  /* this ec's value seg */

	call value_$get_alloc (abs_data.variables_ptr, "01"b,  /* call this entry because it allocates */
	     (P_arg), A_xd.area_ptr, value_ptr, value_len, code);
	if code ^= 0 then
	     if code ^= error_table_$oldnamerr then do;
		A_code = code;
		A_xd.error_msg = "Error in local value assignments.";
		go to RETURN;
	     end;
	     else if P_arg = "" then call error ("No value for null string.");
	     else call error ("No value for """ || P_arg || """");

	if P_state.q_sw | P_state.r_sw then
	     call add_quoted_output (P_state.optr_len, value_str, P_state.r_sw);

	else call add_output (P_state.optr_len, value_str);

	if value_str = "" & parse_args_sw then null_arg_sw = "1"b;

	free value_str in (xd_area);

	return;

EXPAND (3):					/* active function reference &[...] */
	A_xd.expanded_sw = "1"b;
	value_ptr = addr (value_buffer);		/* start with this and see if big enough */
	value_len = maxlength (value_buffer);
CALL_EVALUATE:

	if ec_data_ptr ^= null () then
	     if codeptr (ec_data.eval_string) ^= null () then do;	/* an af evaluation routine was specified */
		call ec_data.eval_string (null, (P_arg), P_state.keyword.af_type, value_var_str, code);
		go to EVALUATE_CALLED;
	     end;
	call cu_$evaluate_active_string (null, (P_arg), P_state.keyword.af_type, value_var_str, code);
EVALUATE_CALLED:
	if code ^= 0 then do;
	     if code = error_table_$command_line_overflow then do;
		if value_len > maxlength (value_buffer) then free value_var_str in (based_area);

		value_len = value_len * 2;
		alloc_err_sw = "0"b;
		on area alloc_err_sw = "1"b;
		on bad_area_format alloc_err_sw = "1"b;
		on bad_area_initialization alloc_err_sw = "1"b;

		allocate value_var_str in (based_area) set (value_ptr);

		revert area;
		revert bad_area_format;
		revert bad_area_initialization;

		if ^alloc_err_sw then go to CALL_EVALUATE;
	     end;
	     A_code = code;
	     A_xd.error_msg = "Evaluating active function.";
	     go to RETURN;
	end;

	if P_state.keyword.af_type = BAR_BAR_BK_TYPE then

	     if value_var_str = "" & nest_level = 1 then call add_arg (P_state);

	     else call add_output (P_state.optr_len, rtrim (value_var_str));

	else call parse_value (P_state, rtrim (value_var_str));

	if value_len > maxlength (value_buffer) then free value_var_str in (based_area);

	return;

EXPAND (4):					/* &condition_info_ptr */
	go to COND_INFO_PTR;

EXPAND (5):					/* &cond_info_ptr */
COND_INFO_PTR:
	call ioa_$rsnnl ("^p", switch_name, i, abs_data.condition_info.info_ptr);

	call add_output (P_state.optr_len, substr (switch_name, 1, i));

	return;

EXPAND (6):					/* &condition_name */
	go to COND_NAME;

EXPAND (7):					/* &cond_name */
COND_NAME:
	if abs_data.on_info.in_handler_sw then	/* null string if not in &on unit */
	     call add_output (P_state.optr_len, rtrim (abs_data.on_info.condition_name));

	return;

EXPAND (8):					/* &ec_dir */
	call hcs_$fs_get_path_name (input_string.ptr, path_string, i, (""), code);

	call add_quoted_output (P_state.optr_len, substr (path_string, 1, i), QDOUBLE);

	return;

EXPAND (9):					/* &ec_name */
	call add_quoted_output (P_state.optr_len, ec_name, QDOUBLE);
	return;

EXPAND (10):					/* &ec_path */
	call add_quoted_output (P_state.optr_len, ec_path, QDOUBLE);
	return;

EXPAND (11):					/* &ec_switch */
	if ec_data.switch_ptr = null then switch_name = "user_i/o";
	else switch_name = ec_data.switch_ptr -> iocb.name;

	call add_quoted_output (P_state.optr_len, rtrim (switch_name), QDOUBLE);

	return;

EXPAND (12):					/* &handlers */
	if abs_data.cleanup_handler_ptr ^= null then value_buffer = """cleanup""";
	else value_buffer = "";

	do p = abs_data.first_handler_ptr repeat (p -> handler_node.next_ptr) while (p ^= null);
	     if value_buffer ^= "" then value_buffer = value_buffer || " ";
	     value_buffer = value_buffer || requote_string_ (rtrim (p -> handler_node.condition_name));
	end;

	call add_output (P_state.optr_len, (value_buffer));

	return;

EXPAND (13):					/* &in_handler (NOT IMPLEMENTED) */
	go to BAD_AMP_WORD;

EXPAND (14):					/* &is_absin */
	call add_output (P_state.optr_len, (TF (fixed (A_xd.is_absin))));

	return;

EXPAND (15):					/* &is_active_function */
	go to IS_AF;

EXPAND (16):					/* &is_af */
IS_AF:
	call add_output (P_state.optr_len, (TF (fixed (A_xd.is_af))));

	return;

EXPAND (17):					/* &is_attached */
	call add_output (P_state.optr_len, (TF (fixed (abs_data.attach.victim_ptr ^= null))));

	return;

EXPAND (18):					/* &is_defined */
	if verify (P_arg, DIGITS) = 0 & P_arg ^= "" then do;  /* for number: true if ec arg or defined by &default */
	     numeric_arg = cv_dec_check_ ((P_arg), code);
	     if code ^= 0 then go to IS_VAR;
	     if numeric_arg <= abs_data.arg_count then tf_string = "true";
	     else if numeric_arg > abs_data.default_arg_count then tf_string = "false";
	     else do;
		command_args_ptr = abs_data.default_arg_ptr;
		command_args_count = abs_data.default_arg_count;
		if command_args (numeric_arg).ptr = null then tf_string = "false";
		else tf_string = "true";
	     end;

	     call add_output (P_state.optr_len, (tf_string));

	     return;
	end;
IS_VAR:						/* for non-numeric: true if defined by &set */
	if abs_data.variables_ptr = null then abs_data.variables_ptr = init_variables ();

	call add_output (P_state.optr_len,
	     (TF (fixed (value_$defined (abs_data.variables_ptr, "01"b, (P_arg), code)))));

	if code ^= 0 then call error ("Format error in variables.");

	return;

EXPAND (19):					/* &is_input_line */
	call add_output (P_state.optr_len, (TF (fixed (A_xd.is_input))));

	return;

EXPAND (20):					/* &n */
	call ioa_$rsnnl ("^d", short_string, 32, abs_data.arg_count);

	call add_output (P_state.optr_len, (short_string));

	return;

EXPAND (21):					/* &quote (...) (NOT IMPLEMENTED) */
/*
	call add_quoted_output (P_state.optr_len, (P_arg), QDOUBLE);
*/

	go to BAD_AMP_WORD;

EXPAND (22):					/* &requote (...) (NOT IMPLEMENTED) */
/*
	call add_quoted_output (P_state.optr_len, (P_arg), REQUOTE);
*/

	go to BAD_AMP_WORD;

EXPAND (23):					/* &unquote (...) (NOT IMPLEMENTED) */
	go to BAD_AMP_WORD;

EXPAND (24):					/* &was_attached */
	call add_output (P_state.optr_len, (TF (fixed (abs_data.in_handler_sw & abs_data.was_attached_sw))));

	return;

EXPAND (25):					/* &AMP */
	call add_output (P_state.optr_len, copy ("&", numeric_arg));
	return;

EXPAND (26):					/* &BS */
	call add_output (P_state.optr_len, copy (BS, numeric_arg));
	return;

EXPAND (27):					/* &CR */
	call add_output (P_state.optr_len, copy (CR, numeric_arg));
	return;

EXPAND (28):					/* &FF, &NP */
	call add_output (P_state.optr_len, copy (FF, numeric_arg));
	return;

EXPAND (29):					/* &HT */
	call add_output (P_state.optr_len, copy ("	", numeric_arg));
	return;

EXPAND (30):					/* &LF */
	call add_output (P_state.optr_len, copy (NL, numeric_arg));
	return;

EXPAND (31):					/* &NL */
	call add_output (P_state.optr_len, copy (NL, numeric_arg));
	return;

EXPAND (32):					/* &NP = &FF */
	call add_output (P_state.optr_len, copy (FF, numeric_arg));
	return;


EXPAND (33):					/* &QT */
	call add_output (P_state.optr_len, copy ("""", numeric_arg));
	return;

EXPAND (34):					/* &SP */
	call add_output (P_state.optr_len, copy (" ", numeric_arg));
	return;

EXPAND (35):					/* &VT */
	call add_output (P_state.optr_len, copy (VT, numeric_arg));
	return;

end expand;
%page;
find_next_occurrence: proc (P_str, P_saved_pos, P_pos);

/* Find the next occurrence P_pos of the string P_str starting at A_xd.input_pos.
P_saved_pos is one of the saved "next occurrence" values in A_xd, e.g. A_xd.next_do_pos.
If the value of P_saved_pos is already beyond A_xd.input_pos, just set P_pos = P_saved_pos.
Otherwise, compute P_pos and set P_saved_pos = P_pos. */

dcl P_str char (*);
dcl (P_pos, P_saved_pos, i) fixed bin (21);

	if P_saved_pos >= A_xd.input_pos then P_pos = P_saved_pos;
	else do;
	     i = index (input, P_str);
	     if i = 0 then P_pos = MAX_CHARS;		/* agreed meaning is "no more left" */
	     else P_pos = A_xd.input_pos + i - 1;
	     P_saved_pos = P_pos;
	end;

end find_next_occurrence;
%page;
get_next_stmt: proc (A_ptr, A_len, A_pos, A_stmt);

/* For abs_io_v2_get_line's look-ahead: type, po & length of next stmt keyword */
dcl A_ptr ptr;
dcl (A_len, A_pos) fixed bin (21);
dcl 1 A_stmt aligned like expand_data.this_statement;
dcl str char (A_len) based (A_ptr);
dcl key_name char (32);
dcl (i, j, k) fixed bin (21);

	got_next_stmt = "1"b;     
 	if abs_data.noabort then do;
 	     i = index ( substr (str, A_pos), NL) + A_pos - 1;
 	     j = i + 1;
 	     abs_data.position = j;
 	     abs_data.limit = i;
	end;
	i = verify (substr (str, A_pos), WHITE || NL);
	if i = 0 then do;
NO_NEXT:	     A_stmt.action = UNDEFINED;			/* no next statement */
	     A_stmt.pos, A_stmt.len, A_stmt.keyword_len = 0;

	     return;
	end;

	j = A_pos + i - 1;
SEE_NEXT:	if substr (str, j, 1) ^= "&" then do;		/* a non-control line */
	     A_stmt.action, A_stmt.len, A_stmt.keyword_len = 0;
	     return;
	end;

	if substr (str, j + 1, 1) = "-" then do;	/* skip &- comment line */
	     k = index (substr (str, j), NL);
	     if k = 0 then go to NO_NEXT;
	     j = j + k;
	     j = j + verify (substr (str, j), WHITE) - 1;	/* skip leading white space */
	     go to SEE_NEXT;
	end;

	else do;
	     k = search (substr (str, j), WHITE || NL || "(");  /* find end of next token (stmt keyword?) */
	     if k = 0 then key_name = substr (str, j);
	     else key_name = substr (str, j, k - 1);

	     A_stmt.action = lookup_stmt (key_name);

	     if A_stmt.action ^= 0 then
		A_stmt.len, A_stmt.keyword_len = length (rtrim (key_name));
	     else A_stmt.len, A_stmt.keyword_len = 0;	/* non-control line */
	end;

	A_stmt.pos = j;

end get_next_stmt;
%page;
get_quoted_string: proc (P_str, P_ipos, P_state, P_q_sw);

/* Called at &", finds matching end quote and saves string */

dcl P_str char (*);
dcl P_ipos fixed bin (21);
dcl 1 P_state like state;
dcl P_q_sw bit (1);

dcl inside_quotes_sw bit (1);
dcl (i, ipos) fixed bin (21);

	inside_quotes_sw = "1"b;			/* caller saw the &" */
	ipos = P_ipos;

	do while (inside_quotes_sw);

	     i = index (substr (P_str, ipos), """");
	     if i = 0 then call error ("Missing end quote for &""");

	     if ipos + i <= length (P_str) & substr (P_str, ipos + i, 1) = """" then do;
						/* imbedded double quote (= 1 quote) */

		if P_q_sw then call add_quoted_output (P_state.optr_len, substr (P_str, ipos, i - 1) || """", "0"b);

		else call add_output (P_state.optr_len, substr (P_str, ipos, i - 1) || """");

		ipos = ipos + i + 1;
	     end;
	     else do;				/* single quote: closes string */

		if P_q_sw then call add_quoted_output (P_state.optr_len, substr (P_str, ipos, i - 1), "0"b);

		else call add_output (P_state.optr_len, substr (P_str, ipos, i - 1));

		P_ipos = ipos + i;
		inside_quotes_sw = "0"b;
	     end;
	end;

	if output = "" & parse_args_sw then null_arg_sw = "1"b;

end get_quoted_string;
%page;
grow_parsed_args: proc;

/* Allocates more room for the parsed_args structure */
/* Implicit arguments are parsed_args_ptr and parsed_args_count */

dcl old_parsed_args_ptr ptr;

	old_parsed_args_ptr = parsed_args_ptr;
	parsed_args_count = parsed_args_count * 2;	/* more room */

	allocate parsed_args in (xd_area) set (parsed_args_ptr);

	parsed_args_ptr -> parsed_args.count = old_parsed_args_ptr -> parsed_args.count;
	parsed_args_ptr -> parsed_args = old_parsed_args_ptr -> parsed_args;
	A_xd.parsed_args_ptr = parsed_args_ptr;

	free old_parsed_args_ptr -> parsed_args in (xd_area);

end grow_parsed_args;
%page;
init_variables: proc returns (ptr);

/* Gets ptr to this ec's private "value seg" */

dcl value_header (72) fixed aligned based;
dcl variables_ptr ptr;
dcl code fixed bin (35);

	allocate value_header in (abs_data.work_area) set (variables_ptr);

	call value_$init_seg (variables_ptr, 1 /* non-shareable */, addr (abs_data.work_area), 0, code);
	if code ^= 0 then call error ("Unable to allocate variables.");

	return (variables_ptr);

end init_variables;
%page;
known: proc (P_keyword) returns (bit (1));

/* TRUE & fills in P_keyword if P_keyword.name is found in NAMES */

dcl 1 P_keyword like state.keyword;
dcl i fixed bin;

	i = index (NAMES_STRING, P_keyword.name || " ");

	if i = 0 then return ("0"b);
	i = divide (i + length (NAMES (1)), length (NAMES (1)), 17, 0);
	P_keyword.number = i + 3;			/* 1 = PARAM; 3 = VAR; 3 = AF */
	unspec (P_keyword.name_switches) = NAME_SWITCHES (i);
	unspec (P_keyword.param_switches) = "0"b;
	return ("1"b);

end known;
%page;
known_dont_expand: proc (P_name) returns (bit (1));

/* TRUE if P_name is found in DONT_EXPAND (a &keyword that's a stmt control-arg) */

dcl P_name char (32) varying;
dcl i fixed bin;

	i = index (DONT_EXPAND_STRING, P_name || " ");

	return (i ^= 0);

end known_dont_expand;
%page;
known_param: proc (P_keyword, P_name) returns (bit (1));

/* TRUE & fills in P_keyword for parameter prefixes &q, &r, etc. */

dcl 1 P_keyword like state.keyword;
dcl P_name char (32) varying;
dcl i fixed bin;

	i = index (PARAMS_STRING, P_keyword.name || " ");

	if i = 0 then return ("0"b);
	i = divide (i + length (PARAMS (1)), length (PARAMS (1)), 17, 0);
	P_keyword = PARAM_KEYWORD;
	P_keyword.name = P_name;
	unspec (P_keyword.param_switches) = PARAM_SWITCHES (i);
	return ("1"b);

end known_param;
%page;
lookup_stmt: proc (A_key_name) returns (fixed bin);

/* Sees whether A_key_name is a beginning-of-stmt keyword */

dcl A_key_name char (32);

	return (divide (index (STMTS_STRING, A_key_name) + length (STMTS (1)) - 1,
		length (STMTS (1)), 17, 0));

end lookup_stmt;
%page;
parse_value: proc (P_state, P_str);

/* Adds to the output string, meanwhile parsing into arguments */

dcl 1 P_state like state;
dcl P_str char (*);
dcl (vbreak, vstart) fixed bin (21);

	if parse_args_sw & nest_level < 2 & P_state.quote_factor = 1 & ^inside_quotes_sw then do;


	     vstart = 1;
PARSE_ARG:
	     vbreak = search (substr (P_str, vstart), WHITE || "&""");
	     if vbreak ^= 0 then do;

		call add (substr (P_str, vstart, vbreak - 1));

		if substr (P_str, vstart + vbreak - 1, 1) = "&" then
		     if substr (P_str, vstart + vbreak, 1) = """" then do;  /*  &"..."  */
			vstart = vstart + vbreak + 1;

			call get_quoted_string (P_str, vstart, P_state, P_state.q_sw);
		     end;
		     else vstart = vstart + vbreak;	/* continue searching */

		else if substr (P_str, vstart + vbreak - 1, 1) = """" then do;  /* handle regular "..." too */
		     vstart = vstart + vbreak;	/* position past the first quote */

		     call get_quoted_string (P_str, vstart, P_state, P_state.q_sw);
		end;

		else do;
		     if verify (output, WHITE) ^= 0 then call add_arg (P_state);

		     vbreak = vstart + vbreak - 1;	     /* actual position of the start of the white space */
		     vstart = verify (substr (P_str, vbreak), WHITE);
		     if vstart ^= 0 then do;
			vstart = vbreak + vstart - 1;
			go to PARSE_ARG;
		     end;
		end;
	     end;

	     else call add (substr (P_str, vstart));
	end;

	else call add (P_str);


add: proc (P_str);

/* Appends the string either quote_doubled or plain depending on P_state.q_sw */

dcl P_str char (*);

	if P_state.q_sw then call add_quoted_output (P_state.optr_len, P_str, "0"b);

	else call add_output (P_state.optr_len, P_str);

end add;

end parse_value;
%page;
pop_state: proc (P_nest_level, P_state);

/* Process close paren */

dcl P_nest_level fixed bin;
dcl 1 P_state like state;

	P_nest_level = max (P_nest_level - 1, 1);
	P_state = state_stack (P_nest_level);
	alloc_info = alloc_stack (P_nest_level);

end pop_state;
%page;
print_trace: proc (P_str, P_trace, P_control_sw);

dcl P_str char (*);
dcl 1 P_trace aligned like abs_data.command_line;
dcl P_control_sw bit (1);
dcl control_word char (32) varying;

	if ^trace_sw then return;

	if P_control_sw = CONTROL then control_word = rtrim (STMTS (abs_data.this_action)) || " ";
	else control_word = "";

	if P_trace.iocb = null then P_trace.iocb = iox_$user_output;

	call ioa_$ioa_switch_nnl (P_trace.iocb, P_trace.prefix || control_word || "^a^/", P_str);

end print_trace;
%page;
push_state: proc (P_nest_level, P_state);

/* Processes open paren */

dcl P_nest_level fixed bin;
dcl 1 P_state like state;

	state_stack (P_nest_level) = P_state;
	alloc_stack (P_nest_level) = alloc_info;
	P_nest_level = P_nest_level + 1;
	state.optr = addcharno (state.optr, state.olen);
	state.omax_len = state.omax_len - state.olen;	/* stay within allocated range */
	state.olen = 0;
	state.quote_factor, state.qscan_start = 1;

end push_state;
%page;
save_arg: proc;

/* This procedure allocates a bigger saved_arg buffer if necessary to hold a long &[...] or other arg */

	if state.olen > saved_arg_len then do;

	     if saved_arg_allocated_sw then free saved_arg_ptr -> saved_arg in (xd_area);

	     saved_arg_len = state.olen;
	     if A_xd.area_ptr = null then A_xd.area_ptr = get_system_free_area_ ();

	     allocate saved_arg in (xd_area) set (saved_arg_ptr);

	     saved_arg_allocated_sw = "1"b;
	end;

	saved_arg = output;

end save_arg;
%page;
trace_comment: proc (P_str);

dcl P_str char (*);

	if abs_data.comment_line.prefix = "" then

	     call print_trace ("&-" || P_str, abs_data.comment_line, NONCONTROL);

	else call print_trace (P_str, abs_data.comment_line, NONCONTROL);

end trace_comment;
%page;
trace_expanded: proc (P_state, P_buffer);

dcl 1 P_state like state;
dcl P_buffer char (*) varying;
dcl open_char char (4) varying;
dcl i fixed bin;

	     P_buffer = "";

	     if parse_args_sw then do;		/* have to print parsed args too */
		if A_xd.parsed_args_ptr ^= null then
		     do parsed_arg_index = 1 to A_xd.parsed_args_ptr -> parsed_args.count;
						/* traced &set line should show arg grouping */
			if search (parsed_arg, """" || WHITE) ^= 0 & abs_data.this_action = SET_ACTION then
			     P_buffer = P_buffer || requote_string_ (parsed_arg) || " ";
			else P_buffer = P_buffer || parsed_arg || " ";
		     end;
	     end;

	     do i = 1 to nest_level - 1;			/* pick up expanded text of each nesting */
		if state_stack (i).olen > 0 then
		     P_buffer = P_buffer ||
			substr (state_stack (i).optr -> output, 1, state_stack (i).olen);

		if state_stack (i).keyword.number = 0 then open_char = "";
		else if state_stack (i).keyword.number = AF_REF then
		     if state_stack (i).keyword.af_type = BAR_BAR_BK_TYPE then open_char = "||[";
		     else if state_stack (i).keyword.af_type = BAR_BK_TYPE then open_char = "|[";
		     else open_char = "[";
		else open_char = "(";
		P_buffer = P_buffer || state_stack (i).keyword.name || open_char;
	     end;
	     if P_state.olen > 0 then P_buffer = P_buffer || output;

end trace_expanded;
%page;
trace_unexpanded: proc (P_str, P_trace);

dcl P_str char (*);
dcl 1 P_trace aligned like abs_data.command_line;

	if substr (P_str, 1, 5) = "&then" | substr (P_str, 1, 5) = "&else" | P_str = " &do" then return;

	if P_trace.iocb = null then P_trace.iocb = iox_$user_output;

	call ioa_$ioa_switch_nnl (P_trace.iocb, P_trace.prefix || "^a^/", P_str);

end trace_unexpanded;
%page;
/* OTHER EXTERNAL ENTRIES TO abs_io_expand_ */


set: entry (A_vars_ptr, A_var, A_val, A_code);

/* Called by abs_io_v2_get_line to perform &set using abs_data.variables_ptr */

	delete_sw = "0"b;
SET:
	if verify (A_var, DIGITS) = 0 & A_var ^= "" then  /* parameter reference */
	     call error ("Attempt to &set the value of an argument.");
	else do;

	     if A_vars_ptr = null then A_vars_ptr = init_variables ();

	     if delete_sw then call value_$delete (A_vars_ptr, "01"b, A_var, A_code);

	     else call value_$set (A_vars_ptr, "01"b, A_var, A_val, "", A_code);
	end;

	return;

/* end of abs_io_expand_$set */


delete: entry (A_vars_ptr, A_var, A_val, A_code);

/* Called by abs_io_v2_get_line to implement "&set var_name &undefined" */
/* NOTE: calling sequence has to be the same as $set to use common code. */

	delete_sw = "1"b;
	go to SET;

/* end of abs_io_expand_$delete */
%page;
%include abs_io_data;
%page;
%include abs_io_expand;
%page;
%include abs_io_handler_node;
%page;
%include ec_data;
%page;
%include iocb;



end abs_io_expand_;




		    abs_io_list_vars.pl1            08/11/87  1003.9r w 08/11/87  0925.7       54135



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
abs_io_list_vars: proc (A_abs_data_ptr, A_parsed_args_ptr, A_error_msg, A_code);

/* Does &list_variables for abs_io_v2_get_line. Similar to the logic in the value_list command. */
/* Written 06/07/83 by Steve Herbst */


/* Parameters */

dcl (A_abs_data_ptr, A_parsed_args_ptr) ptr;
dcl A_error_msg char (*);
dcl A_code fixed bin (35);

/* Based */

dcl arg char (arg_len) based (arg_ptr);
dcl based_area area based (area_ptr);

/* Automatic */

dcl (default_sw, exclude_first_sw, match_arg_sw, match_sw, val_sw, var_sw) bit (1) aligned;

dcl (area_ptr, arg_ptr) ptr;

dcl (i, name_index) fixed bin;
dcl arg_len fixed bin (21);
dcl code fixed bin (35);

/* External */

dcl error_table_$badstar fixed bin (35) ext;
dcl error_table_$badsyntax fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;

/* Entries */

dcl check_star_name_$entry entry (char(*), fixed bin(35));
dcl get_system_free_area_ entry returns (ptr);
dcl (ioa_, ioa_$nnl) entry options (variable);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl value_$list entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35));

/* Builtins */

dcl (index, null, substr, unspec) builtin;

/* Conditions */

dcl cleanup condition;
%page;
	abs_data_ptr = A_abs_data_ptr;
	parsed_args_ptr = A_parsed_args_ptr;
	A_code = 0;

	match_info_ptr, value_list_info_ptr = null;

	exclude_first_sw, match_sw, match_arg_sw, val_sw, var_sw = "0"b;
	alloc_name_count, alloc_max_name_len = 0;

	if parsed_args_ptr ^= null then
	     do i = 1 to parsed_args.count;

		arg_ptr = parsed_args.ptr (i);
		arg_len = parsed_args.len (i);

		if index (arg, "&") = 1 then

		     if arg = "&exclude" | arg = "&ex" | arg = "&match" then do;
			i = i + 1;
			if i > parsed_args.count then call error ("No value specified for " || arg);
			if ^match_sw & (arg = "&exclude" | arg = "&ex") then exclude_first_sw = "1"b;
			match_sw = "1"b;
			if arg = "&match" then match_arg_sw = "1"b;
			arg_ptr = parsed_args.ptr (i);
			arg_len = parsed_args.len (i);
NAME:
			alloc_name_count = alloc_name_count + 1;
			alloc_max_name_len = max (alloc_max_name_len, arg_len);
		     end;

		     else if arg = "&value" | arg = "&val" then val_sw = "1"b;

		     else if arg = "&variable" | arg = "&var" then var_sw = "1"b;

		     else call error ("Invalid &list_variables control argument " || arg);

		else do;
		     match_sw, match_arg_sw = "1"b;
		     go to NAME;
		end;
	     end;

	if ^val_sw & ^var_sw then val_sw, var_sw = "1"b;	/* default is to print both var name and value */

	default_sw = (alloc_name_count = 0);
	if default_sw then do;
	     alloc_name_count = 1;
	     alloc_max_name_len = 2;
	end;
	else if exclude_first_sw then alloc_name_count = alloc_name_count + 1;
						/* if &exclude is first, start by matching "**" */

/* Allocate and fill the match structure */

	area_ptr = get_system_free_area_ ();

	on cleanup call clean_up;

	allocate match_info in (based_area) set (match_info_ptr);

	unspec (match_info) = "0"b;
	match_info.version = match_info_version_1;
	match_info.name_count = alloc_name_count;
	match_info.max_name_len = alloc_max_name_len;

	if default_sw | exclude_first_sw then do;
	     name_index = 1;
	     match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b;
	     match_info.name (1) = "**";
	end;
	else name_index = 0;

	if ^default_sw then do i = 1 to parsed_args.count;

	     arg_ptr = parsed_args.ptr (i);
	     arg_len = parsed_args.len (i);

	     if index (arg, "&") = 1 then do;

		if arg = "&exclude" | arg = "&ex" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "1"b;
MATCH_ARG:
		     i = i + 1;
MATCH_NAME:
		     arg_ptr = parsed_args.ptr (i);
		     arg_len = parsed_args.len (i);
		     if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" & arg ^= "/" then do;
			match_info.regexp_sw (name_index) = "1"b;
			match_info.name (name_index) = substr (arg, 2, arg_len - 2);
		     end;
		     else do;
			call check_star_name_$entry (arg, code);
			if code = error_table_$badstar then
			     call error ("Invalid starname arg to &list_variables: " || arg);
			match_info.regexp_sw (name_index) = "0"b;
			match_info.name (name_index) = arg;
		     end;
		end;

		else if arg = "&match" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "0"b;
		     go to MATCH_ARG;
		end;
	     end;

	     else do;
		name_index = name_index + 1;
		match_info.exclude_sw (name_index) = "0"b;
		go to MATCH_NAME;
	     end;
	end;

	call value_$list (abs_data.variables_ptr, "01"b, match_info_ptr, area_ptr, value_list_info_ptr, code);
	if code ^= 0 then
	     if code = error_table_$nomatch then call ioa_ ("No variables set.");
	     else do;
		A_error_msg = "";
		A_code = code;
	     end;

/* Print the results */

	else do i = 1 to value_list_info.pair_count;

	     if var_sw then call ioa_$nnl ("^2x^a^[^30t^]",
		substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)),
		val_sw);
	     if val_sw then call ioa_ ("^a", requote_string_ (
		substr (value_list_info.chars, value_list_info.value_index (i), value_list_info.value_len (i))));
	     else call ioa_ ("");
	end;
RETURN:
	call clean_up;

	return;
%page;
clean_up: proc;

	if match_info_ptr ^= null then free match_info_ptr -> match_info in (based_area);
	if value_list_info_ptr ^= null then free value_list_info_ptr -> value_list_info in (based_area);

end clean_up;
%page;
error: proc (P_str);

dcl P_str char (*);

	A_error_msg = P_str;
	A_code = error_table_$badsyntax;

	go to RETURN;

end error;
%page;
%include abs_io_data;
%page;
%include abs_io_expand;
%page;
%include value_structures;


end abs_io_list_vars;




		    abs_io_put_chars.pl1            08/11/87  1003.9r w 08/11/87  0925.5      159345



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


/* format: style3,idind30,ll122,ifthenstmt */

abs_io_put_chars:
     procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_status);

/* Initial coding: 25 June 1979 by J. Spencer Love as specified in MCR 3958					*/
/* Changed to always set absout bc unless "ear -no_set_bit_count" 07/29/81 S. Herbst */
/* Fixed bug setting bit count one line early 03/19/82 S. Herbst */
/* Recompiled for changed abs_data structure 04/12/83 S. Herbst */
/* Changed to turn on absout safety switch while running 05/16/83 S. Herbst */
/* Changed to create absouts through links 11/14/84 Steve Herbst */


/* Parameters											*/

declare	P_iocb_ptr		ptr parameter,
	P_buffer_ptr		ptr parameter,
	P_buffer_len		fixed bin (21) parameter,
	P_attach_data_ptr		ptr parameter,
	P_dir_name		char (*) parameter,
	P_entry_name		char (*) parameter,
	P_truncate		bit (1) aligned parameter,
	P_MSF			bit (1) aligned parameter,
	P_status			fixed bin (35) parameter;

/* Builtins											*/

declare	(addr, binary, divide, length, max, min, mod, null, rtrim, substr)
				builtin;

declare	any_other			condition;

/* Automatic											*/

declare	buffer_len		fixed bin (21),
	buffer_ptr		ptr,
	create_dir_name		char (168),
	create_entry_name		char (32),
	iocb_ptr			ptr,
	mask			bit (36),
	pad_len			fixed bin (21),
	rest_of_buffer_len		fixed bin (21),
	safety_switch		bit (1) aligned,
	seg_max_len		fixed bin (19),
	status			fixed bin (35);

declare	1 branch			aligned like status_branch;

/* Based												*/

declare	buffer			char (buffer_len) based (buffer_ptr),
	output_seg		char (output_file.max_len) based (output_file.seg_ptr);

/* Static												*/

declare	max_buffer_size		fixed bin (21) static;

declare	1 file_is_full		aligned static,
	  2 version		fixed bin initial (0),
	  2 status_code		fixed bin (35);

declare	1 unable_to_do_io		aligned static like file_is_full;
%page;
/* Constants											*/

declare	NULL			char (1) aligned static options (constant) initial ("");

/* External Constants										*/

declare	error_table_$buffer_big	fixed bin (35) external,
	error_table_$dirseg		fixed bin (35) external,
	error_table_$file_is_full	fixed bin (35) external,
	error_table_$moderr		fixed bin (35) external,
	error_table_$no_s_permission	fixed bin (35) external,
	error_table_$unable_to_do_io	fixed bin (35) external,
	sys_info$max_seg_size	fixed bin (35) external;

/* Entries											*/

declare	continue_to_signal_		entry (fixed bin (35)),
	hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
	hcs_$get_link_target	entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	hcs_$get_max_length_seg	entry (ptr, fixed bin (19), fixed bin (35)),
	hcs_$get_safety_sw_seg	entry (ptr, bit (1) aligned, fixed bin (35)),
	hcs_$make_seg		entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
	hcs_$reset_ips_mask		entry (bit (36), bit (36)),
	hcs_$set_bc_seg		entry (ptr, fixed bin (24), fixed bin (35)),
	hcs_$set_ips_mask		entry (bit (36), bit (36)),
	hcs_$set_safety_sw_seg	entry (ptr, bit (1) aligned, fixed bin (35)),
	hcs_$status_long		entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)),
	hcs_$terminate_noname	entry (ptr, fixed bin (35)),
	hcs_$truncate_seg		entry (ptr, fixed bin, fixed bin (35)),
	msf_manager_$open		entry (char (*), char (*), ptr, fixed bin (35)),
	msf_manager_$get_ptr	entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24),
				fixed bin (35)),
	msf_manager_$adjust		entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)),
	msf_manager_$close		entry (pointer),
	terminate_process_		entry (char (*), ptr);
%page;
/* abs_io_put_chars: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_status);				*/

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;	/* get our IOCB, so we can get attach data block.		*/
	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;

	buffer_ptr = P_buffer_ptr;			/* copy parameters so we can play with them		*/
	buffer_len = P_buffer_len;

	if buffer_len < 0 | buffer_len > max_buffer_size
	then do;					/* Punt if given invalid buffer size.			*/
		P_status = error_table_$buffer_big;
		return;
	     end;

	mask = ""b;				/* zero mask if we need to switch output segments		*/

/* The following block ensures that no more data will ever get written into a component than will fit.  The block will
   not be executed if the output segment is exactly filled, or if P_buffer_len is zero.  It will only be executed if
   another output component is required.  Note that the max_length of the output segment(s) is picked up at open time;
   if it is decreased we will take a fault before this code will be executed, and if it is increased, we will never
   take advantage of the additional space.								*/

	do while (buffer_len + output_file.current_len > output_file.max_len);
	     pad_len = output_file.max_len - output_file.current_len;
	     rest_of_buffer_len = buffer_len - pad_len;	/* PL/I compiler doesn't notice common subexpression	*/
	     buffer_len = pad_len;
	     call write ();				/* write as much as will fit in current component		*/
	     buffer_ptr = addr (substr (buffer, buffer_len + 1));
	     buffer_len = rest_of_buffer_len;
	     call get_next_MSF_component ();		/* get next MSF component if possible			*/
	end;

	call write ();

	P_status = 0;

	return;
%page;
/* This entrypoint is called by abs_io_open if the opening mode is stream_input_output.  It opens the specified output
   file.  It is called with the IPS mask set to zero to prevent interruption.  An any_other handler in abs_io_open will
   terminate the process if anything goes wrong.  If the file is already an MSF, it is opened using msf_manager_,
   otherwise it is opened with a call to hcs_$make_seg, which creates it if it does not exist.  The first call is to
   hcs_$status_long because the current length and effective mode are needed, otherwise it would have to make an
   additional call.  In the MSF case, this call is not necessary and will have to be repeated on an MSF component, but
   it isn't known that hcs_$status_minf would suffice until too late.						*/

open:
     entry (P_attach_data_ptr, P_dir_name, P_entry_name, P_truncate, P_MSF, P_status);

	abs_data_ptr = P_attach_data_ptr;

	output_file.seg_ptr, output_file.fcb_ptr = null ();
	output_file.may_be_MSF = P_MSF;

	call hcs_$status_long (P_dir_name, P_entry_name, 1, addr (branch), null (), status);

	if branch.type = Link & (status = 0 | status = error_table_$no_s_permission) then do;
						/* chase link with nonexistent target */
	     call hcs_$get_link_target (P_dir_name, P_entry_name, create_dir_name, create_entry_name, status);
	     if create_dir_name = "" then do;
		P_status = status;
		return;
	     end;
	end;
	else do;
	     create_dir_name = P_dir_name;
	     create_entry_name = P_entry_name;
	end;

	if (status ^= 0 & status ^= error_table_$no_s_permission) | (branch.type ^= Segment & branch.type ^= Directory)
	then do;					/* File does not exist.  We will try to create it.	*/
		branch.type = Segment;
		branch.mode = "01010"b;		/* rw access for check later				*/
		branch.bit_count, branch.current_length = 0;
	     end;
	else if branch.type = Directory & branch.bit_count = 0
	then do;					/* File is a directory.  Punt.			*/
		P_status = error_table_$dirseg;
		return;
	     end;

	if branch.type = Segment
	then call open_segment ();
	else call open_MSF ();

	file_is_full.status_code = error_table_$file_is_full;
	unable_to_do_io.status_code = error_table_$unable_to_do_io;

	P_status = 0;

	return;

PUNT:						/* Target for non-local goto's			*/
	P_status = status;				/* Error occured during open or close.			*/
	return;
%page;
/* The following entrypoint is called by abs_io_close when output_file.seg_ptr ^= null ().  It is called with the IPS
   mask set to zero; an any_other handler in abs_io_close will terminate the process if anything goes wrong.		*/

close:
     entry (P_attach_data_ptr, P_status);

	abs_data_ptr = P_attach_data_ptr;

	if output_file.turn_off_ssw then call hcs_$set_safety_sw_seg (output_file.seg_ptr, "0"b, (0));

	pad_len = mod (-output_file.current_len, 4096);
	if pad_len ^= 0
	then do;
		call hcs_$set_bc_seg (output_file.seg_ptr, 9 * output_file.current_len, status);
		if status ^= 0 then go to PUNT;	/* Something very badly wrong. Punt immediately.		*/
	     end;

	if output_file.fcb_ptr = null ()
	then do;					/* File was SSF.					*/
		call hcs_$terminate_noname (output_file.seg_ptr, (0));
		output_file.seg_ptr = null ();	/* TEMP: can go away when terminate_noname is fixed	*/
	     end;
	else do;					/* File was opened as MSF.				*/
		output_file.seg_ptr = null ();	/* msf_manager_ will terminate this.			*/
		call msf_manager_$close (output_file.fcb_ptr);
	     end;

	P_status = 0;
	return;
%page;
/* The following procedure is used by abs_io_put_chars to actually transfer data into the current output segment.  If a
   new page is touched, the bit count of the segment is set to the end of the page.  Thus, data is never present beyond
   the end of file indicated by the bit count.  The call to set the bit count MUST precede the code which does the
   actual transfer of output, so that data will never be lost.  It is the reponsibility of the caller to determine that
   the data in buffer will fit in the output segment.							*/

write:
     procedure ();

	substr (output_seg, output_file.current_len + 1, buffer_len) = buffer;
	output_file.current_len = output_file.current_len + buffer_len;

	if ^abs_data.open_data.no_set_bc then do;
	     call hcs_$set_bc_seg (output_file.seg_ptr, 9 * output_file.current_len, status);
	     if status ^= 0 then go to PUNT;
	end;

	return;
     end write;
%page;
/* The following procedure is called when the segment which abs_io_put_chars is currently using is filled.  If the file
   was opened as a single segment file, it is terminated and reopened as a multi-segment file.  If -single_segment_file
   (-ssf) was specified at attach time, the process is terminated instead with error_table_$file_is_full as the reason.
   If anything goes wrong while we are switching output segments, there is nowhere for output to go from error
   handlers, so we terminate the process with the reason error_table_$unable_to_do_io.  The output file may have been
   opened as an MSF and then truncated.  In this case, it is still open as an MSF and msf_manager_ will automatically
   convert it back to an MSF.  This is done because we can't depend on the MSF becoming an SSF when truncated since it
   might be upgraded.  The whole operation is done with an IPS mask of zero so nothing can interrupt us.		*/

get_next_MSF_component:
     procedure ();

declare	dir_name			char (168),
	entry_name		char (32);

	on any_other
	     begin;
		if substr (mask, 36, 1)
		then call terminate_process_ ("fatal_error", addr (unable_to_do_io));
		else call continue_to_signal_ ((0));
	     end;

	call hcs_$set_ips_mask (mask, mask);

	if output_file.fcb_ptr = null ()
	then do;					/* Convert from SSF to MSF				*/
		if ^output_file.may_be_MSF then call terminate_process_ ("fatal_error", addr (file_is_full));
		call hcs_$fs_get_path_name (output_file.seg_ptr, dir_name, (0), entry_name, status);
		if status ^= 0 then go to PUNT_MASKED;

		if output_file.turn_off_ssw then do;
		     call hcs_$set_safety_sw_seg (output_file.seg_ptr, "0"b, (0));
		     output_file.turn_off_ssw = "0"b;
		end;

		call hcs_$terminate_noname (output_file.seg_ptr, (0));
		call msf_manager_$open (dir_name, entry_name, output_file.fcb_ptr, status);
		if status ^= 0 then go to PUNT_MASKED;
		output_file.MSF_seg_idx = 1;
	     end;
	else output_file.MSF_seg_idx = output_file.MSF_seg_idx + 1;

	call msf_manager_$get_ptr (output_file.fcb_ptr, output_file.MSF_seg_idx, "1"b, output_file.seg_ptr, (0), status)
	     ;
	if status ^= 0 then go to PUNT_MASKED;

	output_file.current_len = 0;			/* start over at base of new component			*/

	call hcs_$reset_ips_mask (mask, mask);
	return;

PUNT_MASKED:
	call terminate_process_ ("fatal_error", addr (unable_to_do_io));

     end get_next_MSF_component;
%page;
/* This entrypoint is called by abs_io_put_chars$open to open an output file which is a segment, which includes the
   case where the output file does not exist.  It checks that rw access is available, makes it known, gets the max
   length and adjusts the length as specified.  The other entrypoint, open_MSF, is described below.  The two
   entrypoints are merged to reduce the number of non-quick internal procedure calls, and are declared options
   (non-quick) to keep the stack frame small for calls to abs_io_put_chars					*/

open_segment:
     procedure () options (non_quick);

	if (branch.mode & "01010"b) ^= "01010"b
	then do;					/* We must have rw access on the file			*/
		status = error_table_$moderr;
		go to PUNT;
	     end;

	call hcs_$make_seg (create_dir_name, create_entry_name, "", 1010b, output_file.seg_ptr, status);
	if output_file.seg_ptr = null () then go to PUNT; /* We couldn't create the file.  Punt.			*/

	call get_max_len ();			/* Needed by abs_io_put_chars and adjust_length		*/

	if P_truncate
	then do;
		if branch.current_length ^= 0
		then do;
			call hcs_$truncate_seg (output_file.seg_ptr, 0, status);
			if status ^= 0 then go to PUNT;
		     end;
		if branch.bit_count ^= 0
		then do;
			call hcs_$set_bc_seg (output_file.seg_ptr, 0, status);
			if status ^= 0 then go to PUNT;
		     end;
	     end;
	else call adjust_length ();

	call hcs_$get_safety_sw_seg (output_file.seg_ptr, safety_switch, status);
	if status = 0 & ^safety_switch then do;
	     output_file.turn_off_ssw = "1"b;
	     call hcs_$set_safety_sw_seg (output_file.seg_ptr, "1"b, status);
	end;

	return;
%page;
/* The following entrypoint is called by abs_io_put_chars$open to open an MSF for output.  There are two separate
   tracks which are followed depending on whether truncation is required.  In the non-truncation case, the length of
   the last component is adjusted by the same procedure used for SSF's.  This necessitates another call to
   hcs_$status_long to acertain the effective mode and the current length of the component.  The index of the last
   component is one less than the bit count of the MSF directory.  In the truncation case, the length of the file is
   adjusted by a call to msf_manager_$adjust; it is assumed that rw access is present on the MSF if this call succeeds.
   The current length and last component index are known to be zero.						*/

open_MSF:
     entry ();

declare	dir_name			char (168),
	entry_name		char (32);

	call msf_manager_$open (P_dir_name, P_entry_name, output_file.fcb_ptr, status);
	if status ^= 0 then go to PUNT;

	if P_truncate
	then do;
		call msf_manager_$adjust (output_file.fcb_ptr, 0, 0, "110"b, status);
		if status ^= 0 then go to PUNT;
		call msf_manager_$get_ptr (output_file.fcb_ptr, 0, "1"b, output_file.seg_ptr, (0), status);
		if status ^= 0 then go to PUNT;
		call get_max_len ();
		output_file.MSF_seg_idx, output_file.current_len = 0;
	     end;
	else do;
		output_file.MSF_seg_idx = branch.bit_count - 1;
		call msf_manager_$get_ptr (output_file.fcb_ptr, output_file.MSF_seg_idx, "1"b, output_file.seg_ptr,
		     (0), status);
		if status ^= 0 then go to PUNT;
		call hcs_$fs_get_path_name (output_file.seg_ptr, dir_name, (0), entry_name, (0));
		call hcs_$status_long (dir_name, entry_name, 1, addr (branch), null (), (0));
		if (branch.mode & "01010"b) ^= "01010"b
		then do;
			status = error_table_$moderr;
			go to PUNT;
		     end;
		call get_max_len ();
		call adjust_length ();
	     end;

	return;
     end open_segment;
%page;
/* This procedure is called by open_segment and open_MSF to initialize output_file.max_len, which is needed by
   abs_io_put_chars and adjust_len, and max_buffer_size, which is needed by abs_io_put_chars.  If the maximum length of
   the output component is zero, the file cannot be opened.							*/

get_max_len:
     procedure ();

	call hcs_$get_max_length_seg (output_file.seg_ptr, seg_max_len, status);
	if status ^= 0 then go to PUNT;
	if seg_max_len <= 0
	then do;
		status = error_table_$file_is_full;
		go to PUNT;
	     end;
	output_file.max_len = 4 * seg_max_len;
	max_buffer_size = 4 * sys_info$max_seg_size;

	return;

     end get_max_len;

/* The following procedure is called by abs_io_put_chars$open to position the logical length of the file just beyond
   the end of valid data.  All entrypoints in this external block cooperate to ensure that data can never be lost.
   get_max_len must be called before this procedure is called.						*/

adjust_length:
     procedure ();

declare	bc			fixed bin (24);

	output_file.current_len = length (rtrim (substr (output_seg, 1, 4096 * binary (branch.current_length)), NULL));
	pad_len = min (output_file.max_len, divide (max (0, branch.bit_count), 9, 21, 0));

	if mod (output_file.current_len, 4096) = 0
	then output_file.current_len = max (output_file.current_len, pad_len);
	else output_file.current_len = max (output_file.current_len, pad_len - 4095);

	bc = 9 * (output_file.current_len + pad_len);
	if bc ^= branch.bit_count
	then do;
		call hcs_$set_bc_seg (output_file.seg_ptr, bc, status);
		if status ^= 0 then go to PUNT;
	     end;

	return;

     end adjust_length;
%page;
%include abs_io_data;
%page;
%include iocb;
%page;
%include status_structures;



     end abs_io_put_chars;




		    abs_io_v1_get_line.pl1          09/10/87  1500.1rew 09/10/87  1445.1      452628



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




/****^  HISTORY COMMENTS:
  1) change(87-03-05,Parisek), approve(87-07-23,MCR7716),
     audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080):
     Continue execution with next exec_com line when abs_io_data.noabort
     is ON.
  2) change(87-09-02,Parisek), approve(87-09-02,PBF7716),
     audit(87-09-03,Farley), install(87-09-10,MR12.1-1104):
     Handle a nobort operation only if severity 1 errors occur.
                                                   END HISTORY COMMENTS */


/* Original coding: 25 June 1979 by J. Spencer Love
   Modified: 19 August 1981 by Steve Herbst not to loop if &detach gets an error.
   Modified: 14 February 1982 by Gary Palter for new calling sequence of ec_data.eval_string and to convert from
   command_processor_$af to cu_$evaluate_active_string.
   Modified: 7 June 1982 by J. Spencer Love to improve error checking for &then and &else clauses.			*/
/* Recompiled for changes to abs_data structure 04/12/83 S. Herbst */

/* format: style3,ifthenstmt,indcomtxt,indproc,idind30 */

abs_io_v1_get_line:
     procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status);

declare	P_iocb_ptr		ptr,		/* ptr to IOCB of abs_io_ or syn_ attached to abs_io_	*/
	P_buffer_ptr		ptr,		/* ptr to caller's input buffer			*/
	P_buffer_len		fixed bin (21),	/* maximum length (in chars) of caller's buffer		*/
	P_actual_len		fixed bin (21),	/* length of data actually returned			*/
	P_status			fixed bin (35);	/* standard system error code				*/

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

declare	(area, cleanup)		condition;

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

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

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

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

declare	ec_name			char (arg_info.ec_name_len) based (arg_info.ec_name_ptr),
	ec_path			char (arg_info.ec_path_len) based (arg_info.ec_path_ptr),
	P_buffer			char (P_actual_len) based (P_buffer_ptr),
	allocated_chars		char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr),
	return_arg		char (ec_data.return_len) varying based (ec_data.return_ptr);

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

declare	1 arg_array		(abs_data.arg_count) aligned based (abs_data.arg_ptr),
	  2 ptr			ptr,
	  2 len			fixed bin (21),
	  2 quotes		fixed bin (21);
%page;
declare	INIT			bit (1) aligned static options (constant) initial ("0"b),
	UPDATE			bit (1) aligned static options (constant) initial ("1"b);

declare	NL			char (1) static options (constant) initial ("
");

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

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

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

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

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

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

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

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

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

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

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

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

declare	(
	error_table_$noalloc,
	error_table_$command_line_overflow,
	error_table_$end_of_info,
	error_table_$long_record
	)			fixed bin (35) external,
	iox_$user_output		ptr external,
	iox_$user_input		ptr external;

declare	abs_io_control$attach	entry (ptr, ptr, fixed bin (35)),
	abs_io_control$detach	entry (ptr, ptr, fixed bin (35)),
	abs_io_control$sleep	entry (ptr),
	active_fnc_err_		entry () options (variable),
	com_err_			entry () options (variable),
	cu_$arg_list_ptr		entry () returns (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	cu_$evaluate_active_string	entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35)),
	cu_$set_ready_mode		entry (1 aligned like ready_mode),
	hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
	ioa_$general_rs		entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)),
	ioa_$nnl			entry options (variable),
	iox_$find_iocb		entry (char (*), ptr, fixed bin (35)),
	iox_$get_line		entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	iox_$put_chars		entry (ptr, ptr, fixed bin (21), fixed bin (35)),
	logout			entry options (variable),
	signal_io_error_		entry (char (*), ptr, fixed bin (35));
%page;
/* abs_io_v1_get_line: procedure (P_iocb_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status);  */

	call get_ptrs (INIT);			/* the usual housekeeping to interface to the I/O system	*/

	input_reset_sw = "0"b;

/* recursion check. used to protect against &if [io get_line &ec_switch] (e.g., &if [query ...] in absentee)		*/

	do while (abs_data.active);			/* Loop until bit is cleared asynchronously, if set	*/
	     if attachedp ()
	     then do;				/* Not our problem; we can offload this request to attachee */
		     call iox_$get_line (abs_data.attach.save_ptr, P_buffer_ptr, P_buffer_len, P_actual_len, P_status)
			;
		     return;
		end;

	     call signal_io_error_ ("Attempt to invoke parser recursively.  Check for invalid ""&if"" test.", iocb_ptr,
		0);

	     call get_ptrs (INIT);			/* world may have changed, so reinit our view of it	*/
	end;

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

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

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

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

	if abs_data.chars_len > 0 then go to CONTINUE_LONG_RECORD;

/* Timed input mode:  used in absentee processes to simulate interactive usage patterns				*/

	if abs_data.timed_input then call abs_io_control$sleep (abs_data_ptr);

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

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

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

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

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

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

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

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

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

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

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

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

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

	if substr (CL, CL_pos + 4, min (CL_len, 5)) = "_name" then call emit_ec_name ();
	else if substr (CL, CL_pos + 4, min (CL_len - 3, 4)) = "_dir" then call emit_ec_dir ();
	else if substr (CL, CL_pos + 4, min (CL_len - 3, 7)) = "_switch" then call emit_ec_switch ();

	go to EXPAND_AGAIN;

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

	go to EXPAND_MODIFIER;

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

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

	go to EXPAND_AGAIN;

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

	go to EXPAND_AGAIN;

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

	go to EXPAND_MODIFIER;

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

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

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

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

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

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

CHECK_CONTROL:

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

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

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

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

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

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

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

	if abs_data.allocated_chars_ptr ^= null () & abs_data.chars_len <= 0 & abs_data.else_clause_len <= 0
	then free allocated_chars;			/* We don't need the buffer anymore so we can dump it	*/

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

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

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

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

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

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

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

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

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

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

		call reset_input ();
	     end;

	if abs_data.absentee then call logout ();

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	call trace_output (abs_data.comment_line, CL);

	go to get_next_line;

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

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

	go to END_OF_FILE;

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

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

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

	go to END_OF_FILE;

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

	if ec_data_ptr ^= null () & ^attachedp ()
	then do;
		call abs_io_control$attach (abs_data_ptr, null (), status);
		if status ^= 0 then call error (status, "Error while performing ""&attach"".");
	     end;

	go to get_next_line;

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

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

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

	go to get_next_line;

reset_input:
     procedure ();

	if attachedp ()
	then do;
		call abs_io_control$detach (abs_data_ptr, null (), status);
		if status ^= 0 then call error (status, "Error while performing ""&detach"".");
		if input_linep ()
		then do;
			call iox_$get_line (iox_$user_input, P_buffer_ptr, P_buffer_len, P_actual_len, P_status);
			go to EGRESS;
		     end;
	     end;

	return;
     end;
%page;
CONTROL (13):					/* &ready						*/
	string (ready_mode) = ""b;
	ready_mode.flag = trace_mode ();

	if ec_data_ptr ^= null ()
	then if codeptr (ec_data.set_ready_mode) ^= null ()
	     then call ec_data.set_ready_mode (ready_mode);
	     else call cu_$set_ready_mode (ready_mode);
	else call cu_$set_ready_mode (ready_mode);

	go to get_next_line;

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

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

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

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

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

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

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

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

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

trace_control:
     procedure (trace_structure);

declare	1 trace_structure		aligned like abs_data.command_line;

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

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

	if substr (RS, RS_pos + 1) = "on" | substr (RS, RS_pos + 1) = "true" then trace_structure.on = "1"b;
	else if substr (RS, RS_pos + 1) = "off" | substr (RS, RS_pos + 1) = "false" then trace_structure.on = "0"b;
	else if substr (RS, RS_pos + 1, len) = "output_switch" | substr (RS, RS_pos + 1, len) = "osw"
	then if RS_pos + len >= RS_len
	     then trace_structure.iocb = null ();
	     else do;
		     RS_pos = RS_pos + len + verify (substr (RS, RS_pos + len + 2), WHITE);
		     call iox_$find_iocb (substr (RS, RS_pos + 1), trace_structure.iocb, status);
		     if status ^= 0 then call error (status, "Finding stream ""^a"".", substr (RS, RS_pos + 1));
		end;
	else do;
		call warning (0, "Invalid keyword in tracing statement.  ""on"" assumed.");
		trace_structure.on = "1"b;
	     end;

	return;

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

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

declare	switch			ptr;

	do while (trace_structure.on);		/* Do this only if tracing is enabled.			*/
	     if trace_structure.iocb = null ()
	     then switch = iox_$user_output;		/* Default					*/
	     else switch = trace_structure.iocb;

	     call iox_$put_chars (switch, addr (line), length (line), status);
	     if status = 0 then return;		/* Exit if line successfully traced			*/

	     call signal_io_error_ ("Unable to do trace output.  Correct I/O attachments and type ""start"".", switch,
		status);

	     call get_ptrs (UPDATE);			/* Make sure user didn't do too good a job of "correction"	*/
	end;

	return;

     end trace_output;

/* This procedure copies parameters and gets pointers to our databases.  It is called when abs_io_v1_get_line is
   entered and after calling signal_io_error_ to make sure that nothing has changed that we care about.		*/

get_ptrs:
     procedure (update);

declare	update			bit (1) aligned;

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;

	if update
	then do;
		do while (abs_data_ptr ^= iocb_ptr -> iocb.attach_data_ptr);
		     call signal_io_error_ ("Attachment of " || abs_data.io_module_name || " has been moved.",
			P_iocb_ptr, 0);
		     iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
		end;
		return;
	     end;

	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;
	buffer_ptr = P_buffer_ptr;
	buffer_len = P_buffer_len;

	return;

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

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

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

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

	abs_data.nest_level = abs_data.nest_level + 1;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

	go to CONTINUE_THEN;

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

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

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

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

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

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

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

	go to CONTINUE_THEN;

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

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

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

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

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

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

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

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

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

	if start_keyword < 0 then return (-1);

	keyword_pos = RS_pos + start_keyword;

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

	return (keyword_pos);

     end find_clause;
%page;

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

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

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

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

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

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

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

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

	if ec_data_ptr ^= null ()
	then if codeptr (ec_data.eval_string) ^= null ()
	     then call ec_data.eval_string (null (), AF, (bars_len + 1), value, status);
	     else call cu_$evaluate_active_string (null (), AF, (bars_len + 1), value, status);
	else call cu_$evaluate_active_string (null (), AF, (bars_len + 1), value, status);

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

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

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

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

     end conditional;
%page;
/* This utility predicate knows how to determine if some switch is &attached.  It has been designed to be easily
   extended to other cases than the usual &attach in exec_com using the io_call command or iox_$control		*/

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

	return (abs_data.attach.target_ptr ^= null ());

     end attachedp;

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

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

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

	return (ec_data.input_line);

     end input_linep;

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

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

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

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

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

     end emit_ec_name;

emit_ec_dir:
     procedure ();					/* &ec_dir:  The dir containing the input file		*/
						/* This is used to simulate referencing_dir		*/
declare	ec_dir_buf		char (168),
	ec_dir_len		fixed bin,
	ec_dir			char (ec_dir_len) based (addr (ec_dir_buf));

	call copy_up_to_ampersand (6);
	call hcs_$fs_get_path_name (input_string.ptr, ec_dir_buf, ec_dir_len, (""), (0));
	call copy_string (ec_dir, QUOTE);

     end emit_ec_dir;

emit_ec_switch:
     procedure ();					/* &ec_switch:  The I/O switch to read input lines from	*/

declare	ec_switch			char (ec_switch_len) based,
	ec_switch_len		fixed bin;

	call copy_up_to_ampersand (9);
	if ec_data_ptr = null ()
	then do;
		ec_switch_len = length (rtrim (iocb_ptr -> iocb.name));
		call copy_string (addr (iocb_ptr -> iocb.name) -> ec_switch, QUOTE);
	     end;
	else do;
		ec_switch_len = length (rtrim (ec_data.switch_ptr -> iocb.name));
		call copy_string (addr (ec_data.switch_ptr -> iocb.name) -> ec_switch, QUOTE);
	     end;

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

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

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

     end emit_arg_count;

predicate:
     procedure (test, width);

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

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

	return;

     end predicate;

copy_up_to_ampersand:
     procedure (width);

declare	width			fixed bin;

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

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

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

	return;

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

declare	arg_string		char (*),
	quote_modifier		fixed bin;

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

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

	arg_pos = 0;

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

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

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

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

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

	return;

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

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

	new_RS_len = RS_len + len;

	if new_RS_len > buffer_len then call allocate_buffer (new_RS_len);

	RS_len = new_RS_len;

	return;

     end check_len;

allocate_buffer:
     procedure (required_len);

declare	required_len		fixed bin (21),
	new_RS_ptr		ptr,
	new_RS			char (buffer_len) based (new_RS_ptr);

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

	if abs_data.allocated_chars_ptr ^= null ()
	then if required_len <= abs_data.allocated_chars_len
	     then do;				/* Reuse allocated buffer if possible			*/
		     abs_data.allocated_chars_ptr -> RS = RS;
		     buffer_ptr, RS_ptr = abs_data.allocated_chars_ptr;
		     return;
		end;

	buffer_len = divide (16 * required_len + 15, 8, 21, 0);
	if buffer_len > 1044320
	then if required_len > 1044320
	     then call error (0, "Expanded line exceeds implementation restriction of 1044320 characters in length.");
	     else buffer_len = 1044320;		/* Biggest string that can fit in an extensible area	*/

	on area call error (error_table_$noalloc, "Allocating buffer (^d words).", required_len);

	allocate new_RS in (abs_data.work_area);

	revert area;

	new_RS_ptr -> RS = RS;

	if abs_data.allocated_chars_ptr ^= null () then free allocated_chars;

	abs_data.allocated_chars_ptr, buffer_ptr, RS_ptr = new_RS_ptr;
	abs_data.allocated_chars_len = buffer_len;

	return;

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

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

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

	revert area;

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

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

	severity = "1"b;
	go to ERROR_COMMON;

warning:
     entry options (variable);

	severity = "0"b;

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

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

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

	if ec_data_ptr = null ()
	then do;
		complain = com_err_;
		who = rtrim (abs_data.io_module_name);
	     end;
	else do;
		if codeptr (ec_data.error) = null () then
		     if ec_data.active_function
		     then complain = active_fnc_err_;
		     else complain = com_err_;
		else complain = ec_data.error;
		who = ec_data.who_am_i;
	     end;

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

	if ^severity then return;

	if abs_data.noabort then do;
	     get_next_line = EXPAND_NEXT_LINE;
	     go to get_next_line;
	end;

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

	go to END_OF_FILE;

     end error;
%page;
%include abs_io_data;
%page;
%include abs_io_hash;
%page;
%include ec_data;
%page;
%include iocb;

     end abs_io_v1_get_line;




		    abs_io_v2_get_line.pl1          10/04/88  1315.2rew 10/04/88  1311.8      583938



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




/****^  HISTORY COMMENTS:
  1) change(86-03-13,Herbst), approve(86-04-17,MCR7376),
     audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041):
     Fixed bug where null &else failed to close an &if-&then-&else.
  2) change(87-06-04,Parisek), approve(87-07-23,MCR7716),
     audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080):
     Continue execution with next exec_com line when abs_io_data.noabort
     is ON.
  3) change(87-09-18,Parisek), approve(87-09-18,PBF7716),
     audit(87-09-21,Farley), install(87-09-21,MR12.1-1111):
     Set end_ec & goto ERROR_RETURN label when noabort is ON if error
     occurs on the last line of the exec_com.
  4) change(88-08-08,TLNguyen), approve(88-08-08,MCR7934),
     audit(88-09-15,Parisek), install(88-09-16,MR12.2-1111):
     Make the &exit statement and the &goto LABEL statement constructed within
     the &on unit work as documented.  Also fixed a size condition and
     stringrange condition raised while fixing errors.
  5) change(88-09-29,TLNguyen), approve(88-09-29,PBF7934),
     audit(88-09-30,Parisek), install(88-10-04,MR12.2-1128):
     Remove unnessesary label searching within the &label block, and
     make more extensive checks for the value of goto_entry_sw and
     abs_data.label_search_sw in determining what action to take when
     inside an &on unit block in the exec_com/absin.
                                                   END HISTORY COMMENTS */


/* format: off */

abs_io_v2_get_line:  proc (A_iocb_ptr, A_buffer_ptr, A_buffer_len, A_return_len) returns (fixed (35));


/* Implements &version 2 exec_com language; reads and executes control lines from an input file
   until it encounters a non-control line, then returns this expanded line. */

/* Added &print_switch{_nnl} 10/20/81 Steve Herbst */
/* Modified: 15 February 1982 by G. Palter for new calling sequence of ec_data.eval_string */
/* Fixed &if-&then-&else to be impervious to imbedded get_line 04/20/82 Steve Herbst */
/* Fixed to detect all cases of null &then and &else clauses 07/19/82 Steve Herbst */
/* Fixed to detect missing &quit statement 07/28/82 Steve Herbst */
/* Changed to zero xd.label_search_values to be filled in by abs_io_expand_ 10/06/82 Steve Herbst */
/* Fixed &label inside &do group to not destroy block info 11/15/82 Steve Herbst */
/* Fixed &is_af and "Missing &quit statement" line number 12/07/82 Steve Herbst */
/* Fixed &goto to position correctly to 1st char in target line 02/24/83 Steve Herbst */
/* Added &on, &begin, &revert, etc., also added $goto for handler's nonlocal &goto 04/07/83 Steve Herbst */
/* Added &attach &trim on/off 06/02/83 Steve Herbst */
/* Added &list_variables (&lsv) 06/07/83 Steve Herbst */
/* Fixed &if...&then...BLANK LINE&else... 07/22/83 Steve Herbst */
/* Fixed bug causing &on unit to screw up later &if's 10/13/83 Steve Herbst */
/* Fixed &else<NL>&if to be a null &else rather than an &else &if 10/13/83 Steve Herbst */
/* Changed to set abs_data.goto_pl1_label for absentee_listen_, doing &goto from an &on unit 11/17/83 Steve Herbst */
/* Fixed not to wait until non-ctl line to set abs_data.(position limit) 11/30/83 Steve Herbst */
/* Removed useless and undocumented "Missing &quit statement" warning 11/30/83 Steve Herbst */
/* Made &on accept commas as well as white space between condition names 01/25/84 Steve Herbst */
/* Made ec -trace, -no_trace override &trace statements 03/20/84 Steve Herbst */
/* Added &all_types, &all_expansions keywords to &trace 05/03/84 Steve Herbst */
/* Fixed &revert, &signal, &trace to parse result of expansion yielding "token1 token2" 07/18/84 Steve Herbst */
/* Fixed bug that stopped skipping while inside skipped &do-&end 08/03/84 Steve Herbst */
/* Fixed bug where a handler's &end fouled up later &if-&then skipping 08/10/84 Steve Herbst */
/* Fixed &list_variables bug that used default value seg if no variables set 08/10/84 Steve Herbst */
/* Fixed end-of-file processing to log out an absentee only if not executing an &on unit 09/17/84 Steve Herbst */
/* Fixed $goto to record found label in hash table 01/02/85 Steve Herbst */
/* Fixed &on-&end to not require the &end to be followed by a newline character 01/03/85 Steve Herbst */
/* Fixed &goto not to allocate storage if label has already been parsed 02/15/85 Steve Herbst */
/* Fixed to free parsed_args structure allocated by abs_io_expand_ 02/19/85 Steve Herbst */


/* Parameters */

dcl A_goto_label char (*);
dcl (A_iocb_ptr, iocb_ptr) ptr;			/* ptr to IOCB of abs_io_ or syn_ attached to abs_io_ */
dcl (A_abs_data_ptr, A_ec_data_ptr) ptr;			/* ptr to caller's info structures (for $goto) */
dcl (A_buffer_ptr, buffer_ptr) ptr;			/* ptr to caller's input buffer */
dcl (A_buffer_len, buffer_len) fixed bin (21);		/* max length (in chars) of caller's buffer */
dcl (A_return_len, actual_len) fixed bin (21);		/* length of data actually returned */
dcl A_code fixed bin (35);				/* standard status code */
%page;
/* Constants */

/* NOTE: These next five values depend on the values of the STMTS array in abs_io_expand_ */

dcl BEGIN_ACTION fixed bin int static options (constant) init (2);
dcl DO_ACTION fixed bin int static options (constant) init (6);
dcl ELSE_ACTION fixed bin int static options (constant) init (7);
dcl IF_ACTION fixed bin int static options (constant) init (13);
dcl THEN_ACTION fixed bin int static options (constant) init (35);



dcl DO_TYPE fixed bin int static options (constant) init (0);
dcl BEGIN_TYPE fixed bin int static options (constant) init (1);
dcl THEN_TYPE fixed bin int static options (constant) init (2);
dcl ELSE_TYPE fixed bin int static options (constant) init (3);

dcl NO_UPDATE bit (1) int static options (constant) init ("0"b);

dcl ALPHA char (52) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");
dcl DIGITS char (10) int static options (constant) init ("0123456789");
dcl LABEL fixed bin int static options (constant) init (1);
dcl NL char (1) int static options (constant) init ("
");
dcl WHITE_SPACE char (4) int static options (constant) init (" 	");  /* SP HT VT FF */


/* Based */

dcl condition_array (condition_count) char (32) based (condition_array_ptr);

dcl 1 saved_if_info aligned like abs_data.if_info based;

dcl 1 default_args (abs_data.default_arg_count) based (abs_data.default_arg_ptr),
   2 ptr ptr,
   2 len fixed bin (21),
   2 quote_count fixed bin (21);

dcl default_values_ptr ptr;
dcl default_values (abs_data.default_arg_count) char (max_default_len) based (default_values_ptr);

dcl allocated_chars char (abs_data.allocated_chars_len) based (abs_data.allocated_chars_ptr);
dcl ec_path char (arg_info.ec_path_len) based (arg_info.ec_path_ptr);

dcl allocated_buffer char (alloc_len) based (xd.allocated_ptr);
dcl arg char (xd.arg_len) based (xd.arg_ptr);
dcl buffer char (buffer_len) based (buffer_ptr);
dcl goto_name char (goto_name_len) based (goto_name_ptr);
dcl input_string char (input_string.len) based (input_string.ptr);
dcl label_val char (label_val_len) based (label_val_ptr);
dcl remainder char (abs_data.chars_len) based (abs_data.chars_ptr);
dcl return_arg char (ec_data.return_len) varying based (ec_data.return_ptr);
dcl val_string char (val_len) based (val_ptr);
dcl var_string char (var_len) based (var_ptr);

dcl based_area area based (area_ptr);
dcl xd_area area based (xd.area_ptr);


/* Automatic */

dcl 1 xd aligned like expand_data;

dcl (message, switch_name) char (168);
dcl token char (128) varying;
dcl token32 char (32);

dcl (begin_line_sw, goto_entry_sw, nnl_sw, skipping_handler_sw, some_left_sw) bit (1);

dcl area_ptr ptr init (null);
dcl (condition_array_ptr, goto_name_ptr, handler_ptr, label_val_ptr, last_node_ptr, lastp) ptr;
dcl (on_saved_if_ptr, p, saved_if_ptr, saved_label_ptr, test_ptr, val_ptr, var_ptr) ptr;

dcl (active_string_pos, alloc_len, cond_string_len, goto_name_len, handler_len, handler_start) fixed bin (21);
dcl (label_val_len, max_default_len, name_len, saved_goto_pos) fixed bin (21);
dcl (saved_statement_len, saved_statement_pos, tpos, val_len, var_len) fixed bin (21);
dcl (condition_count, hash, i, saved_hash, saved_skip_block_level, search_type) fixed bin;
dcl code fixed bin (35);

dcl (area, bad_area_format, bad_area_initialization, cleanup) condition;


/* External */

dcl error_table_$badsyntax fixed bin (35) ext;
dcl error_table_$command_line_overflow fixed bin (35) ext;
dcl error_table_$end_of_info fixed bin (35) ext;
dcl error_table_$long_record fixed bin (35) ext;
dcl error_table_$noalloc fixed bin (35);
dcl error_table_$notalloc fixed bin (35) ext;

dcl abs_io_control$attach entry (ptr, ptr, fixed bin (35));
dcl abs_io_control$detach entry (ptr, ptr, fixed bin (35));
dcl abs_io_expand_ entry (1 aligned like expand_data, fixed bin (35));
dcl abs_io_expand_$expand_label entry (1 aligned like expand_data, fixed (21), fixed (21), ptr, fixed (21), fixed (35));
dcl (abs_io_expand_$delete, abs_io_expand_$set) entry (ptr, char (*), char (*), fixed bin (35));
dcl abs_io_expand_$label_search entry (1 aligned like expand_data, fixed bin (35));
dcl abs_io_expand_$skip entry (1 aligned like expand_data, fixed bin (35));
dcl abs_io_list_vars entry (ptr, ptr, char (*), fixed bin (35));
dcl (active_fnc_err_, com_err_) entry options (variable);
dcl cu_$evaluate_active_string entry (ptr, char (*), fixed bin, char (*) varying, fixed bin (35));
dcl cu_$arg_list_ptr entry returns (ptr);
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$set_ready_mode entry (1 aligned like ready_mode);
dcl get_system_free_area_ entry returns (ptr);
dcl (ioa_, ioa_$nnl, ioa_$general_rs, ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable);
dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35));
dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl iox_$look_iocb entry (char (*), ptr, fixed bin (35));
dcl iox_$user_input ptr ext;
dcl logout entry;
dcl signal_ entry options (variable);
dcl signal_io_error_ entry (char (*), ptr, fixed bin (35));

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

dcl input_linep bit (1) aligned;

dcl (addcharno, addr, binary, char, charno, codeptr, index, length, max, mod, null) builtin;
dcl (reverse, rtrim, search, substr, translate, unspec, verify) builtin;
%page;
START:
	goto_entry_sw, skipping_handler_sw = "0"b;

	A_code = 0;

	call get_data_ptrs (NO_UPDATE);

	if abs_data.active then
	     if abs_data.attach.save_ptr ^= null then do;	/* use previous attachment */
		call iox_$get_line (abs_data.attach.save_ptr, A_buffer_ptr, A_buffer_len, A_return_len, A_code);
		return (A_code);
	     end;
	     else call recurse_error;
	abs_data.active = "1"b;

	if ^abs_data.in_handler_sw then abs_data.get_line_pl1_label = START;
				/* target for &goto from inside &on unit invoked while inside this program */

	if abs_data.ec_data_ptr = null () then input_linep = "0"b;
	else input_linep = abs_data.ec_data_ptr -> ec_data.input_line;

	if abs_data.chars_len > 0 then do;		/* pending chars to return */

	     if input_linep ^= abs_data.last_input_line_sw then do;  /* changed input/command mode in mid-line */
		abs_data.chars_len = 0;
		free allocated_chars;
		go to EXPAND_NEXT_STMT;			/* flush the rest of the old line */
	     end;

	     if abs_data.chars_len > A_buffer_len then do;  /* return as much as will fit */
		some_left_sw = "1"b;
		actual_len = buffer_len;
	     end;
	     else do;				/* return it all */
		some_left_sw = "0"b;
		actual_len = abs_data.chars_len;
	     end;

	     substr (buffer, 1, actual_len) = substr (remainder, 1, actual_len);

	     if some_left_sw then do;
		abs_data.chars_ptr = addr (substr (remainder, actual_len + 1));
		abs_data.chars_len = abs_data.chars_len - actual_len;
		A_code = error_table_$long_record;
	     end;
	     else do;
		abs_data.chars_len = 0;
		free allocated_chars;
	     end;

RETURN:	     abs_data.last_input_line_sw = input_linep;
	     abs_data.active = "0"b;

	     if ^goto_entry_sw then A_return_len = actual_len;

	     return (A_code);
	end;

/* Initialize local expand_data */

	call init_xd ();

EXPAND_NEXT_STMT:
	if ^goto_entry_sw then do;
	     xd.caller_buffer_ptr = A_buffer_ptr;	/* expanded line will be returned in caller's buffer */
	     xd.caller_buffer_len = A_buffer_len;
	end;

	xd.allocated_ptr = null;
	xd.allocated_len = 0;

	if input_linep then xd.trace_lines = abs_data.input_line;
	else xd.trace_lines = abs_data.command_line;

	if abs_data.if_sw then call test_end_of_if ();

MIGHT_SKIP:
	if xd.parsed_args_ptr ^= null then free xd.parsed_args_ptr -> parsed_args in (xd_area);
	unspec (xd.expander_output) = "0"b;
	xd.arg_ptr, xd.parsed_args_ptr = null;

/* Call the expander */

	saved_statement_pos = xd.this_statement.pos;	/* in case we run off end with no &quit */

	i = 0;                                            /* in case it doesn't get set below we can avoid stringrange error */
	if xd.input_pos > 1 then                          /* to avoid stringrange condition raised when finding the substring */
						/* does the input substring characters begin with NL? */
	     i = verify (substr (input_string, xd.input_pos - 1), NL || WHITE_SPACE);

	if i < 2 then begin_line_sw = "0"b;               /* no, the input substring characters does not start with NL */
	else begin_line_sw = (index (substr (input_string, xd.input_pos - 1, i - 1), NL) ^= 0);

	if begin_line_sw & abs_data.next_action = IF_ACTION then do;  /* <NL>&if always starts a new &if statement */
	     abs_data.if_sw = "0"b;
	     if ^skipping_handler_sw & abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b;
	end;

	if abs_data.label_search_sw then do;
	     call abs_io_expand_$label_search (xd, code);
	     if code ^= 0 then
		if code = error_table_$end_of_info then go to END_OF_FILE;  /* label not found */
		else call error (code, xd.error_msg);
	end;

	else if abs_data.skip_sw then			/* after &if FALSE &then, skip to &else */
	     call abs_io_expand_$skip (xd, code);

	else call abs_io_expand_ (xd, code);

	if code ^= 0 then
	     if code = error_table_$end_of_info then do;
		if saved_statement_pos ^= 0 then xd.this_statement.pos = saved_statement_pos;
		else if xd.this_statement.pos = 0 then xd.this_statement.pos = abs_data.input_string.len - 1;
		go to END_OF_FILE;
	     end;
	     else call error (code, xd.error_msg);

	input_string.limit = max (input_string.limit, xd.input_pos - 1);  /* how far parsed by abs_io_expand_ */
	input_string.position = xd.input_pos;

	parsed_args_ptr = xd.parsed_args_ptr;

	if abs_data.if_sw & begin_line_sw &		/* previous &then or &else clause */
	     abs_data.this_action ^= THEN_ACTION &	/* and current stmt is neither &then nor &else */
	     abs_data.this_action ^= ELSE_ACTION then
		if abs_data.this_action = 0 &		/* except for blank line followed by &then or &else */
		     (abs_data.next_action = THEN_ACTION | abs_data.next_action = ELSE_ACTION) then;
		else do;				/* force end of &if construct */
		     abs_data.if_sw = "0"b;
		     if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b;
		end;

	if abs_data.skip_sw then go to SKIP (abs_data.this_action);

	if abs_data.this_action = 0 then do;

	     if abs_data.label_search_sw then
		go to END_OF_FILE;			/* label search failed (no more &label stmts) */

RETURN_LINE:   if xd.caller_actual_len >= xd.caller_buffer_len then do;  /* no room to append NL */
		if xd.allocated_ptr = null then do;
		     alloc_len = 1;

		     allocate allocated_buffer in (abs_data.work_area) set (xd.allocated_ptr);

		     xd.allocated_buffer_len = 1;
		     xd.allocated_len = 0;
		end;
		xd.allocated_len = xd.allocated_len + 1;  /* append NL */
		substr (allocated_buffer, xd.allocated_len, 1) = NL;
		actual_len = xd.caller_actual_len;
		abs_data.allocated_chars_ptr, abs_data.chars_ptr = xd.allocated_ptr;
		abs_data.allocated_chars_len, abs_data.chars_len = xd.allocated_len;
		A_code = error_table_$long_record;
	     end;
	     else do;				/* fits in caller's buffer */
		substr (buffer, xd.caller_actual_len + 1, 1) = NL;
		actual_len = xd.caller_actual_len + 1;
		A_code = 0;
	     end;

	     go to RETURN;
	end;

	else go to ACTION (abs_data.this_action);
%page;
goto: entry (A_abs_data_ptr, A_ec_data_ptr, A_goto_label) returns (fixed bin (35));

/* Called by absentee_listen_$execute_handler if the handler did a nonlocal &goto */

	goto_entry_sw = "1"b;

	abs_data_ptr = A_abs_data_ptr;
	ec_data_ptr = A_ec_data_ptr;

	call init_xd ();
	xd.caller_buffer_ptr, xd.allocated_ptr = null;
	unspec (xd.trace_lines) = "0"b;
                                                            /* save the location and the length of the line containing "&goto LABEL_NAME" */
                                                            /* for later referenced in the error message when LABEL_NAME not found */
	xd.this_statement.pos = abs_data.goto_statement_pos;
	xd.this_statement.len = abs_data.goto_statement_len;

	goto_name_len = length (rtrim (A_goto_label, WHITE_SPACE));
	allocate goto_name in (abs_data.work_area) set (goto_name_ptr);
	goto_name = A_goto_label;

	go to GOTO_STMT;
%page;
ACTION (0):					/* end of the input file */

END_OF_FILE:
	call reset_input ();			/* implicit &detach at end of file */

	if abs_data.label_search_sw then do;

	     if abs_data.in_handler_sw & ^goto_entry_sw then do;
						/* nonlocal &goto out of &on unit */
		if abs_data.condition_name = "cleanup" then
		     call error (0, "Attempted nonlocal &goto from inside cleanup handler.");
		abs_data.goto_sw, abs_data.exit_sw = "1"b;
		abs_data.goto_label_ptr = addr (saved_label_ptr -> label.name);
		abs_data.goto_label_len = saved_label_ptr -> label.len;
		go to ERROR_RETURN;
	     end;

	     xd.this_statement.pos = saved_goto_pos;
	     xd.this_statement.len = saved_statement_len;

	     if search_type = LABEL then message = "Label ""^a"" not found.";
	     else message = "Search failed for ""^a"".";

	     call error (0, message, saved_label_ptr -> label.name);
	end;

ERROR_RETURN:
	abs_data.eof = "1"b;
	if ^goto_entry_sw then A_return_len = 0;

	if abs_data.absentee & ^abs_data.in_handler_sw then call logout;

	else return (error_table_$end_of_info);
%page;
/* NOTE: These labels correspond to the STMTS array in abs_io_expand_ */

ACTION (1):					/* &attach */
	if ec_data_ptr ^= null & ^attachedp () then do;
	     call abs_io_control$attach (abs_data_ptr, null, code);
	     if code ^= 0 then call error (code, "Error while performing &attach.");
	end;

	if parsed_args_ptr = null then abs_data.trim_whitespace_sw = "1"b;
	else if parsed_args.count = 0 then abs_data.trim_whitespace_sw = "1"b;
	else do;
	     xd.arg_ptr = parsed_args.ptr (1);
	     xd.arg_len = parsed_args.len (1);
	     if arg ^= "&trim" then call error (0, "Invalid &attach control argument " || arg || ".");
	     if parsed_args.count = 1 then abs_data.trim_whitespace_sw = "1"b;
	     else if parsed_args.count > 2 then call error (0, "Too many arguments for &attach.");
	     else do;
		xd.arg_ptr = parsed_args.ptr (2);
		xd.arg_len = parsed_args.len (2);
		if arg = "on" | arg = "true" then abs_data.trim_whitespace_sw = "1"b;
		else if arg = "off" | arg = "false" then abs_data.trim_whitespace_sw = "0"b;
		else call error (0, "Invalid argument to &attach &trim: " || arg);
	     end;
	end;

SET_INPUT_LIMIT:					/* done expanding and executing this control stmt */
	input_string.limit = max (input_string.limit, xd.input_pos - 1);  /* how far parsed by abs_io_expand_ */
	go to EXPAND_NEXT_STMT;


ACTION (2):					/* &begin */
	if abs_data.label_search_sw then do;

	     call execute_begin ();

	     go to SET_INPUT_LIMIT;
	end;
	else call error (0, "&begin not preceded by &on.");


ACTION (3):					/* &call (UNIMPLEMENTED) */
BAD_KEY:	call error (0, "Invalid keyword ^a",
	     substr (input_string, xd.this_statement.pos, xd.this_statement.keyword_len));


ACTION (4):					/* &default */
	call set_defaults (xd.parsed_args_ptr);
	go to SET_INPUT_LIMIT;


ACTION (5):					/* &detach */
	call reset_input ();
	go to SET_INPUT_LIMIT;


ACTION (6):					/* &do */
	call execute_do ();

	go to EXPAND_NEXT_STMT;


ACTION (7):					/* &else */
	abs_data.clause_type = ELSE_TYPE;

	call execute_else ();

	go to SET_INPUT_LIMIT;


ACTION (8):					/* &end */
END_STMT:
	call execute_end ();

	go to SET_INPUT_LIMIT;


ACTION (9):					/* &exit */
	if ^abs_data.in_handler_sw then call error (0, "&exit is allowed only inside an &on unit.");
	if parsed_args_ptr ^= null then do;
	     do i = 1 to parsed_args.count;
		xd.arg_ptr = parsed_args.ptr (i);
		xd.arg_len = parsed_args.len (i);
		if arg = "&continue" then abs_data.on_info.continue_to_signal_sw = "1"b;
		else call error (0, "Invalid &exit control argument " || arg || ".");
	     end;
	end;
	go to END_OF_FILE;


ACTION (10):					/* &entry (UNIMPLEMENTED) */
	go to BAD_KEY;


ACTION (11):					/* &function (UNIMPLEMENTED) */
/*
	block_ptr = allocate_block ();

	block.containing_lex_block_ptr = null;
	block.containing_proc_block_ptr = current_proc_block_ptr;
	block.args_ptr = xd.parsed_args_ptr;
	block.identifier = FUNCTION_TYPE;

	current_proc_block_ptr = block_ptr;
	current_lex_block_ptr = null;
	go to EXPAND_NEXT_STMT;
*/
	go to BAD_KEY;


ACTION (12):					/* &goto */
	abs_data.goto_statement_pos = xd.this_statement.pos;
	abs_data.goto_statement_len = xd.this_statement.len;

	goto_name_len, xd.arg_len = length (rtrim (arg, WHITE_SPACE));
	allocate goto_name in (abs_data.work_area) set (goto_name_ptr);
	goto_name = arg;

GOTO_STMT:
	label_ptr = lookup_label (abs_data.labels_ptr, goto_name, hash);  /* see if the right &label was seen */

	if label_ptr ^= null then do;			/* already compiled label */
	     xd.input_pos = label.statement_pos + label.statement_len + 1;
	     if label.lex_block_ptr ^= null then do;	/* target is inside a &do group */
		abs_data.if_info = label.lex_block_ptr -> block.if_info;

/* Check for &goto into a &do group (not allowed).
   When &proc's are added, check for &goto's into &proc's too. */

		do test_ptr = abs_data.current_lex_block_ptr
		  repeat (test_ptr -> block.containing_lex_block_ptr)
		  while (test_ptr ^= label.lex_block_ptr);
		     if test_ptr = null then call error (0, "&goto into a &do group");
		end;
	     end;
	     abs_data.current_lex_block_ptr = label.lex_block_ptr;
	     free goto_name in (abs_data.work_area);
	     if goto_entry_sw then do;
		input_string.limit = max (input_string.limit, xd.input_pos - 1);
		input_string.position = xd.input_pos;
		return (0);			/* return from $goto */
	     end;
	     else go to EXPAND_NEXT_STMT;		/* start executing after the label stmt */
	end;

	saved_label_ptr = allocate_label (goto_name);	/* create a node for the &label when found */
	saved_hash = hash;				/* save everything */
	saved_goto_pos = xd.this_statement.pos;
	saved_statement_len = xd.this_statement.len;

	abs_data.label_search_sw = "1"b;
	unspec (xd.label_search_values) = "0"b;		/* next &do, &end, etc. for searching */
	xd.searching_for = goto_name;			/* for error message */
	search_type = LABEL;
	free goto_name in (abs_data.work_area);
	go to EXPAND_NEXT_STMT;


ACTION (13):					/* &if */
	call execute_if ();

	go to SET_INPUT_LIMIT;


ACTION (14):					/* &label */
	xd.arg_len = length (rtrim (arg, WHITE_SPACE));
	if abs_data.label_search_sw & search_type = LABEL then
	     if arg = saved_label_ptr -> label.name then do;  /* the one we want */
		label_ptr = saved_label_ptr;
		hash = saved_hash;
		xd.input_pos = xd.this_statement.pos + xd.this_statement.len + 1;  /* begin executing from here */
		abs_data.label_search_sw = "0"b;
		go to GOT_LABEL;
	     end;

	label_ptr = allocate_label (arg);
	hash = mod (binary (unspec (char (arg, 2)), 18) + length (arg), 61);
GOT_LABEL:					/* compile label for finding later */
	label.lex_block_ptr = abs_data.current_lex_block_ptr;  /* &goto to here restores all of this stuff */
	label.statement_pos = xd.this_statement.pos;
	label.statement_len = xd.this_statement.len;

	if goto_entry_sw & ^abs_data.label_search_sw then do;
	     input_string.limit = max (input_string.limit, xd.input_pos - 1);
	     input_string.position = xd.input_pos;
	end;
	else input_string.limit = xd.input_pos;

	if xd.expanded_sw then do;			/* was an expandable label */
						/* thread into xlabel chain */
	     if abs_data.first_xlabel_ptr = null then abs_data.first_xlabel_ptr = label_ptr;
	     if abs_data.last_xlabel_ptr ^= null then
		abs_data.last_xlabel_ptr -> label.next_ptr = label_ptr;
	     abs_data.last_xlabel_ptr = label_ptr;
	     label.next_ptr = null;			/* last in chain */
	end;

	else do;
						/* else thread into hash tree of constant labels */
	     if abs_data.labels_ptr = null then abs_data.labels_ptr = allocate_hash_table ();

	     label.next_ptr = abs_data.labels_ptr -> hash_table (hash);
	     abs_data.labels_ptr -> hash_table (hash) = label_ptr;  /* thread in as first node for hash */
	end;

	if goto_entry_sw & ^abs_data.label_search_sw then return (0);
						/* return from $goto */
	else go to EXPAND_NEXT_STMT;


ACTION (15):					/* &leave (UNIMPLEMENTED) */
	go to BAD_KEY;


ACTION (16):					/* &list_variables */
LIST_VARIABLES_STMT:
	if abs_data.variables_ptr = null then call ioa_ ("No variables set.");
	else do;
	     call abs_io_list_vars (abs_data_ptr, parsed_args_ptr, message, code);
	     if code ^= 0 then call error (code, message);
	end;

	go to SET_INPUT_LIMIT;


ACTION (17):					/* &lsv (synonym for &list_variables) */
	go to LIST_VARIABLES_STMT;


ACTION (18):					/* &on */
	if parsed_args_ptr = null then
NO_ON_ARGS:    call error (0, "No condition names specified for &on statement.");
	if parsed_args.count = 0 then go to NO_ON_ARGS;

	if abs_data.next_action ^= BEGIN_ACTION then
NO_BEGIN:	     call error (0, "&on statement not followed by &begin");

	cond_string_len = 0;
	do i = 1 to parsed_args.count;
	     cond_string_len = cond_string_len + parsed_args.len (i) + 1;
	end;
begin;
dcl cond_string char (cond_string_len) varying;
	cond_string = "";
	do i = 1 to parsed_args.count;
	     xd.arg_ptr = parsed_args.ptr (i);
	     xd.arg_len = parsed_args.len (i);
	     cond_string = cond_string || arg || " ";
	end;
	cond_string = translate (cond_string, " ", ",");

	condition_count = 0;
	i = verify (cond_string, " ");
	do while (i > 0 & i < cond_string_len);
	     condition_count = condition_count + 1;
	     i = i + index (substr (cond_string, i), " ") - 1;
	     if verify (substr (cond_string, i), " ") = 0 then i = cond_string_len;
	     else i = i + verify (substr (cond_string, i), " ") - 1;
	end;


	allocate condition_array in (abs_data.work_area) set (condition_array_ptr);

	condition_count = 0;
	i = verify (cond_string, " ");
	do while (i > 0 & i < cond_string_len);
	     name_len = index (substr (cond_string, i), " ") - 1;
	     if name_len > 32 then call error (0, "Condition name ^a longer than 32 characters.",
		substr (cond_string, i, name_len));
	     condition_count = condition_count + 1;
	     condition_array (condition_count) = substr (cond_string, i, name_len);
	     i = i + name_len;
	     if verify (substr (cond_string, i), " ") = 0 then i = cond_string_len;
	     else i = i + verify (substr (cond_string, i), " ") - 1;
	end;
end;

	i = index (substr (input_string, xd.input_pos), "&begin");
	if i = 0 then go to NO_BEGIN;
	xd.input_pos = xd.input_pos + i + length ("&begin") - 1;  /* position past &begin */
	if substr (input_string, xd.input_pos, 1) = NL then xd.input_pos = xd.input_pos + 1;  /* and newline */

	handler_start = xd.input_pos;
	handler_ptr = addcharno (input_string.ptr, xd.input_pos - 1);
	
	call execute_begin ();

	allocate saved_if_info in (abs_data.work_area) set (on_saved_if_ptr);
	on_saved_if_ptr -> saved_if_info = abs_data.if_info;

	saved_skip_block_level = abs_data.skip_block_level;
	abs_data.skip_block_level = 1;
	abs_data.skip_sw, skipping_handler_sw = "1"b;

	go to SET_INPUT_LIMIT;

GOT_HANDLER:
	do i = xd.input_pos by -1 to 1 while (substr (input_string, i, 4) ^= "&end"); end;
	if i = 0 then
NO_ON_END:     call error (0, "Missing &end following &on...&begin.");
	else if index (ALPHA, substr (input_string, i + 4, 1)) ^= 0 then go to NO_ON_END;
	handler_len = i - handler_start;		/* length of handler text not including &end */
	if substr (input_string,xd.input_pos, 1) = NL then xd.input_pos = xd.input_pos + 1;  /* and trailing newline */

	do i = 1 to condition_count;

	     if condition_array (i) = "cleanup" then do;	/* treat cleanup special */
		if abs_data.cleanup_handler_ptr = null then do;
		     allocate handler_node in (abs_data.work_area) set (abs_data.cleanup_handler_ptr);
		     abs_data.cleanup_handler_ptr -> handler_node.condition_name = "cleanup";
		     abs_data.cleanup_handler_ptr -> handler_node.next_ptr = null;
		end;
		abs_data.cleanup_handler_ptr -> handler_node.ptr = handler_ptr;
		abs_data.cleanup_handler_ptr -> handler_node.len = handler_len;
	     end;
	     else do;

/* Is there already a handler for this condition? */

		if abs_data.first_handler_ptr = null then do;  /* no handlers at all */
		     allocate handler_node in (abs_data.work_area) set (handler_node_ptr);
		     handler_node.condition_name = condition_array (i);
		     handler_node.next_ptr = null;
		     abs_data.first_handler_ptr = handler_node_ptr;
		end;

		else do;
		     do handler_node_ptr = abs_data.first_handler_ptr repeat (handler_node.next_ptr)
			while (handler_node_ptr ^= null);
			     if handler_node.condition_name = condition_array (i) then go to SET_HANDLER;
			     last_node_ptr = handler_node_ptr;
		     end;

		     allocate handler_node in (abs_data.work_area) set (handler_node_ptr);
		     handler_node.condition_name = condition_array (i);
		     handler_node.next_ptr = null;
		     last_node_ptr -> handler_node.next_ptr = handler_node_ptr;
		end;

SET_HANDLER:	handler_node.ptr = handler_ptr;
		handler_node.len = handler_len;
	     end;
	end;

	abs_data.if_info = on_saved_if_ptr -> saved_if_info;
	free on_saved_if_ptr -> saved_if_info in (abs_data.work_area);

	go to SET_INPUT_LIMIT;
	     

ACTION (19):					/* &print */
	call ioa_ ("^a", arg);
	go to SET_INPUT_LIMIT;


ACTION (20):					/* &print_nnl */
	call ioa_$nnl ("^a", arg);
	go to SET_INPUT_LIMIT;


ACTION (21):					/* &print_switch */
	nnl_sw = "0"b;
PRINT_SWITCH:
	i = search (arg, WHITE_SPACE);
	if i = 0 then i = xd.arg_len + 1;
	switch_name = substr (arg, 1, i - 1);

	call iox_$look_iocb (switch_name, iocb_ptr, code);
	if code ^= 0 then call error (code, "^a", switch_name);

	if nnl_sw then call ioa_$ioa_switch_nnl (iocb_ptr, "^a", substr (arg, i + 1));
	else call ioa_$ioa_switch (iocb_ptr, "^a", substr (arg, i + 1));
	go to SET_INPUT_LIMIT;


ACTION (22):					/* &print_switch_nnl */
	nnl_sw = "1"b;
	go to PRINT_SWITCH;


ACTION (23):					/* &procedure (UNIMPLEMENTED)*/
PROC_STMT:
/*
	block_ptr = allocate_block ();

	block.containing_lex_block_ptr = null;
	block.containing_proc_block_ptr = current_proc_block_ptr;
	block.args_ptr = xd.parsed_args_ptr;
	block.identifier = PROC_TYPE;

	current_proc_block_ptr = block_ptr;
	current_lex_block_ptr = null;
	go to EXPAND_NEXT_STMT;
*/
	go to BAD_KEY;


ACTION (24):					/* &proc (synonym for &procedure) */
	go to PROC_STMT;


ACTION (25):					/* &quit */
	if xd.caller_actual_len ^= 0 then
	     call warning (0, "&quit accepts no arguments.");
	go to END_OF_FILE;


ACTION (26):					/* &ready */
READY_STMT:
	ready_mode.flag = get_ready_mode ();
	ready_mode.pad = "0"b;
	if ec_data_ptr ^= null then
	     if codeptr (ec_data.set_ready_mode) ^= null then do;  /* ready proc specified (e.g., by absentee) */
		call ec_data.set_ready_mode (ready_mode);
		go to SET_INPUT_LIMIT;
	     end;

	call cu_$set_ready_mode (ready_mode);
	go to SET_INPUT_LIMIT;


ACTION (27):					/* &ready_mode (synonym for &ready) */
	go to READY_STMT;


ACTION (28):					/* &ready_proc */
	if ec_data_ptr ^= null then ec_data.call_ready_proc = get_ready_mode ();
	go to SET_INPUT_LIMIT;


ACTION (29):					/* &repeat (UNIMPLEMENTED) */
	go to BAD_KEY;


ACTION (30):					/* &resignal */
/*
   THIS IS THE WRONG IMPLEMENTATION BECAUSE IT RE-INVOKES HANDLERS ABOVE THIS ONE.

	if ^abs_data.in_handler_sw then call error (0, "&resignal is allowed only inside an &on unit.");

	saved_condition_name = abs_data.handler_node_ptr -> handler_node.condition_name;
	abs_data.handler_node_ptr -> handler_node.condition_name = "";   temp. disable handler for this cond 

	call signal_ ((abs_data.condition_name), abs_data.mc_ptr, abs_data.info_ptr, abs_data.wc_ptr);

	abs_data.handler_node_ptr -> handler_node.condition_name = saved_condition_name;
*/
	go to BAD_KEY;


ACTION (31):					/* &return */
	if functionp () then do;			/* called as [exec_com] */
	     if xd.arg_len > ec_data.return_len then
		call warning (error_table_$command_line_overflow,
		     "Expanded value length of ^d characters exceeds return argument length of ^d characters.",
		     xd.arg_len, ec_data.return_len);

	     return_arg = arg;
	end;

	else call ioa_ ("^a", arg);			/* called as a command */
	go to END_OF_FILE;

ACTION (32):					/* &revert */
	if abs_data.in_handler_sw then call error (0, "Cannot execute &revert inside an &on unit.");
	if parsed_args_ptr = null then call error (0, "No argument specified for &revert.");

	do i = 1 to parsed_args.count;
	     xd.arg_ptr = parsed_args.ptr (i);
	     xd.arg_len = parsed_args.len (i);

	     do token = first_token (arg, tpos) repeat (next_token (arg, tpos)) while (token ^= "");

		if token = "cleanup" then
		     if abs_data.cleanup_handler_ptr = null then
NO_HANDLER:
			call warning (0, "(&revert) No &on unit for " || arg);
		     else abs_data.cleanup_handler_ptr = null;

		else do;
		     p = abs_data.first_handler_ptr;
		     lastp = null;
		     do while (p ^= null);
			if p -> handler_node.condition_name = token then do;
						/* free the node */
			     if lastp = null then abs_data.first_handler_ptr = p -> handler_node.next_ptr;
			     else lastp -> handler_node.next_ptr = p -> handler_node.next_ptr;
			     free p -> handler_node in (abs_data.work_area);
			     go to END_REVERT_LOOP;
			end;
			else do;
			     lastp = p;
			     p = p -> handler_node.next_ptr;
			end;
		     end;
		end;
END_REVERT_LOOP:
	     end;
	end;
	go to SET_INPUT_LIMIT;


ACTION (33):					/* &set */
	if parsed_args_ptr = null then
NO_SET_ARGS:   call error (0, "No arguments specified for &set.");
	if parsed_args.count = 0 then go to NO_SET_ARGS;

	if mod (parsed_args.count, 2) ^= 0 then do;	/* odd number of args */
	     var_ptr = parsed_args.ptr (parsed_args.count);
	     var_len = parsed_args.len (parsed_args.count);
	     call error (0, "Missing last value; no value set for ""^a"".", var_string);
	end;

	do i = 1 by 2 to parsed_args.count - 1;		/* test all args first to rule out integers */
	     var_ptr = parsed_args.ptr (i);
	     var_len = parsed_args.len (i);
	     if verify (var_string, DIGITS || WHITE_SPACE) = 0 then
		call error (0, "Invalid syntax in var name ""^a""; all white space and digits.", var_string);
	end;

	do i = 1 by 2 to parsed_args.count - 1;
	     var_ptr = parsed_args.ptr (i);
	     var_len = parsed_args.len (i);
	     val_ptr = parsed_args.ptr (i + 1);
	     val_len = parsed_args.len (i + 1);

	     if val_string = "&undefined" | val_string = "&undef" then
		call abs_io_expand_$delete (abs_data.variables_ptr, var_string, "", code);

	     else call abs_io_expand_$set (abs_data.variables_ptr, var_string, val_string, code);
	     if code ^= 0 then call error (code, xd.error_msg);
	end;
	go to SET_INPUT_LIMIT;


ACTION (34):					/* &signal */
	token = first_token (arg, tpos);
	if next_token (arg, tpos) ^= "" then
	     call error (0, "&signal accepts only one condition name: " || rtrim (arg));

	if abs_data.in_handler_sw & token = abs_data.condition_name then
	     call error (0, "Attempt to &signal " || rtrim (token) || " from within "
		|| rtrim (token) || " &on unit.");

	abs_data.input_string.position = xd.input_pos;

	token32 = token;
	call signal_ (token32);

	xd.input_pos = abs_data.input_string.position;	/* a handler's &goto may have changed it */
	go to SET_INPUT_LIMIT;


ACTION (35):					/* &then */
	abs_data.clause_type = THEN_TYPE;

	call execute_then ();

	go to SET_INPUT_LIMIT;


ACTION (36):					/* &trace */
	call set_trace;
	go to SET_INPUT_LIMIT;


ACTION (37):					/* &until (UNIMPLEMENTED) */
	go to BAD_KEY;


ACTION (38):					/* &version */
	call error (0, "The ""&version"" statement can only be the first line of the program.");


ACTION (39):					/* &while (UNIMPLEMENTED) */
	go to BAD_KEY;
%page;
/* NOTE: These labels (except 0) correspond to the STMTS array in abs_io_expand_ */

SKIP (0):						/* non-control stmt */

SKIP_TEST:
	if abs_data.if_sw then call test_end_of_if ();	/* done skipping? */

	else if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b;

	if ^abs_data.skip_sw & skipping_handler_sw then do;
	     skipping_handler_sw = "0"b;
	     abs_data.skip_block_level = saved_skip_block_level;
	     go to GOT_HANDLER;
	end;

	else go to MIGHT_SKIP;			/* loop to call abs_io_expand_ again */

SKIP (1):
	go to SKIP_TEST;

SKIP (2):						/* &begin */
	call execute_begin ();

	abs_data.skip_block_level = abs_data.skip_block_level + 1;
	go to SKIP_TEST;

SKIP (3): SKIP (4): SKIP (5):
	go to SKIP_TEST;

SKIP (6):						/* &do */
	call execute_do ();

	abs_data.skip_block_level = abs_data.skip_block_level + 1;
	go to SKIP_TEST;

SKIP (7):						/* &else */
	abs_data.clause_type = ELSE_TYPE;

	call execute_else ();

	go to SKIP_TEST;

SKIP (8):						/* &end */
	call execute_end ();

	go to SKIP_TEST;

SKIP (9): SKIP (10): SKIP (11): SKIP (12):
	go to SKIP_TEST;

SKIP (13):					/* &if */
	call execute_if ();

	go to SKIP_TEST;

SKIP (14): SKIP (15):
SKIP (16): SKIP (17): SKIP (18): SKIP (19):
SKIP (20): SKIP (21): SKIP (22): SKIP (23):
SKIP (24): SKIP (25): SKIP (26): SKIP (27):
SKIP (28): SKIP (29): SKIP (30): SKIP (31):
SKIP (32): SKIP (33): SKIP (34):
	go to SKIP_TEST;

SKIP (35):					/* &then */
	abs_data.clause_type = THEN_TYPE;
	call execute_then ();
	go to SKIP_TEST;

SKIP (36): SKIP (37): SKIP (38): SKIP (39):
	go to SKIP_TEST;
%page;
/**/
allocate_block: proc returns (ptr);

dcl block_ptr ptr;

	on area call error (error_table_$noalloc, "Allocating program block.");
	on bad_area_format call error (error_table_$notalloc, "Allocating program block.");
	on bad_area_initialization call error (error_table_$notalloc, "Allocating program block.");

	allocate block in (abs_data.work_area) set (block_ptr);

	block_ptr -> block.prev_block_ptr = abs_data.last_block_ptr;
	abs_data.last_block_ptr = block_ptr;

	block_ptr -> block.keyword_pos = xd.this_statement.pos;
	block_ptr -> block.if_info = abs_data.if_info;
	block_ptr -> block.statement_end_pos = 0;

	return (block_ptr);

end allocate_block;
/**/
%page;
allocate_hash_table: proc returns (ptr);

/* Allocates a labels hash table for use by lookup_label */

dcl labels_ptr ptr;

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

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

	revert area;
	revert bad_area_format;
	revert bad_area_initialization;

	return (labels_ptr);

end allocate_hash_table;
%page;
allocate_label: proc (P_label_name) returns (ptr);

/* allocates a single label node to be threaded by the caller */

dcl P_label_name char (*);
dcl label_ptr ptr;

	on area call error (error_table_$noalloc, "Allocating label ""^a""", P_label_name);
	on bad_area_format call error (error_table_$notalloc,
	     "Allocating label ""^a""", P_label_name);
	on bad_area_initialization call error (error_table_$notalloc,
	     "Allocating label ""^a""", P_label_name);

	current_label_ptr = addr (P_label_name);
	current_label_len = length (P_label_name);

	allocate label in (abs_data.work_area) set (label_ptr);

	revert area;
	revert bad_area_format;
	revert bad_area_initialization;

	label_ptr -> label.name = P_label_name;
	label_ptr -> label.statement_pos = input_string.position;
	label_ptr -> label.statement_len = 0;		/* until set by caller */
	label_ptr -> label.next_ptr = null;

	return (label_ptr);

end allocate_label;
%page;
attachedp: proc returns (bit (1) aligned);

/* TRUE if input is being read from the file (&attach) */

	if abs_data_ptr = null then return ("0"b);
	else return (abs_data.attach.target_ptr ^= null);

end attachedp;
%page;
conditional: proc returns (bit (1) aligned);

/* TRUE if expanded string = "true", FALSE if "false", otherwise strip off brackets and
   evaluate by calling the command processor to expand an active string */

dcl active_string char (active_string_len) based (active_string_ptr);
dcl (active_string_len, temp_len) fixed bin (21);
dcl (active_string_ptr, saved_ptr, temp_ptr) ptr;
dcl bars_len fixed bin (21);
dcl free_sw bit (1);
dcl temp_string char (temp_len) based (temp_ptr);
dcl value char (8) varying;

	if xd.allocated_ptr ^= null then do;	/* rest-of-line allocated, have to copy */

	     active_string_len = xd.caller_actual_len + xd.allocated_len;
	     if area_ptr = null then area_ptr = get_system_free_area_ ();
	     free_sw = "1"b;
	     on cleanup free active_string in (area_ptr -> based_area);

	     allocate active_string in (area_ptr -> based_area) set (active_string_ptr);

	     temp_ptr = xd.caller_buffer_ptr;
	     temp_len = xd.caller_actual_len;
	     substr (active_string, 1, temp_len) = temp_string;

	     temp_ptr = xd.allocated_ptr;
	     temp_len = xd.allocated_len;
	     substr (active_string, xd.caller_actual_len + 1, temp_len) = temp_string;
	end;
	else do;
	     free_sw = "0"b;
	     active_string_ptr = xd.arg_ptr;
	     active_string_len = xd.arg_len;
	end;

	active_string_pos = verify (active_string, WHITE_SPACE);
	active_string_len = active_string_len - verify (reverse (active_string), WHITE_SPACE) + 1;

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

	else if active_string = "false" then return ("0"b);

/* Also accept [...], |[...], ||[...] for compatibility */

	if substr (active_string, active_string_pos, 1) = "|" then
	     if substr (active_string, active_string_pos + 1, 1) = "|" then bars_len = 2;  /* ||[ */
	     else bars_len = 1;			/* |[ */
	else bars_len = 0;

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

	saved_ptr = active_string_ptr;
	active_string_ptr = addr (substr (active_string, active_string_pos + bars_len + 1));
	active_string_len = active_string_len - bars_len - 2;
	if ec_data_ptr ^= null then
	     if codeptr (ec_data.eval_string) ^= null then do;  /* an af evaluation routine was specified */
		call ec_data.eval_string (null, active_string, bars_len + 1, value, code);
		go to EVALUATED;
	     end;

	call cu_$evaluate_active_string (null, active_string, bars_len + 1, value, code);
EVALUATED:
	if free_sw then do;
	     active_string_ptr = saved_ptr;
	     free active_string in (area_ptr -> based_area);
	end;

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

	if value = "true" then return ("1"b);
	else if value = "false" then return ("0"b);
	else call error (0, "Invalid ""&if"" value ""^a""; must be true or false.", value);

end conditional;
%page;
error: proc options (variable);

/* Prints an error message (ec syntax or whatever) and skips to end of file */

dcl based_ec_string char (based_ec_len) based (based_ec_ptr);
dcl based_ec_ptr ptr;
dcl based_ec_len fixed bin (21);
dcl (error_pos, line_len, line_number, line_start) fixed bin (21);
dcl complain entry variable options (variable);
dcl statement_ptr ptr;
dcl statement char (xd.this_statement.len) based (statement_ptr);
dcl message char (4096);
dcl who char (72) varying;
dcl severity_sw bit (1);				/* ON for skip to end of file, OFF for warning only */
dcl end_ec bit (1);					/* Note end of file */
dcl status_ptr ptr;
dcl status fixed bin (25) based (status_ptr);

	severity_sw = "1"b;				/* skip to end of file after printing error */
	go to ERROR_COMMON;


warning: entry options (variable);

/* Prints a warning message and returns */

	severity_sw = "0"b;

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

	if abs_data.in_handler_sw & ^goto_entry_sw then do;
						/* count line numbers in parent ec if inside &on unit */
	     based_ec_ptr = abs_data.parent_abs_data_ptr -> abs_data.input_string.ptr;
	     based_ec_len = abs_data.parent_abs_data_ptr -> abs_data.input_string.len;
	     error_pos = xd.this_statement.pos + charno (abs_data.handler_node_ptr -> handler_node.ptr)
		- charno (based_ec_ptr);
	end;
	else do;
	     based_ec_ptr = abs_data.input_string.ptr;
	     based_ec_len = abs_data.input_string.len;
	     error_pos = xd.this_statement.pos;
	end;

	line_number = 0;				/* calculate line number of error */
	do line_start = 0 repeat (line_start + line_len + 1) while (line_start <= error_pos);
	     line_len = index (substr (based_ec_string, line_start + 1), NL) - 1;
	     if line_len < 0 then do;
		end_ec = "1"b;
		line_len = error_pos - line_start;
	     end;
	     line_number = line_number + 1;
	end;

	if ec_data_ptr = null then do;
	     complain = com_err_;
	     who = rtrim (abs_data.io_module_name);
	end;
	else do;
	     if codeptr (ec_data.error) = null then
		if ec_data.active_function then complain = active_fnc_err_;
		else complain = com_err_;
	     else complain = ec_data.error;
	     who = ec_data.who_am_i;
	end;

	if status = error_table_$badsyntax then status = 0;

	statement_ptr = addr (substr (input_string, xd.this_statement.pos));

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

	if severity_sw then do;
	     if end_ec then go to ERROR_RETURN;
	     if abs_data.noabort then do;
		actual_len = 0;
		A_code = 0;
		go to RETURN;
	     end;
	     else go to ERROR_RETURN;
	end;

end error;
%page;
execute_begin: proc;

	block_ptr = allocate_block ();

	block.containing_lex_block_ptr = abs_data.current_lex_block_ptr;
	block.containing_proc_block_ptr = abs_data.current_proc_block_ptr;
	block.args_ptr = null;
	block.identifier = BEGIN_TYPE;

	block.if_info = abs_data.if_info;
	abs_data.if_sw = "0"b;
	abs_data.prev_if_ptr = null;	

	abs_data.current_lex_block_ptr = block_ptr;

end execute_begin;
%page;
execute_do: proc;

	block_ptr = allocate_block ();

	block.containing_lex_block_ptr = abs_data.current_lex_block_ptr;
	block.containing_proc_block_ptr = abs_data.current_proc_block_ptr;
	block.args_ptr = null;
	if abs_data.clause_type = THEN_TYPE | abs_data.clause_type = ELSE_TYPE then
	     block.identifier = abs_data.clause_type;
	else block.identifier = DO_TYPE;

	block.if_info = abs_data.if_info;
	abs_data.if_sw = "0"b;
	abs_data.prev_if_ptr = null;

	abs_data.current_lex_block_ptr = block_ptr;

end execute_do;
%page;
execute_else: proc;

	if ^abs_data.if_sw | abs_data.got_else_sw then call error (0, "&else not preceded by &if");

	abs_data.got_else_sw = "1"b;

	if abs_data.skip_block_level = 0 then

/* Unless inside an &if being skipped in its entirety (abs_data.prev_if_ptr -> saved_if_info.skip_sw is ON),
   or inside a &do-&end block being skipped (abs_data.skip_block_level > 0),
   decide whether to skip this &else clause depending on value of the &if conditional. */

	     if abs_data.prev_if_ptr = null then call set_skip (abs_data.true_sw);
	     else if ^abs_data.prev_if_ptr -> saved_if_info.skip_sw then call set_skip (abs_data.true_sw);

end execute_else;
%page;
execute_end: proc;

dcl (saved_this_action, saved_next_action) fixed bin;

	block_ptr = abs_data.current_lex_block_ptr;
	if block_ptr = null then call error (0, "&end not preceded by &do or &on...&begin");

	saved_this_action = abs_data.this_action;	/* don't restore these from block */
	saved_next_action = abs_data.next_action;

	abs_data.if_info = block.if_info;

	abs_data.this_action = saved_this_action;
	abs_data.next_action = saved_next_action;

	if abs_data.current_lex_block_ptr = null then call error (0, "&end not preceded by &do");

	block.statement_end_pos = xd.this_statement.pos;
	if abs_data.next_action = ELSE_ACTION then
	     block.else_clause_pos = xd.next_statement.pos;
	else block.else_clause_pos = 0; 

	abs_data.current_lex_block_ptr = block.containing_lex_block_ptr;

end execute_end;
%page;
execute_if: proc;

	if abs_data.next_action ^= THEN_ACTION & abs_data.next_action ^= ELSE_ACTION then
	     call error (0, "Missing &then or &else following &if");

	if abs_data.if_sw then do;			/* already inside an &if */

	     on area call error (error_table_$noalloc, "Allocating &if statement information.");
	     on bad_area_format call error (error_table_$notalloc, "Allocating &if statement information.");
	     on bad_area_initialization call error (error_table_$notalloc, "Allocating &if statement information.");

	     allocate saved_if_info in (abs_data.work_area) set (saved_if_ptr);

	     saved_if_ptr -> saved_if_info = abs_data.if_info;
	     abs_data.prev_if_ptr = saved_if_ptr;
	end;

	abs_data.if_sw = "1"b;
	abs_data.got_then_sw, abs_data.got_else_sw = "0"b;

	if abs_data.skip_sw then abs_data.true_sw = "1"b;

	else abs_data.true_sw = conditional ();

end execute_if;
%page;
execute_then: proc;

	if ^abs_data.if_sw | abs_data.got_then_sw | abs_data.got_else_sw then
	     call error (0, "&then not preceded by &if");

	abs_data.got_then_sw = "1"b;

/* Unless inside an &if being skipped in its entirety (abs_data.prev_if_ptr -> saved_if_info.skip_sw is ON),
   or inside a &do-&end block being skipped (abs_data.skip_block_level > 0),
   decide whether to skip this &then clause based on the value of the &if conditional. */

	if abs_data.skip_block_level = 0 then
	     if abs_data.prev_if_ptr = null then call set_skip (^abs_data.true_sw);
	     else if ^abs_data.prev_if_ptr -> saved_if_info.skip_sw then call set_skip (^abs_data.true_sw);

end execute_then;
%page;
first_token: proc (P_str, P_pos) returns (char (128) varying);

dcl P_str char (*);
dcl (P_pos, i, j) fixed bin (21);

	if length (P_str) = 0 then return ("");
	i = search (P_str, WHITE_SPACE);
	if i = 0 then do;
	     P_pos = length (P_str) + 1;
	     return (P_str);
	end;
	j = verify (substr (P_str, i + 1), WHITE_SPACE);
	if i = 1 then do;
	     if j = 0 then return ("");
	     P_pos = j + 1;
	     return (next_token (P_str, P_pos));
	end;
	if j = 0 then do;
	     P_pos = length (P_str) + 1;
	     return (substr (P_str, 1));
	end;
	else do;
	     P_pos = i + j;
	     return (substr (P_str, 1, i - 1));
	end;

end first_token;
%page;
functionp: proc returns (bit (1) aligned);

/* TRUE if exec_com was invoked as an active function */

	if ec_data_ptr = null then return ("0"b);	/* unusual case */
	else return (ec_data.active_function);

end functionp;
%page;
get_data_ptrs: proc (P_update_sw);

/* Copies parameters and gets pointers to the various databases. It is called with P_update_sw = "0"b when
   abs_io_v2_get_line is entered, and with P_update_sw = "1"b after calling signal_io_error_ to make sure
   that nothing has changed that we care about. */

dcl P_update_sw bit (1);

	iocb_ptr = A_iocb_ptr -> iocb.actual_iocb_ptr;	/* chase syn's */

	if P_update_sw then do;
	     do while (abs_data_ptr ^= iocb_ptr -> iocb.attach_data_ptr);  /* something's wrong */
		call signal_io_error_ ("Attachment of " || abs_data.io_module_name || " has been moved.",
		     A_iocb_ptr, 0);
		iocb_ptr = A_iocb_ptr -> iocb.actual_iocb_ptr;
	     end;
	     return;
	end;

	buffer_ptr = A_buffer_ptr;
	buffer_len = A_buffer_len;

	abs_data_ptr = iocb_ptr -> iocb.attach_data_ptr;
	ec_data_ptr = abs_data.ec_data_ptr;


end get_data_ptrs;
%page;
get_ready_mode: proc returns (bit (1));

/* TRUE if "on" or "true" is the argument, FALSE if "off" or "false" */

dcl arg char (arg_len) based (arg_ptr);
dcl arg_ptr ptr;
dcl arg_len fixed bin (21);
dcl mode_sw bit (1);

	if parsed_args_ptr = null then
NO_READY_ARGS: call warning (0, "Missing argument to &ready; ""on"" assumed.");
	if parsed_args.count = 0 then go to NO_READY_ARGS;

	arg_ptr = parsed_args.ptr (1);
	arg_len = parsed_args.len (1);
	if arg = "on" | arg = "true" then mode_sw = "1"b;
	else if arg = "off" | arg = "false" then mode_sw = "0"b;
	else do;
	     call warning (0, "Invalid argument ""^a"" to ready statement; ""on"" assumed.", arg);
	     mode_sw = "1"b;
	end;

	if parsed_args.count > 1 then
	     call warning (0, "Ready statement accepts only one argument; extra args ignored.");

	return (mode_sw);

end get_ready_mode;
%page;
init_xd: proc;

/* Initializes much of the auto (in the external proc) xd structure. */

	unspec (xd) = "0"b;
	xd.version = expand_data_version_2;
	xd.abs_data_ptr = abs_data_ptr;
	xd.expand_data_ptr = addr (xd);
	xd.area_ptr = addr (abs_data.work_area);
	xd.parsed_args_ptr = null;
	xd.next_expand_data_ptr, xd.last_expand_data_ptr, xd.allocated_ptr = null;
	xd.first_loop_ptr, xd.first_block_ptr = null;
	xd.is_absin = abs_data.absentee;
	xd.is_af = functionp ();
	xd.is_input = input_linep;

	xd.input_pos = input_string.position;

end init_xd;
%page;
lookup_label: proc (P_labels_ptr, P_name, P_hash) returns (ptr);

/* Sets P_last_node_info from tree of defined labels and returns either ptr to requested label node or null */

dcl P_labels_ptr ptr;
dcl P_name char (*);
dcl P_hash fixed bin;

dcl (found_label_ptr, label_ptr) ptr;
dcl limit_pos fixed bin (21);

	if P_labels_ptr = null then P_labels_ptr = allocate_hash_table ();  /* no tree of labels allocated yet */

	P_hash = mod (binary (unspec (char (P_name, 2)), 18) + length (P_name), 61);

	do label_ptr = P_labels_ptr -> hash_table (P_hash)
	     repeat (label_ptr -> label.next_ptr) while (label_ptr ^= null);

		if label_ptr -> label.name = P_name then do;
		     found_label_ptr = label_ptr;
		     limit_pos = label_ptr -> label.statement_pos + label_ptr -> label.statement_len;
		     go to CHECK_EXPANDABLES;
		end;
	end;

	found_label_ptr = null;			/* no matching constant label in table */
	limit_pos = xd.this_statement.pos;

CHECK_EXPANDABLES:
						/* loop through expandables (e.g., &label &(foo)) */
	if abs_data.first_xlabel_ptr ^= null & unspec (abs_data.first_xlabel_ptr) ^= "0"b then
	     do label_ptr = abs_data.first_xlabel_ptr repeat (label_ptr -> label.next_ptr)
		while (label_ptr ^= null);

		     if label_ptr -> label.statement_pos >= limit_pos then return (found_label_ptr);

		     call abs_io_expand_$expand_label (xd, label_ptr -> label.statement_pos,
			label_ptr -> label.statement_len, label_val_ptr, label_val_len, 0);

		     if label_val = P_name then return (label_ptr);
	     end;

	return (found_label_ptr);

end lookup_label;
%page;
next_token: proc (P_str, P_pos) returns (char (128) varying);

dcl P_str char (*);
dcl (P_pos, i, j, start_pos) fixed (21);

	start_pos = P_pos;
	if start_pos > length (P_str) then return ("");
	i = search (substr (P_str, start_pos), WHITE_SPACE);
	if i = 0 then do;
	     P_pos = length (P_str) + 1;
	     return (substr (P_str, start_pos));
	end;
	j = verify (substr (P_str, start_pos + i), WHITE_SPACE);
	if j = 0 then do;
	     P_pos = length (P_str) + 1;
	     return (substr (P_str, start_pos));
	end;
	else do;
	     P_pos = start_pos + i + j - 1;
	     return (substr (P_str, start_pos, i - 1));
	end;

end next_token;
%page;
recurse_error: proc;

/* Aborts recursive $get_line invocation since there's no previous attachment to use */

dcl complain entry variable options (variable);
dcl who char (72) varying;

	if ec_data_ptr = null then do;
	     complain = com_err_;
	     who = rtrim (abs_data.io_module_name);
	end;
	else do;
	     if codeptr (ec_data.error) = null then
		if ec_data.active_function then complain = active_fnc_err_;
		else complain = com_err_;
	     else complain = ec_data.error;
	     who = ec_data.who_am_i;
	end;

	call complain (0, who, "Attempt to read recursively from the exec_com.");

	go to END_OF_FILE;

end recurse_error;
%page;
reset_input: proc;

/* Performs &detach */

	if attachedp () then do;

	     call abs_io_control$detach (abs_data_ptr, null, code);
	     if code ^= 0 then call error (code, "Error while performing ""&detach"".");
	     if input_linep then do;
						/* return a line from the prior user_input instead */
		call iox_$get_line (iox_$user_input, buffer_ptr, buffer_len, actual_len, A_code);
		input_string.limit = max (input_string.limit, xd.input_pos - 1);
		go to RETURN;
	     end;
	end;

end reset_input;
%page;
set_defaults: proc (P_args_ptr);

/* Sets default values for the first N arguments to exec_com */

dcl P_args_ptr ptr;
dcl i fixed bin;

	if unspec (P_args_ptr) = "0"b then return;
	else if P_args_ptr = null then return;
	else parsed_args_ptr = P_args_ptr;
	abs_data.default_arg_count = parsed_args.count;

	max_default_len = 0;
	do i = 1 to parsed_args.count;		/* compute max string len to allocate values */
	     max_default_len = max (max_default_len, parsed_args.len (i));
	end;

	on area call error (error_table_$noalloc, "Allocating &default args.");
	on bad_area_format call error (error_table_$notalloc, "Allocating &default args.");
	on bad_area_initialization call error (error_table_$notalloc, "Allocating &default args.");

	allocate default_values in (abs_data.work_area) set (default_values_ptr);
	allocate default_args in (abs_data.work_area) set (abs_data.default_arg_ptr);

	revert area;
	revert bad_area_format;
	revert bad_area_initialization;

	do i = 1 to parsed_args.count;		/* copy &default statement args */
	     val_ptr = parsed_args.ptr (i);
	     val_len = parsed_args.len (i);
	     if val_string = "&undefined" | val_string = "&undef" then default_args (i).ptr = null;
	     else do;
		default_values (i) = val_string;
		default_args (i).ptr = addr (default_values (i));
		default_args (i).len = val_len;
		default_args (i).quote_count = parsed_args.quote_count (i);
	     end;
	end;

end set_defaults;
%page;
set_skip: proc (P_sw);

dcl P_sw bit (1) aligned;

	if substr (input_string, xd.input_pos - 1, 1) = NL &  /* &then or &else ends line and */
	     abs_data.next_action ^= IF_ACTION then	/* not nested &if means */
		abs_data.skip_sw =			/* null &then or &else, hence end of &if construct */
		     (abs_data.skip_block_level > 0);

	else abs_data.skip_sw = P_sw;

end set_skip;
%page;
set_trace: proc;

/* Reads arguments to &trace and decides how and what to trace */

dcl 1 tracing,
   2 types,
    3 (command, input, control, comment) bit (1),
   2 (on, off, output_switch, prefix_sw) bit (1),
   2 expand fixed bin,
   2 prefix char (32) varying,
   2 iocb ptr;
dcl arg char (arg_len) based (arg_ptr);
dcl switch_name char (32);
dcl token char (128) varying;
dcl arg_ptr ptr;
dcl arg_len fixed bin (21);
dcl i fixed bin;
dcl pos fixed bin (21);

	unspec (tracing) = "0"b;

	if unspec (xd.parsed_args_ptr) = "0"b then go to NO_TRACE_ARG;
	else if xd.parsed_args_ptr = null then go to NO_TRACE_ARG;
	else parsed_args_ptr = xd.parsed_args_ptr;

	if parsed_args.count = 0 then do;
NO_TRACE_ARG:  call warning (0, "Missing &trace keyword; ""&command on"" assumed.");
	     tracing.command, tracing.on = "1"b;
	end;

	else do i = 1 to parsed_args.count;

	     arg_ptr = parsed_args.ptr (i);
	     arg_len = parsed_args.len (i);

	     do token = first_token (arg, pos) repeat (next_token (arg, pos)) while (token ^= "");

		if token = "&command" then tracing.command = "1"b;
		else if token = "&input" then tracing.input = "1"b;
		else if token = "&control" then tracing.control = "1"b;
		else if token = "&comment" then tracing.comment = "1"b;
		else if token = "&all_types" then
		     tracing.command, tracing.comment, tracing.control, tracing.input = "1"b;

		else if token = "on" | token = "true" then do;
		     tracing.on = "1"b;
		     tracing.off = "0"b;
		end;
		else if token = "off" | token = "false" then do;
		     tracing.off = "1"b;
		     tracing.on = "0"b;
		end;

		else if token = "&unexpanded" then do;
		     tracing.on = "1"b;
		     tracing.expand = UNEXPANDED;
		end;
		else if token = "&expanded" then do;
		     tracing.on = "1"b;
		     tracing.expand = EXPANDED;
		end;
		else if token = "&all" | token = "&all_expansions" then do;
		     tracing.on = "1"b;
		     tracing.expand = ALL;
		end;

		else if token = "&both" then do;
		     tracing.on = "1"b;
		     tracing.expand = BOTH;
		end;

		else if token = "&prefix" then do;
		     tracing.prefix_sw = "1"b;
		     tracing.prefix = get_value ("&prefix");
		end;

		else if token = "&output_switch" | token = "&osw" then do;
		     switch_name = get_value ("&output_switch");
		     call iox_$find_iocb (switch_name, tracing.iocb, code);
		     if code ^= 0 then call error (code, "Finding I/O switch ""^a""", switch_name);
		     tracing.output_switch = "1"b;
		end;

		else call error (0, "Invalid &trace keyword ^a", token);
	     end;
	end;

	if ^tracing.on & ^tracing.off then tracing.on = "1"b;

	if unspec (tracing.types) = "0"b then unspec (tracing.types) = "1111"b;

	if tracing.command then call set_one_trace (abs_data.command_line, "COMMAND");

	if tracing.input then call set_one_trace (abs_data.input_line, "INPUT");

	if tracing.control then call set_one_trace (abs_data.control_line, "CONTROL");

	if tracing.comment then call set_one_trace (abs_data.comment_line, "COMMENT");


get_value: proc (P_arg_name) returns (char (128) varying);

dcl P_arg_name char (*);

	token = next_token (arg, pos);
	do while (token = "");
	     i = i + 1;
	     if i > parsed_args.count then
		call error (0, "No value specified for &trace " || P_arg_name);
	     arg_ptr = parsed_args (i).ptr;
	     arg_len = parsed_args (i).len;
	     token = first_token (arg, pos);
	end;
	return (token);

end get_value;


set_one_trace: proc (P_line, P_type);

dcl 1 P_line aligned like abs_data.command_line;
dcl P_type char (*);

	if P_line.by_control_arg then return;		/* ec control args override &trace */

	if tracing.on then do;
	     P_line.on = "1"b;
	     if P_line.expand = 0 then	/* apply defaults for tracing mode */
		if xd.is_absin then P_line.expand = EXPANDED;  /* expanded for absentee */
		else if P_type = "COMMENT" | P_type = "CONTROL" then P_line.expand = UNEXPANDED;
		else P_line.expand = EXPANDED;	/* expanded for comand and input lines */
	end;
	if tracing.off then P_line.on = "0"b;
	if tracing.expand ^= 0 then P_line.expand = tracing.expand;
	if tracing.prefix_sw then P_line.prefix = tracing.prefix;
	if tracing.output_switch then P_line.iocb = tracing.iocb;

end set_one_trace;

end set_trace;
%page;
test_end_of_if: proc;

dcl (saved_this_action, saved_next_action) fixed bin;

	saved_this_action = abs_data.this_action;
	saved_next_action = abs_data.next_action;
TEST:
	if (abs_data.clause_type = ELSE_TYPE &
	     (saved_this_action ^= ELSE_ACTION | saved_next_action = ELSE_ACTION))
						/* statement following an &else */
	  | (abs_data.clause_type = THEN_TYPE & saved_this_action ^= THEN_ACTION &
	     saved_next_action ^= ELSE_ACTION) then do;
						/* or stmt following &then, not followed by &else */
		if saved_this_action = IF_ACTION | saved_this_action = DO_ACTION then return;
						/* More nesting: &then &if, &then &do, same for &else */
/* End of the &if-&then-&else compound statement */

		if abs_data.prev_if_ptr ^= null then do;  /* nested inside another &if */
		     abs_data.if_info = abs_data.prev_if_ptr -> saved_if_info;
		     go to TEST;			/* see if the outer &if is ended too, and so on */
		end;

		else do;
		     abs_data.if_sw = "0"b;		/* back to normal text */
		     abs_data.clause_type = 0;	/* we have seen the stmt after the &then or &else */

		     if abs_data.skip_block_level = 0 then abs_data.skip_sw = "0"b;
						/* stop skipping unless inside a &do being skipped */
		end;
	     end;

end test_end_of_if;

%page;
%include abs_io_block;
%page;
%include abs_io_data;
%page;
%include abs_io_expand;
%page;
%include abs_io_handler_node;
%page;
%include abs_io_hash;
%page;
%include ec_data;
%page;
%include iocbx;

end abs_io_v2_get_line;




		    absentee_listen_.pl1            10/04/88  1315.2rew 10/04/88  1312.5      360324



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



/****^  HISTORY COMMENTS:
  1) change(86-03-13,Herbst), approve(86-04-17,MCR7376),
     audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041):
     Fixed bug where &goto from &on unit was not resetting auto_in_handler_sw.
  2) change(87-02-20,Parisek), approve(87-07-23,MCR7716),
     audit(87-08-07,Fawcett), install(87-08-11,MR12.1-1080):
     If caller of exec_com_ is call_ec_ then turn on the exec_com_info.noabort
     flag for subsequent notification to subroutines to not abort after an
     ec severity 1 error.
  3) change(88-08-08,TLNguyen), approve(88-08-08,MCR7934),
     audit(88-08-26,Parisek), install(88-09-16,MR12.2-1111):
     Make the &exit statement and the &goto LABEL statement constructed within
     the &on unit work as documented.
  4) change(88-09-29,TLNguyen), approve(88-09-29,PBF7934),
     audit(88-09-29,Parisek), install(88-10-04,MR12.2-1128):
     Add the local turned_on_in_handler_sw flag in the invoke_handler
     internal procedure.  This flag is used to control how
     abs_data.in_handler_sw gets set/reset based on its current state
     (ie, ON if OFF; OFF if ON).  Remove setting/resetting of
     abs_data.in_handler_sw within the any_other handler.
                                                   END HISTORY COMMENTS */


/* format: off */

absentee_listen_:
     procedure (P_initial_command_line);

/* Initial coding: 25 June 1979 by J. Spencer Love */
/* Modified: 8 June 1980 by J. Spencer Love for exec_com_ and absentee_listen_ */
/* Added get_ec_version_ 07/28/81 S. Herbst */
/* Modified for new abs_io_, April 1982, E. N. Kittlitz */
/* Fixed get_ec_version_ to use uniquely-named IO switch 05/24/82 S. Herbst */
/* Changed wording of "not found using search list" message 07/26/82 S. Herbst */
/* Added $execute_handler and code to execute an &on unit 01/06/83 S. Herbst */
/* Fixed to turn off ec_data.input_line while executing handler 06/03/83 S. Herbst */
/* Fixed so that all entry points initialize "initialized" and "state" 10/05/83 S. Herbst */
/* Fixed to do a PL/1 nonlocal goto to parent ec's stack frame for &goto inside an &on unit 11/17/83 S. Herbst */
/* Fixed get_ec_version_ to return the right character position 11/30/83 S. Herbst */
/* Changed to support exec_com command control args -trace, -no_trace, -trace_default 03/22/84 S. Herbst */
/* Fixed $exec_com to initialize exec_com_info_ptr to null 08/10/84 S. Herbst */
/* Fixed $absentee_listen_ to set ec_info.switch_ptr = iox_$user_io instead of null 09/17/84 Steve Herbst */
/* Fixed &on any_other, ec_data.input_line="0"b executing cleanup handler 10/25/84 Steve Herbst */
/* Changed $absentee_listen_ to call listen_, which knows about release/start, etc. 12/03/84 Steve Herbst */
/* Changed all entry points to deal with release/start as listen_ does 12/07/84 Steve Herbst */
/* Commented out support for release/start except via $absentee_listen_ 12/12/84 Steve Herbst */
/* Fixed any_other handler to use auto recursion flag in case user_i/o detached 01/04/85 Steve Herbst */
/* Fixed bug where revert_output or discard_output turns off abs_data.in_handler_sw 01/14/85 Steve Herbst */


declare	P_abs_data_ptr		ptr parameter,
	P_caller			char (*) parameter,
	P_code			fixed bin (35) parameter,
	P_condition_info_ptr	ptr parameter,
	P_continue_to_signal_sw	bit (1) aligned parameter,
	P_dn			char (*) parameter,
	P_ec_info_ptr		ptr parameter,
	P_en			char (*) parameter,
	P_exec_com_info_ptr		ptr parameter,
	P_goto_label_len		fixed bin (21) parameter,
	P_goto_label_ptr		ptr parameter,
	P_handler_node_ptr		ptr parameter,
	P_initial_command_line	char (*) varying parameter,
	P_initial_string		char (*) parameter,
	P_pathname		char (*) parameter,
	P_search_list		char (*) parameter,
	P_search_name		char (*) parameter,
	P_subsystem_dir_ptr		ptr parameter,
	P_suffix			char (*) parameter,
	P_text_pos		fixed bin (21) parameter,
	P_version			fixed bin parameter;

declare	(addr, addrel, baseno, charno, clock, codeptr, copy, index, length, null, rtrim, stackframeptr, string, substr, unspec)
				builtin;

declare	(any_other, cleanup, stringsize)
				condition;

declare	auto_in_handler_sw		bit (1) aligned,	  /* to prevent looping of any_other handler */
	auto_cond_name		char (32);

declare	arg_count			fixed bin,
	arg_len			fixed bin (21),
	arg_ptr			ptr,
	arg			char (arg_len) based (arg_ptr),
	arg_list_ptr		ptr,
	actual_len		fixed bin (21),
	buffer			char (512),
	command_sw		bit (1) aligned,
	cond_name			char (32),
	continue_to_signal_sw	bit (1) aligned,
	entry_point_name		char (32),
	goto_label		char (goto_label_len) based (goto_label_ptr),
	goto_label_len		fixed bin (21),
	goto_label_ptr		ptr,
	handler_found_sw		bit (1) aligned,
	i			fixed bin,
	initialized		bit (1) aligned,
	p			ptr,
	path			char (168),
	path_arg_pos		fixed bin,
	read_len			fixed bin (21),
	read_ptr			ptr,
	ready_procedure		entry (1 aligned like ready_mode) variable,
	saved_abs_data_ptr		ptr,
	saved_in_handler_sw		bit (1),
	seg_ptr			ptr,
	spno			bit (18) aligned,
	state			fixed bin,
	status			fixed bin (35),
	X_status			fixed bin (35),
	whoami			char (32),
	work_len			fixed bin (21),
	work_ptr			ptr,
	work_string		char (work_len) based (work_ptr);

declare	1 listener_control		aligned like based_listener_control;

declare	1 ec_info			aligned like ec_data;

declare	1 trace_info		aligned like ec_trace_info;

declare   1 local_condition_info	aligned like condition_info;

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

declare   (TRACE_OFF init ("1"b),
	 TRACE_ON init ("0"b))	bit (1) int static options (constant);

declare	(
	IN_OUTER_PROC		init (0),
	IN_INITIALIZE_EC_INFO	init (1),
	IN_FIND_EC		init (-1)
	)			fixed bin int static options (constant);
declare	stream_input		fixed bin static options (constant) initial (1);

declare	(
	error_table_$badopt,
	error_table_$end_of_info,
	error_table_$long_record,
	error_table_$not_act_fnc,
	error_table_$pathlong
	)			fixed bin (35) external,
	iox_$user_io		ptr external,
	sys_info$max_seg_size	fixed bin (35) external;

dcl abs_io_$allocate_abs_data entry (ptr);
dcl abs_io_$initialize_abs_data entry (ptr);
dcl abs_io_v2_get_line$goto entry (ptr, ptr, char (*)) returns (fixed bin (35));
dcl absentee_listen_$execute_handler entry
	(ptr, ptr, ptr, ptr, ptr, ptr, fixed bin (21), bit (1) aligned, fixed bin (35));

declare	active_fnc_err_		entry options (variable),
	active_fnc_err_$af_suppress_name
				entry options (variable),
	com_err_			entry options (variable),
	com_err_$suppress_name	entry options (variable),
	continue_to_signal_		entry (fixed bin (35)),
	cu_$af_return_arg_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	cu_$arg_list_ptr		entry () returns (ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
	cu_$generate_call		entry (entry, ptr),
	cu_$cp			entry (ptr, fixed bin (21), fixed bin (35)),
	cu_$ready_proc		entry () options (variable),
	expand_pathname_$add_suffix	entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	find_condition_info_	entry (ptr, ptr, fixed bin (35)),
	get_temp_segment_		entry (char (*), ptr, fixed bin (35)),
	iox_$attach_name		entry (char (*), ptr, char (*), ptr, fixed bin (35)),
	iox_$control		entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$detach_iocb		entry (ptr, fixed bin (35)),
	iox_$destroy_iocb		entry (ptr, fixed bin (35)),
	iox_$find_iocb		entry (char (*), ptr, fixed bin (35)),
	iox_$get_line		entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	iox_$open			entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
	release_temp_segment_	entry (char (*), ptr, fixed bin (35)),
	request_id_		entry (fixed bin (71)) returns (char (19)),
	requote_string_		entry (char (*)) returns (char (*)),
	signal_io_error_		entry (char (*), ptr, fixed bin (35)),
	unique_chars_		entry (bit (*)) returns (char (15));
%page;
/* Called by initialize_process_, this entry point is the listener for an absentee process. */

/* absentee_listen_:
   procedure (P_initial_command_line);								*/

	entry_point_name = "absentee_listen_";

	exec_com_info_ptr = null;
	state = IN_OUTER_PROC;			/* Tell cleanup handler we have nothing for it to do	*/
	initialized = "0"b;

	on cleanup call clean_up ();

	call initialize_ec_info ();

	ec_info.who_am_i, whoami = "Absentee facility";

	ec_info.switch_ptr = iox_$user_io;

	abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr;
	initialized = "1"b;

	call iox_$control (iox_$user_io, "set_ec_data_ptr", addr (ec_info), status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting ec data.");

	unspec (listener_control) = "0"b;
	listener_control.prev_ptr = null;
	listener_control.level = 1;
	sp = stackframeptr ();			/* count the stack frame number */
	spno = baseno (sp);
	i = 0;
	do while (baseno (sp -> stack_frame.prev_sp) = spno & sp ^= null);
	     i = i + 1;
	     sp = sp -> stack_frame.prev_sp;
	end;
	listener_control.frame = i;
	listener_control.release_all, listener_control.release, listener_control.new_release = RELEASE_LABEL;
	listener_control.start = START_LABEL;
	listen_static_data_.control_ptr = addr (listener_control);

	abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE;

	call cu_$cp (addrel (addr (P_initial_command_line), 1), length (P_initial_command_line), status);

	if status ^= 0 & status ^= 100 then call complain (status, ec_info.who_am_i, "Executing initial command line.");

	go to COMMON;
%page;
exec_com_:
     entry (P_pathname, P_initial_string, P_caller, P_exec_com_info_ptr, P_code);

	entry_point_name = "exec_com_";

	exec_com_info_ptr = P_exec_com_info_ptr;
	state = IN_OUTER_PROC;
	initialized = "0"b;

	on cleanup call clean_up;

	call initialize_ec_info ();

	if unspec (exec_com_info.error) ^= ""b & codeptr (exec_com_info.error) ^= null ()
	then ec_info.error = exec_com_info.error;
	if unspec (exec_com_info.eval_string) ^= ""b & codeptr (exec_com_info.eval_string) ^= null ()
	then ec_info.eval_string = exec_com_info.eval_string;
	if unspec (exec_com_info.execute_line) ^= ""b & codeptr (exec_com_info.execute_line) ^= null ()
	then ec_info.execute_line = exec_com_info.execute_line;
	if unspec (exec_com_info.ready) ^= ""b & codeptr (exec_com_info.ready) ^= null ()
	then ready_procedure = exec_com_info.ready;
	if unspec (exec_com_info.set_ready_mode) ^= ""b & codeptr (exec_com_info.set_ready_mode) ^= null ()
	then ec_info.set_ready_mode = exec_com_info.set_ready_mode;

	ec_info.call_ready_proc = "0"b;
	ec_info.who_am_i = P_caller;
	whoami = "exec_com_";

	call attach_ec ("ec_input_", P_pathname);

	initialized = "1"b;

	arg_list_ptr = exec_com_info.arg_list_ptr;

	call check_arg_list (exec_com_info.arg_list_ptr);

	call set_args (exec_com_info.first_arg);

	if ec_info.who_am_i = "call_ec_" then 
	     abs_data.switches.noabort = "1"b;
	else abs_data.switches.noabort = ""b;
	if codeptr (exec_com_info.execute_line) ^= null () & unspec (exec_com_info.execute_line) ^= ""b
	then call exec_com_info.execute_line (addr (P_initial_string), length (P_initial_string), status);
	else call cu_$cp (addr (P_initial_string), length (P_initial_string), status);

	if status ^= 0 & status ^= 100 then call complain (status, ec_info.who_am_i, "Executing initial command line.");

	abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE;

	go to COMMON;
%page;
exec_com:
ec:
     entry () options (variable);

	entry_point_name = "exec_com";

	exec_com_info_ptr = null;
	state = IN_OUTER_PROC;
	initialized = "0"b;

	on cleanup call clean_up ();

	call initialize_ec_info ();
	command_sw = "1"b;

	ec_info.set_ready_mode = set_ready_mode;
	ec_info.who_am_i, whoami = "exec_com";

	arg_list_ptr = cu_$arg_list_ptr ();

	call check_arg_list (arg_list_ptr);

	if arg_count < 1
	then do;
COMMAND_USAGE:
		if ec_info.active_function
		then call active_fnc_err_$af_suppress_name (0, whoami, "Usage:  [ec {-control_args} path {ec_args}]");
		else call com_err_$suppress_name (0, whoami, "Usage:  ec {-control_args} path {ec_args}");
		go to EGRESS;
	     end;

	path_arg_pos = 0;
	do i = 1 to arg_count while (path_arg_pos = 0);
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") = 1 then do;
		if arg = "-no_trace" | arg = "-trace" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call com_err_ (0, ec_info.who_am_i, "No value specified for ^a", arg);
			go to EGRESS;
		     end;
		end;
		else if arg = "-trace_default" then;
		else do;
		     call com_err_ (error_table_$badopt, ec_info.who_am_i, "^a", arg);
		     go to EGRESS;
		end;
	     end;
	     else path_arg_pos = i;
	end;

	if path_arg_pos = 0 then go to COMMAND_USAGE;

	call cu_$arg_ptr_rel (path_arg_pos, arg_ptr, arg_len, (0), arg_list_ptr);

	call attach_ec ("ec_input_", find_ec ("ec", "exec_com", null ()));

	initialized = "1"b;

	unspec (trace_info) = "0"b;

	do i = 1 to path_arg_pos - 1;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
	     if index (arg, "-") = 1 then do;
		if arg = "-no_trace" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
		     call set_trace (TRACE_OFF, arg);
		end;
		else if arg = "-trace" then do;
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, (0));
		     call set_trace (TRACE_ON, arg);
		end;
		else if arg = "-trace_default" then unspec (trace_info) = "0"b;
	     end;
	end;

	call iox_$control (ec_info.switch_ptr, "set_trace", addr (trace_info), status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting -trace information.");

	call set_args (path_arg_pos + 1);

	if ec_info.active_function then ec_info.call_ready_proc = "0"b;
	status = 100;				/* Suppress initial call to ready proc			*/

	abs_data.listener_pl1_label, abs_data.get_line_pl1_label = CONTINUE;

	go to COMMON;
%page;
execute_handler: entry (P_exec_com_info_ptr, P_ec_info_ptr, P_abs_data_ptr, P_handler_node_ptr,
		     P_condition_info_ptr, P_goto_label_ptr, P_goto_label_len, P_continue_to_signal_sw, P_code);

/* This entry point executes the text of an &on unit as if it were a separate exec_com, remembering whether it
   has exited by means of a nonlocal &goto */

	entry_point_name = "execute_handler";

	P_goto_label_ptr = null;

	state = IN_OUTER_PROC;
	initialized = "0"b;

	exec_com_info_ptr = P_exec_com_info_ptr;
	ec_info = P_ec_info_ptr -> ec_data;
	handler_node_ptr = P_handler_node_ptr;

/* Set up a new abs_data for executing the handler */

	abs_data_ptr = null;

	on cleanup call clean_up;

	call abs_io_$allocate_abs_data (abs_data_ptr);

	abs_data = P_abs_data_ptr -> abs_data;		/* will use some old information */

	abs_data.active = "0"b;

	call abs_io_$initialize_abs_data (abs_data_ptr);	/* and some new information */

	initialized = "1"b;

/* Set defaults for an &on handler */

	abs_data.io_module_name = "abs_io_";

	abs_data.input_string.ptr = handler_node.ptr;
	abs_data.input_string.len = handler_node.len;
	abs_data.input_string.start, abs_data.input_string.position = 1;
	abs_data.input_string.limit = 0;

	abs_data.active, abs_data.label_search_sw = "0"b;
	abs_data.command_line.on, abs_data.comment_line.on, abs_data.control_line.on, abs_data.input_line.on = "0"b;
	unspec (abs_data.if_info) = "0"b;
	abs_data.prev_if_ptr = null;
	unspec (abs_data.on_info) = "0"b;
	abs_data.cleanup_handler_ptr, abs_data.first_handler_ptr, abs_data.goto_label_ptr = null;

	abs_data.on_info.in_handler_sw = "1"b;
	abs_data.on_info.handler_node_ptr = P_handler_node_ptr;
	abs_data.on_info.condition_name = P_condition_info_ptr -> condition_info.condition_name;
	abs_data.on_info.mc_ptr = P_condition_info_ptr -> condition_info.mc_ptr;
	abs_data.on_info.info_ptr = P_condition_info_ptr -> condition_info.info_ptr;
	abs_data.on_info.wc_ptr = P_condition_info_ptr -> condition_info.wc_ptr;
	abs_data.on_info.was_attached_sw = (P_abs_data_ptr -> abs_data.attach.victim_ptr ^= null);

	abs_data.work_area = P_abs_data_ptr -> abs_data.work_area;  /* use the same area; copy it back when done */

	saved_abs_data_ptr, abs_data.on_info.parent_abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr;
	ec_info.switch_ptr -> iocb.attach_data_ptr = abs_data_ptr;

	ec_info.call_ready_proc = "0"b;

	go to COMMON;
%page;
COMMON:

/* Handle all conditions. This is for the benefit of &on and, in the case of
   cleanup, for popping a listener level. */

	auto_in_handler_sw = "0"b;
	auto_cond_name = "";

	on any_other begin;

	     call find_condition_info_ (null, addr (local_condition_info), 0);
	     cond_name = local_condition_info.condition_name;

	     if cond_name = "cleanup" then do;	/* pop listener level */
		listen_static_data_.control_ptr =
		listen_static_data_.control_ptr -> based_listener_control.prev_ptr;
		if listen_static_data_.control_ptr = null then listen_static_data_.first_level_sw = "1"b;
	     end;

	     if ^auto_in_handler_sw | cond_name ^= auto_cond_name then do;  /* prevent looping */

		auto_in_handler_sw = "1"b;
		auto_cond_name = cond_name;

		continue_to_signal_sw = "1"b;		/* default if no handlers invoked */

		handler_found_sw = "0"b;

		p = abs_data.on_info.first_handler_ptr;
		do while (p ^= null);                   /* walk down to chain of handler nodes to find a matching condition name */

		     if p -> handler_node.condition_name = cond_name then do;
			handler_found_sw = "1"b;

			call invoke_handler (p);      /* execute the text of a specified condition handler (&on unit) */
		     end;
		     else p = p -> handler_node.next_ptr;
		end;

		if ^handler_found_sw then do;		/* look for an any_other handler */
		     p = abs_data.on_info.first_handler_ptr;
		     do while (p ^= null);
			if p -> handler_node.condition_name = "any_other" then do;
			     call invoke_handler (p);
			end;
			else p = p -> handler_node.next_ptr;
		     end;
		end;

		if continue_to_signal_sw then call continue_to_signal_ ((0));  /* very important! */

		auto_in_handler_sw = "0"b;
	     end;
	end;
%page;
LISTENER_LOOP:

/* The following routine reads lines from the input file and passes them on to the command processor. It communicates
   with abs_io_ through the attach_data block (it gets a pointer to this via a control order) in order to determine
   when command vs. input lines are being read and what the ready mode is.					*/

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

	     ec_info.input_line = "0"b;

	     read_ptr, work_ptr = addr (buffer);
	     read_len = length (buffer);
	     work_len = 0;
	     do while (status ^= 0 | work_len = 0);
		call iox_$get_line (ec_info.switch_ptr, read_ptr, read_len, actual_len, status);
		work_len = work_len + actual_len;
		if status ^= 0
		then if status = error_table_$end_of_info
		     then if work_len = 0
			then go to EGRESS;		/* all done */
			else status = 0;		/* abs_io_ wont do this, but if there is a partial line...	*/
		     else if status = error_table_$long_record & seg_ptr = null ()
		     then do;			/* too big; get a temp segment and put it there instead	*/
			     call get_temp_segment_ (whoami, seg_ptr, X_status);
			     if X_status ^= 0
			     then call complain (X_status, ec_info.who_am_i, "Getting temp segment.");
			     work_ptr = seg_ptr;
			     work_string = substr (buffer, 1, work_len);
			     read_ptr = addr (substr (work_string, work_len + 1));
			     read_len = (sys_info$max_seg_size * 4) - work_len;
			end;
		     else call signal_io_error_ ("Error while reading command line.", ec_info.switch_ptr, status);
	     end;

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

	     saved_in_handler_sw = abs_data.in_handler_sw;  /* I don't know why, but a revert_output or
						     discard_output zeroes this flag! */
	     if codeptr (ec_info.execute_line) ^= null ()
	     then call ec_info.execute_line (work_ptr, work_len, status);
	     else call cu_$cp (work_ptr, work_len, status);

	     abs_data.in_handler_sw = saved_in_handler_sw;

CONTINUE:
	     if seg_ptr ^= null () then call release_temp_segment_ (whoami, seg_ptr, status);
	end;

	go to EGRESS;
%page;
RELEASE_LABEL:					/* transferred to by the release command */

	abs_data.active = "0"b;

	go to LISTENER_LOOP;




START_LABEL:					/* transferred to by the start command */

	listen_static_data_.control_ptr = listen_static_data_.control_ptr -> based_listener_control.prev_ptr;

	return;
%page;
get_ec_version_:
     entry (P_dn, P_en, P_version, P_text_pos, P_code);

/* Returns version number of ec and position of first character following the "&version N" stmt if any.
   Called by program that adds copyright notices to exec_com's. */

	state = IN_OUTER_PROC;
	initialized = "0"b;

	call initialize_ec_info ();

	on cleanup
	     begin;
		if ec_info.switch_ptr ^= null ()
		then do;
			call iox_$detach_iocb (ec_info.switch_ptr, (0));
			call iox_$destroy_iocb (ec_info.switch_ptr, (0));
		     end;
	     end;

	if P_dn = ">"
	then path = ">" || P_en;
	else path = rtrim (P_dn) || ">" || P_en;

	call iox_$attach_name (unique_chars_ ("0"b), ec_info.switch_ptr, "ec_input_ " || requote_string_ (rtrim (path)),
	     codeptr (exec_com), status);
	if status ^= 0
	then do;
		P_code = status;
		if ec_info.switch_ptr ^= null () then call iox_$destroy_iocb (ec_info.switch_ptr, (0));
		return;
	     end;

	abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr;

	initialized = "1"b;

	P_version = abs_data.open_data.parser_version;
	P_text_pos = abs_data.input_string.start;
	if P_version = 1 then	  /* version 1 positions to newline after the "&version 1" */
	     P_text_pos = P_text_pos + 1;		/* user wants position of char after newline */
	P_code = 0;

	call iox_$detach_iocb (ec_info.switch_ptr, status);
	if status = 0 then call iox_$destroy_iocb (ec_info.switch_ptr, status);

	return;
%page;
invoke_handler: proc (P_node_ptr);

dcl P_node_ptr ptr;
dcl (goto_sw, saved_input_line_sw, turned_on_in_handler_sw) bit (1) aligned;

	saved_input_line_sw = ec_info.input_line;
	ec_info.input_line = "0"b;

	turned_on_in_handler_sw = "0"b;
	if ^abs_data.in_handler_sw then		/* turn on, if not already on */
	     abs_data.in_handler_sw, turned_on_in_handler_sw = "1"b;
	call absentee_listen_$execute_handler (exec_com_info_ptr, addr (ec_info), abs_data_ptr,
	     P_node_ptr, addr (local_condition_info), goto_label_ptr, goto_label_len,
	     continue_to_signal_sw, 0);

	if goto_label_ptr ^= null then do;
	     goto_sw = "1"b;
	     status = abs_io_v2_get_line$goto (abs_data_ptr, addr (ec_info), goto_label);
	     if status ^= 0 then go to EGRESS;
	end;
	else goto_sw = "0"b;

	ec_info.input_line = saved_input_line_sw;

	if turned_on_in_handler_sw then		/* only turn off, if we turned it on */
	     abs_data.in_handler_sw = "0"b;

	if goto_sw then do;
	     abs_data.active, auto_in_handler_sw = "0"b;

/* Implementing nonlocal &goto from inside an &on unit (handler). This is
   done by a PL/1 nonlocal goto so that interrupted actions are not continued.
   If the handler was invoked while in abs_io_v2_get_line, the target of the
   goto is that procedure's START: label, to process the &label statement.
   If the handler was invoked while inside cu_$cp (ec_info.input_line = "1"b),
   the target of the goto is absentee_listen_'s CONTINUE: label, to put us
   back in the listener loop. */

	     if ec_info.input_line then go to abs_data.listener_pl1_label;
	     else go to abs_data.get_line_pl1_label;
	end;

	P_node_ptr = null;				/* handler invoked; stop the caller's loop */

	return;

end invoke_handler;
%page;
invoke_ready_procedure:
     procedure ();

	if codeptr (ready_procedure) ^= null () then call ready_procedure (ready_mode);
						/* This case is for exec_com_, if given a value		*/

	else if command_sw then call cu_$ready_proc (ready_mode);
						/* This case is for the exec_com command		*/

	else call cu_$ready_proc ();			/* This case is for absentee, or exec_com_ default	*/

	return;

     end invoke_ready_procedure;



set_ready_mode:
     procedure (P_ready_mode);

declare	1 P_ready_mode		aligned like ready_mode;

	ready_mode = P_ready_mode;

	return;

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

declare	arg_list_ptr		ptr,
	based_status_ptr		ptr,
	based_status		fixed bin (35) based (based_status_ptr);

	arg_list_ptr = cu_$arg_list_ptr ();

	if state = IN_FIND_EC
	then do;					/* In exec_com_$find_ec.  Set return values and punt	*/
		P_pathname = "";
		call cu_$arg_ptr (1, based_status_ptr, (0), (0));
		P_code = based_status;
	     end;

	else if codeptr (ec_info.error) ^= null () then call cu_$generate_call (ec_info.error, arg_list_ptr);

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

	go to EGRESS;

     end complain;

EGRESS:
	call finish_up ();

	return;
%page;
clean_up:
     procedure ();

dcl saved_input_line_sw bit (1) aligned;

	saved_input_line_sw = ec_info.input_line;
	ec_info.input_line = "0"b;

	if initialized then
	  if abs_data.on_info.cleanup_handler_ptr ^= null then  /* there is an "&on cleanup" */
	    if abs_data.on_info.cleanup_handler_ptr -> handler_node.condition_name = "cleanup" then do;
						/* and it's not disabled by &resignal */

	     local_condition_info.condition_name = "cleanup";
	     local_condition_info.mc_ptr, local_condition_info.info_ptr, local_condition_info.wc_ptr = null;

	     call absentee_listen_$execute_handler (exec_com_info_ptr, addr (ec_info), abs_data_ptr,
		abs_data.on_info.cleanup_handler_ptr, addr (local_condition_info), null, 0, "0"b, 0);
						/* don't honor any nonlocal &goto inside it */

	end;

	ec_info.input_line = saved_input_line_sw;

	call finish_up ();

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

dcl goto_label char (abs_data.goto_label_len) based (abs_data.goto_label_ptr);
declare	status		fixed bin (35);
declare	iox_$close	entry (ptr, fixed bin (35));

	if state = IN_INITIALIZE_EC_INFO
	then do;					/* clean up after initialize_ec_info */

		if ec_info.switch_ptr ^= null & abs_data_ptr ^= null then
		     if ^abs_data.in_handler_sw then do;
			call iox_$control (ec_info.switch_ptr, "handle_cleanup", addr (ec_info), status);
			call iox_$close (ec_info.switch_ptr, status);
			call iox_$detach_iocb (ec_info.switch_ptr, status);
			call iox_$destroy_iocb (ec_info.switch_ptr, status);
		     end;

		if seg_ptr ^= null () then call release_temp_segment_ (whoami, seg_ptr, status);
	     end;

	if initialized then
	  if abs_data_ptr ^= null then
	     if entry_point_name = "execute_handler" then do;

		P_continue_to_signal_sw = abs_data.on_info.continue_to_signal_sw;

		if abs_data.goto_sw then do;		/* leaving &on unit via &goto */
						/* label must be allocated in parent's area */
		     allocate goto_label in (saved_abs_data_ptr -> abs_data.work_area)
			set (P_goto_label_ptr);	/* set args of absentee_listen_$execute_handler */
		     P_goto_label_ptr -> goto_label = abs_data.goto_label_ptr -> goto_label;
		     P_goto_label_len = abs_data.goto_label_len;

		     saved_abs_data_ptr -> abs_data.goto_statement_pos = abs_data.goto_statement_pos
			+ charno (abs_data.input_string.ptr)
			- charno (saved_abs_data_ptr -> abs_data.input_string.ptr);
		     saved_abs_data_ptr -> abs_data.goto_statement_len = abs_data.goto_statement_len;
		end;

		saved_abs_data_ptr -> abs_data.output_file = abs_data.output_file;
		saved_abs_data_ptr -> abs_data.variables_ptr = abs_data.variables_ptr;

		free abs_data;			/* free the &on unit's private abs_data */
						/* and restore the parent's: */

		abs_data_ptr, ec_info.switch_ptr -> attach_data_ptr = saved_abs_data_ptr;
	     end;

	return;

end finish_up;
%page;
initialize_ec_info:
     procedure ();

declare	null_entry_value		entry variable;

	unspec (null_entry_value) = copy (unspec (null ()), 2);
	ready_procedure = null_entry_value;
	string (ready_mode) = ""b;
	command_sw = "0"b;

	seg_ptr = null ();

	ec_info.version_id = ec_data_version_id;
	ec_info.version = ec_data_version_1;
	ec_info.active_function = "0"b;
	ec_info.return_len = 0;
	ec_info.return_ptr = null ();
	ec_info.execute_line = null_entry_value;
	ec_info.eval_string = null_entry_value;
	ec_info.set_ready_mode = null_entry_value;
	ec_info.error = null_entry_value;
	ec_info.switch_ptr = null ();
	ec_info.id_string = request_id_ (clock ());
	ec_info.input_line = "1"b;
	ec_info.call_ready_proc = "1"b;

	abs_data_ptr = null;

	state = IN_INITIALIZE_EC_INFO;

	return;

     end initialize_ec_info;
%page;
attach_ec:
     procedure (P_switch_name, P_path);

dcl (P_switch_name, P_path) char (*);
declare	code			fixed bin (35);
declare	sub_error_		condition;

	condition_info_ptr = addr (local_condition_info);

	on sub_error_
	     begin;
		call find_condition_info_ (null (), condition_info_ptr, code);
		if code = 0
		then do;
			sub_error_info_ptr = condition_info.info_ptr;
			call complain (sub_error_info.status_code, ec_info.who_am_i, "^a",
			     sub_error_info.info_string);
		     end;
		else call continue_to_signal_ ((0));
	     end;

	call iox_$attach_name (ec_info.id_string || "." || rtrim (whoami), ec_info.switch_ptr,
	     rtrim (P_switch_name) || " " || requote_string_ (rtrim (P_path)),
	     codeptr (exec_com) /* Pick up bound-in version by default */, status);

	if status ^= 0 then call complain (status, ec_info.who_am_i, "Attaching ^a.", P_path);

	call iox_$open (ec_info.switch_ptr, stream_input, "0"b, status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Opening ^a.", P_path);

	revert sub_error_;

	call iox_$control (ec_info.switch_ptr, "set_ec_data_ptr", addr (ec_info), status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting ec data.");

	abs_data_ptr = ec_info.switch_ptr -> iocb.attach_data_ptr;

	return;

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

declare	P_arg_list_ptr		ptr;

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

	return;

     end check_arg_list;



set_args:
     procedure (first_arg);

declare	(first_arg, args_index, i)	fixed bin;

declare	1 args			aligned,		/* adjustable automatic storage			*/
	  2 count			fixed bin,
	  2 e			(arg_count - first_arg + 1),
	    3 ptr			ptr unaligned,
	    3 len			fixed bin (21);

	args.count = arg_count - first_arg + 1;
	args_index = 0;

	do i = first_arg to arg_count;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_len, status, arg_list_ptr);
	     args_index = args_index + 1;
	     args (args_index).ptr = arg_ptr;
	     args (args_index).len = arg_len;
	end;

	call iox_$control (ec_info.switch_ptr, "set_argument_ptrs", addr (args), status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "Setting arguments.");

	return;

     end set_args;
%page;
exec_com_$find_ec:
     entry (P_search_name, P_suffix, P_search_list, P_subsystem_dir_ptr, P_pathname, P_code);

	state = IN_FIND_EC;				/* Tell complain that we are find_ec			*/
	initialized = "0"b;

	arg_ptr = addr (P_search_name);		/* find_ec uses based variable "arg" as input		*/
	arg_len = length (rtrim (P_search_name));

	on stringsize go to PATHNAME_TOO_LONG;		/* Complain if "returns (char (*))" result too big	*/

(stringsize):
	P_pathname = find_ec (P_suffix, P_search_list, P_subsystem_dir_ptr);
	P_code = 0;				/* find_ec aborted through complain if it failed */

	return;

PATHNAME_TOO_LONG:
	P_pathname = "";
	P_code = error_table_$pathlong;

	return;
%page;
find_ec:
     procedure (suffix, search_list, subsystem_dir_ptr) returns (char (*));

declare	suffix			char (*) parameter,
	search_list		char (*) parameter,
	subsystem_dir_ptr		ptr parameter;

declare	(length, null, reverse, rtrim, search)
				builtin;

declare	dirname			char (168),
	entryname			char (32),
	entryname_len		fixed bin (21),
	must_search		bit (1) aligned,
	path_len			fixed bin (21),
	path			char (path_len) based (arg_ptr),
	pathname			char (169 + arg_len) varying,
	search_dirname		char (168),
	subsystem_dir		char (168);

declare	(
	error_table_$badpath,
	error_table_$no_search_list
	)			fixed bin (35) external;

declare	hcs_$fs_get_path_name	entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
	search_paths_$find_dir	entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35));


	must_search = "0"b;
	path_len = arg_len;

	entryname_len = search (reverse (arg), "<>") - 1;
	if entryname_len < 0
	then do;
		entryname_len = arg_len;
		if search_list ^= "" then must_search = "1"b;
	     end;
	else if entryname_len = 0
	then call complain (error_table_$badpath, ec_info.who_am_i, "No file name given.  ^a", arg);

	call expand_pathname_$add_suffix (path, suffix, dirname, entryname, status);
	if status ^= 0 then call complain (status, ec_info.who_am_i, "^a", path);

	if must_search
	then do;
		if subsystem_dir_ptr = null ()
		then subsystem_dir = "";
		else do;
			call hcs_$fs_get_path_name (subsystem_dir_ptr, subsystem_dir, (0), (""), status);
			if status ^= 0 then subsystem_dir = "";
		     end;

		call search_paths_$find_dir (search_list, null (), entryname, subsystem_dir, search_dirname, status);
		if status = 0 then dirname = search_dirname;
		else if status ^= error_table_$no_search_list
		then call complain (status, ec_info.who_am_i, "^a using ^a search list.", entryname, search_list);
	     end;

	pathname = rtrim (dirname);
	if length (pathname) ^= 1 then pathname = pathname || ">";
	pathname = pathname || entryname;

	return (pathname);

     end find_ec;
%page;
set_trace: proc (P_off_sw, P_str);

/* Parses list of trace terms separated by commas and does the work. */

dcl P_off_sw bit (1);
dcl P_str char (*);
dcl (i, str_len) fixed bin (21);
dcl 1 tracing,
   2 types,
    3 (command, comment, control, input) bit (1) unaligned,
   2 (on, off, output_switch, prefix_sw) bit (1) unaligned,
   2 expand fixed bin,
   2 prefix char (32) varying,
   2 iocb ptr;

	unspec (tracing) = "0"b;

	str_len = length (P_str);
begin;
dcl buffer char (str_len) varying;

	buffer = P_str;
	do while (buffer ^= "");
	     i = index (buffer, ",");
	     if i = 0 then do;
		call set_term (P_off_sw, (buffer));
		buffer = "";
	     end;
	     else do;
		call set_term (P_off_sw, substr (buffer, 1, i - 1));
		buffer = substr (buffer, i + 1);
	     end;
	end;

	if ^tracing.on & ^tracing.off then tracing.on = "1"b;

	if unspec (tracing.types) = "0"b then unspec (tracing.types) = "1111"b;

	if tracing.command then call set_one_trace (trace_info.command_line, "COMMAND");
	if tracing.input then call set_one_trace (trace_info.input_line, "INPUT");
	if tracing.control then call set_one_trace (trace_info.control_line, "CONTROL");
	if tracing.comment then call set_one_trace (trace_info.comment_line, "COMMENT");
end;

	return;


set_one_trace: proc (P_line, P_type);

dcl 1 P_line aligned like ec_trace_info.command_line;
dcl P_type char (*);

	P_line.explicit_sw = "1"b;

	if tracing.on then do;
	     P_line.on = "1"b;
	     if P_line.expand = 0 then		/* apply defaults for expansion tracing */
		if abs_data.absentee then P_line.expand = EXPANDED;
		else if P_type = "COMMENT" | P_type = "CONTROL" then P_line.expand = UNEXPANDED;
		else P_line.expand = EXPANDED;
	end;
	if tracing.off then P_line.on = "0"b;
	if tracing.expand ^= 0 then P_line.expand = tracing.expand;
	if tracing.prefix_sw then P_line.prefix = tracing.prefix;
	if tracing.output_switch then P_line.iocb = tracing.iocb;

end set_one_trace;
%page;
/* More procs internal to set_trace */

set_term: proc (P_off_sw, P_str);

/* Handles a single trace keyword or keyword pair ("prefix=STR"). */

dcl P_off_sw bit (1);
dcl P_str char (*);
dcl i fixed bin;

	i = index (P_str, "=");
	if i ^= 0 then call set_keyword (P_off_sw, substr (P_str, 1, i - 1), "1"b, substr (P_str, i + 1));
	else call set_keyword (P_off_sw, P_str, "0"b, "");

	return;


set_keyword: proc (P_off_sw, P_keyword, P_value_sw, P_value);

/* Does the work for a single trace keyword or keyword pair. */

dcl (P_off_sw, P_value_sw) bit (1);
dcl (P_keyword, P_value) char (*);

	if P_keyword = "command" then
	     if P_value_sw then do;
BAD_TRACE_SYNTAX:
		call complain (0, ec_info.who_am_i, "Syntax error in argument to -^[no_^]trace", P_off_sw);
		go to EGRESS;
	     end;
	     else tracing.command = "1"b;
	else if P_keyword = "comment" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else tracing.comment = "1"b;
	else if P_keyword = "control" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else tracing.control = "1"b;
	else if P_keyword = "input" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else tracing.input = "1"b;
	else if P_keyword = "all_types" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else tracing.command, tracing.comment, tracing.control, tracing.input = "1"b;

	else if P_off_sw | open_data.parser_version <= 1 then do;
	     call complain (0, ec_info.who_am_i, "Invalid keyword specified for ^[-no_^]trace", P_off_sw);
	     go to EGRESS;
	end;

	if P_keyword = "command" | P_keyword = "comment" | P_keyword = "control" | P_keyword = "input" then do;
	     if P_off_sw then tracing.off = "1"b;
	end;

	else if P_keyword = "unexpanded" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then do;
BAD_V1_TRACE_MODE:
		call complain (0, ec_info.who_am_i, "Invalid trace mode ""^a"" for a Version 1 ec.", P_keyword);
		go to EGRESS;
	     end;
	     else tracing.expand = UNEXPANDED;
	else if P_keyword = "expanded" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE;
	     else tracing.expand = EXPANDED;
	else if P_keyword = "all" | P_keyword = "all_expansions" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE;
	     else tracing.expand = ALL;
	else if P_keyword = "both" then
	     if P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE;
	     else tracing.expand = BOTH;

	else if P_keyword = "prefix" then
	     if ^P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE;
	     else do;
		tracing.prefix_sw = "1"b;
		tracing.prefix = P_value;
	     end;

	else if P_keyword = "output_switch" | P_keyword = "osw" then
	     if ^P_value_sw then go to BAD_TRACE_SYNTAX;
	     else if abs_data.parser_version = 1 then go to BAD_V1_TRACE_MODE;
	     else do;
		call iox_$find_iocb (P_value, tracing.iocb, status);
		if status ^= 0 then do;
		     call complain (status, ec_info.who_am_i, "Finding I/O switch ""^a""", P_value);
		     go to EGRESS;
		end;
		tracing.output_switch = "1"b;
	     end;

	else do;
	     call complain (0, ec_info.who_am_i, "Invalid -^[no_^]trace keyword ^a", P_off_sw, P_keyword);
	     go to EGRESS;
	end;

end set_keyword;

end set_term;

end set_trace;
%page;
%include abs_io_data;
%page;
%include abs_io_handler_node;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include ec_data;
%page;
%include ec_trace_info;
%page;
%include exec_com_info;
%page;
%include iocb;
%page;
%include listener_info;
%page;
%include stack_frame;
%page;
%include sub_error_info;


end absentee_listen_;




		    convert_ec.pl1                  04/29/86  0941.8rew 04/29/86  0939.6      206820



/****^  ***********************************************************
        *                                                         *
        * 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-04-14,Herbst), approve(86-04-14,MCR7377),
     audit(86-04-17,Kissel), install(86-04-22,MR12.0-1041):
     Fixed to apply equal convention correctly to -of argument.
                                                   END HISTORY COMMENTS */


/* format: off */

convert_ec: cvec: proc;

/* Converts a version 1 exec_com to version 2 */
/* Conversions of note are:	leading/trailing whitespace
				->  &SP, &HT, etc.	V2 ignores leading/trailing white
			&<whitespace>  ->  &-	new comment sequence
			&if [...]  -> &if &[...]	af expansion in control lines
			&&...&  ->  &&&&...&&	double strings of 2 or more &'s
			&(...)  ->  &&(...)		do command kludge
			&0  ->  &ec_path		&0 is obsolete in V2
			&NN     ->  &(NN)		2 or more digit params
			&command_line  ->  &trace &command
			&comment_line  ->  &trace &comment
			&control_line  -> &trace &control
			&input_line  ->  &trace &input
			&unknown (beginning of line)  ->  comment line  (causes warning unless -bf)
			&unknown -> &&unknown	(causes warning unless -bf)
/* Written 12/08/80 S. Herbst */
/* Converted to final MCR'd version 05/13/81 */
/* Changed to accept .absin suffix explicitly 12/17/81 S. Herbst */
/* Fixed to restore original if replacement is interrupted 01/03/84 S. Herbst */


/* Constants */

dcl KEYWORDS_STRING char (KEYWORDS_LEN) aligned based (addr (KEYWORDS));
dcl ME char (32) int static options (constant) init ("convert_ec");
dcl KEYWORDS (28) char (32) int static options (constant) init
	("&attach", "&command_line", "&comment_line", "&control_line", "&detach",
	 "&ec_dir", "&ec_name", "&ec_switch", "&else", "&f&n",
	 "&goto", "&if", "&input_line", "&is_absin", "&is_active_function",
	 "&is_af", "&is_attached", "&is_input_line", "&label", "&n",
	 "&print", "&q&n", "&quit", "&r&n", "&ready",
	 "&ready_proc", "&return", "&then");

dcl DIGITS char (10) int static options (constant) init ("0123456789");
dcl ALPHABET char (27) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz_");
dcl (BRANCHES init (2), BRANCHES_AND_LINKS init (3)) fixed (2) int static options (constant);
dcl WHITE char (4) int static options (constant) init (" 	");  /* SP HT VT FF */
dcl SP char (1) int static options (constant) init (" ");
dcl NL char (1) int static options (constant) init ("
");

dcl PREFIXES (10) char (8) varying int static options (constant) init
	("q", "r", "f", "qf", "rf", "q&n", "r&n", "f&n", "qf&n", "rf&n");

dcl TAKES_ARG (10) bit (1) int static options (constant) init
	("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b);

/* Based */

dcl arg char (arg_len) based (arg_ptr);


/* Automatic */

dcl (dn1, dn2, temp_dn) char (168);
dcl (en1, en2, suffix, temp_en) char (32);

dcl (absin_sw, begin_line_sw, chase_sw, check_sw, force_sw, got_path1_sw, got_path2_sw, star_sw) bit (1);

dcl arg_ptr ptr;

dcl KEYWORDS_LEN fixed;
dcl (arg_count, i, severity) fixed;
dcl star_select fixed (2);
dcl arg_len fixed (21);
dcl code fixed (35);

dcl error_table_$action_not_performed fixed (35) ext;
dcl error_table_$badopt fixed (35) ext;
dcl error_table_$namedup fixed bin (35) ext;
dcl error_table_$segknown fixed (35) ext;
dcl error_table_$segnamedup fixed (35) ext;

dcl iox_$error_output ptr ext;

dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl check_star_name_$entry entry (char (*), fixed (35));
dcl cu_$arg_count entry (fixed, fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed);
dcl delete_$ptr entry (ptr, bit (6), char (*), fixed bin (35));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35));
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl get_equal_name_ entry (char (*), char (*), char (*), fixed (35));
dcl get_pdir_ entry returns (char (168));
dcl get_system_free_area_ entry returns (ptr);
dcl get_temp_segment_ entry (char (*), ptr, fixed (35));
dcl hcs_$chname_seg entry (ptr, char (*), char (*), fixed (35));
dcl hcs_$delentry_seg entry (ptr, fixed bin (35));
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed, char (*), fixed (35));
dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed (24), fixed (2), ptr, fixed (35));
dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35));
dcl hcs_$set_bc_seg entry (ptr, fixed (24), fixed (35));
dcl hcs_$star_ entry (char (*), char (*), fixed (2), ptr, fixed, ptr, ptr, fixed (35));
dcl hcs_$terminate_noname entry (ptr, fixed (35));
dcl ioa_$ioa_switch entry options (variable);
dcl ioa_$rsnnl entry options (variable);
dcl nd_handler_ entry (char (*), char (*), char (*), fixed (35));
dcl pathname_ entry (char(*), char(*)) returns(char(168));
dcl release_temp_segment_ entry (char (*), ptr, fixed (35));

dcl (addr, copy, divide, hbound, fixed, index, length, null, rtrim, reverse, search, substr, verify) builtin;

dcl cleanup condition;
%page;
	KEYWORDS_LEN = length (KEYWORDS (1)) * hbound (KEYWORDS, 1);

	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;

/* Read control args */

	chase_sw, check_sw, force_sw = "0"b;
	got_path1_sw, got_path2_sw = "0"b;
	severity = 2;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then
		if arg = "-chase" then chase_sw = "1"b;
		else if arg = "-check" | arg = "-ck" then check_sw = "1"b;
		else if arg = "-force" | arg = "-fc" then force_sw = "1"b;
		else if arg = "-no_chase" then chase_sw = "0"b;
		else if arg = "-no_check" | arg = "-nck" then check_sw = "0"b;
		else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b;

		else if arg = "-output_file" | arg = "-of" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call com_err_ (0, ME, "No value specified for -output_file");
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		     call expand_pathname_ (arg, dn2, en2, code);
		     if code ^= 0 then do;
ARG_ERR:			call com_err_ (code, ME, "^a", arg);
			return;
		     end;
		     got_path2_sw = "1"b;
		end;

		else if arg = "-severity" | arg = "-sv" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call com_err_ (0, ME, "No value specified for -severity");
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     severity = cv_dec_check_ (arg, code);
		     if code ^= 0 then go to ARG_ERR;
		end;

		else do;
		     call com_err_ (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_path1_sw then do;
USAGE:		call com_err_$suppress_name (0, ME, "Usage:  convert_ec path {-control_args}");
		return;
	     end;

	     else do;
		suffix = "ec";
		if length (arg) > 6 then
		     if substr (arg, length (arg) - 5, 6) = ".absin" then suffix = "absin";

		call expand_pathname_$add_suffix (arg, suffix, dn1, en1, code);
		if code ^= 0 then go to ARG_ERR;

		call check_star_name_$entry (en1, code);
		if code ^= 0 then
		     if code = 1 | code = 2 then star_sw = "1"b;
		     else do;
			call com_err_ (code, ME, "^a", pathname_ (dn2, en2));
			return;
		     end;
		else star_sw = "0"b;

		got_path1_sw = "1"b;
	     end;
	end;

	if ^got_path1_sw then go to USAGE;

	if got_path2_sw then

	     if star_sw then call convert_stars (dn1, en1, dn2, en2);

	     else call convert_one (dn1, en1, dn2, en2);

	else if star_sw then call convert_stars (dn1, en1, dn1, "===");

	else call convert_one (dn1, en1, dn1, en1);

RETURN:	return;
%page;
convert_stars: proc (P_dn1, P_en1, P_dn2, P_en2);

dcl (P_dn1, P_en1, P_dn2, P_en2) char (*);
dcl 1 entries (entry_count) aligned based (entries_ptr),
   2 pad bit (18) unaligned,
   2 nindex bit (18) unaligned;
dcl names (999) char (32) based (names_ptr);
dcl area area based (area_ptr);
dcl (area_ptr, entries_ptr, names_ptr) ptr;
dcl (entry_count, j) fixed;

	area_ptr = get_system_free_area_ ();
	entries_ptr, names_ptr = null;

	if chase_sw then star_select = BRANCHES_AND_LINKS;
	else star_select = BRANCHES;

	on cleanup call star_cleanup;

	call hcs_$star_ (P_dn1, P_en1, star_select, area_ptr, entry_count, entries_ptr, names_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a^[>^]^a", P_dn1, P_dn1 ^= ">", P_en1);
	     return;
	end;

	do j = 1 to entry_count;

	     call convert_one (P_dn1, names_ptr -> names (fixed (entries_ptr -> entries (j).nindex)), P_dn2, P_en2);
	end;

	call star_cleanup;

	return;

star_cleanup: proc;

	if entries_ptr ^= null then free entries in (area);
	if names_ptr ^= null then free names in (area);

end star_cleanup;

end convert_stars;
%page;
convert_one: proc (P_dn1, P_en1, P_dn2, P_en2);

dcl (P_dn1, P_en1, P_dn2, P_en2) char (*);
dcl seg1 char (len1) based (ptr1);
dcl seg2 char (len2) based (ptr2);
dcl (digit_str, target_en) char (32);
dcl keyword_name char (32) varying;
dcl next_char char (1);
dcl (errors_sw, found_sw, replacing_orig_sw) bit (1);
dcl (ptr1, ptr2, safe_copy_ptr, target_ptr) ptr;
dcl bit_count fixed (24);
dcl (len1, len2, pos1) fixed (21);
dcl (i, line_number) fixed;
dcl (code, safe_copy_code) fixed (35);

	call get_equal_name_ (P_en1, P_en2, target_en, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a for ^a", P_en2, P_en1);
	     go to RETURN;
	end;

/* Add suffix if necessary to target entry name */

	call expand_pathname_$add_suffix (target_en, suffix, (""), target_en, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", target_en);
	     go to RETURN;
	end;

	ptr1, ptr2, safe_copy_ptr, target_ptr = null;
	replacing_orig_sw = "0"b;

	on cleanup call clean_up;

	call hcs_$initiate_count (P_dn1, P_en1, "", bit_count, 0, ptr1, code);
	if ptr1 = null then do;
	     call com_err_ (code, ME, "^a", pathname_ (P_dn1, P_en1));
	     return;
	end;

RETRY:	if ^check_sw then do;
	     call hcs_$make_seg (P_dn2, target_en, "", 01010b, target_ptr, code);
	     if target_ptr = null then do;
		call com_err_ (code, ME, "^a", pathname_ (P_dn2, target_en));
		go to RETURN;
	     end;
	     else if (code = error_table_$namedup | code = error_table_$segknown) & target_ptr ^= ptr1 then do;
		call nd_handler_ (ME, dn2, target_en, code);
		if code = error_table_$action_not_performed then return;
		else go to RETRY;
	     end;
	end;

	len1 = divide (bit_count, 9, 21, 0);
	line_number = 1;
	pos1 = verify (seg1, WHITE);

	len2 = 0;

	if substr (seg1, pos1, 8) = "&version" then do;
	     pos1 = pos1 + 8;
	     if substr (seg1, pos1, 1) ^= SP then do;
BAD_VERSION:	call com_err_ (0, ME, "Invalid &version statement on first line.");
CLEANUP_TARGET:	if target_ptr ^= null & target_ptr ^= ptr1 then call hcs_$delentry_seg (target_ptr, code);
		go to RETURN;
	     end;

	     i = verify (substr (seg1, pos1), WHITE);
	     if i = 0 then go to BAD_VERSION;
	     pos1 = pos1 + i - 1;
	     if substr (seg1, pos1, 1) = NL then go to BAD_VERSION;  /* no number */
	     if index (WHITE || NL, substr (seg1, pos1 + 1, 1)) = 0 then go to BAD_VERSION;  /* not 1 char */

	     if substr (seg1, pos1, 1) = "2" then do;
		call com_err_ (0, ME, "Segment is already version 2.  ^a",
		     pathname_ (P_dn1, P_dn2));
		go to CLEANUP_TARGET;
	     end;
	     else if substr (seg1, pos1, 1) ^= "1" then go to BAD_VERSION;

	     pos1 = pos1 + verify (substr (seg1, pos1 + 1), WHITE || NL);  /* skip the &version stmt */
	end;
	else pos1 = 1;				/* if no &version 1, don't strip leading white space */

	if ^check_sw then do;
	     call get_temp_segment_ (ME, ptr2, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Temp segment.");
		go to CLEANUP_TARGET;
	     end;
	end;

	call output ("&version 2" || NL);

/* Convert the segment */

	errors_sw = "0"b;

	i = verify (seg1, WHITE);			/* look for initial leading whitespace */
	if i > 1 then do;

	     call convert_white (substr (seg1, 1, i - 1));

	     pos1 = i;
	end;

	do while (pos1 <= len1);

	     i = search (substr (seg1, pos1), "&" || NL);

	     if i = 0 then do;

		if index (WHITE, substr (seg1, len1, 1)) ^= 0 then

		     call convert_trailing_white (substr (seg1, pos1));

		else call output (substr (seg1, pos1));

		go to COPY_SEG;
	     end;

	     if substr (seg1, pos1 + i - 1, 1) = NL then do;  /* NL */
		if i > 1 then			/* some text in between */
		     if index (WHITE, substr (seg1, pos1 + i - 2, 1)) ^= 0 then

			call convert_trailing_white (substr (seg1, pos1, i - 1));

		     else call output (substr (seg1, pos1, i - 1));

		call output (NL);

		line_number = line_number + 1;
		pos1 = pos1 + i;			/* position past the NL */
		i = verify (substr (seg1, pos1), WHITE);  /* look for leading whitespace */
		if i > 1 then do;

		     call convert_white (substr (seg1, pos1, i - 1));

		     pos1 = pos1 + i - 1;
		end;

		go to NEXT;
	     end;

/*  &  */
	     if i > 1 then call output (substr (seg1, pos1, i - 1));  /* copy up to the & */

	     pos1 = pos1 + i - 1;			/* position of the & */

	     if pos1 = len1 | index (WHITE || NL, substr (seg1, pos1 + 1, 1)) ^= 0 then do;  /* comment */
		i = index (substr (seg1, pos1), NL);  /* take whole comment line */
		if i = 0 then do;
		     call warn (3, "Segment does not end in newline.");

		     if pos1 = len1 then call output ("&-");

		     else call output ("&-" || substr (seg1, pos1 + 1));

		     go to COPY_SEG;
		end;
		else if pos1 = 1 then do;

GOOD_COMMENT:	     call output ("&-" || substr (seg1, pos1 + 1, i - 1));

		     line_number = line_number + 1;
		     pos1 = pos1 + i;
		end;
		else if substr (seg1, pos1 - 1, 1) = NL then go to GOOD_COMMENT;
		else do;
		     call warn (1, "&<SP> does not begin line; converted to &&<SP>");

		     call output ("&& ");

		     pos1 = pos1 + 2;
		end;
	     end;

	     else if substr (seg1, pos1 + 1, 1) = "&" then do;  /* double 2 or more &'s */
		i = verify (substr (seg1, pos1), "&") - 1;
		if i = -1 then i = len1 - pos1 + 1;

		call output (copy ("&", i * 2));

		pos1 = pos1 + i;
	     end;

	     else do;				/* &keyword */

		if substr (seg1, pos1 + 1, 1) = "(" then do;  /* the do command kludge */
						/* change &(1) -> &&(1) */
		     call output ("&" || substr (seg1, pos1, 2));

		     pos1 = pos1 + 2;
		end;

		else do;

		     if pos1 = 1 then begin_line_sw = "1"b;
		     else if substr (seg1, pos1 - 1, 1) = NL then begin_line_sw = "1"b;
		     else begin_line_sw = "0"b;

		     pos1 = pos1 + 1;
		     next_char = substr (seg1, pos1, 1);

		     if index (DIGITS, next_char) ^= 0 then do;  /* &1 parameter */

			call output ("&");

PARAM:			i = verify (substr (seg1, pos1), DIGITS);
			if i = 0 then do;
			     call warn (3, "Segment does not end in newline.");
			     digit_str = substr (seg1, pos1);
			end;
			else digit_str = substr (seg1, pos1, i - 1);

			if length (rtrim (digit_str)) = 1 then

			     if digit_str = "0" then call output ("ec_path");

			     else call output (rtrim (digit_str));

			else call output ("(" || rtrim (digit_str) || ")");  /* &12 -> &(12) */

			pos1 = pos1 + length (rtrim (digit_str));
		     end;

		     else do;			/* some &keyword */

			if index ("fqr", next_char) ^= 0 then do;  /* might be &r, &q, &f something */

			     do i = hbound (PREFIXES, 1) by -1 to 1
				while (index (substr (seg1, pos1), PREFIXES (i)) ^= 1); end;

			     if i ^= 0 then do;	/* it is */
				if TAKES_ARG (i) then do;
				     if pos1 < len1 &
				       index (DIGITS, substr (seg1, pos1 + length (PREFIXES (i)), 1)) ^= 0 then do;

					call output ("&" || PREFIXES (i));

					pos1 = pos1 + length (PREFIXES (i));
					go to PARAM;
				     end;
				end;

				else do;		/* &f&n, &r&n, &q&n, &rf&n, &qf&n */

				     call output ("&" || PREFIXES (i));

				     pos1 = pos1 + length (PREFIXES (i));
				     go to NEXT;
				end;
			     end;
			end;

			keyword_name = "&";
			found_sw = "0"b;

			do while (^found_sw);

			     keyword_name = keyword_name || next_char;
			     pos1 = pos1 + 1;

			     if known (keyword_name) then do;

				found_sw = "1"b;

				if keyword_name = "&command_line" then call output ("&trace &command");
				else if keyword_name = "&input_line" then call output ("&trace &input");
				else if keyword_name = "&comment_line" then call output ("&trace &comment");
				else if keyword_name = "&control_line" then call output ("&trace &control");

				else do;

				     call output ((keyword_name));

				     if keyword_name = "&if" then do;  /* &if [ -> &if &[ */
					pos1 = pos1 + verify (substr (seg1, pos1), WHITE) - 1;
					if substr (seg1, pos1, 1) = "[" then do;
					     pos1 = pos1 + 1;

					     call output (" &[");
					end;

					else call output (" ");
				     end;

				     else if keyword_name = "&print" then do;  /* look for &print ^-^/^x etc. */
					i = index (substr (seg1, pos1), NL);
					if i = 0 then i = len1 - pos1 + 1;
					if index (substr (seg1, pos1, i), "^") ^= 0 then
					     call warn (3, "ioa_ controls in &print statement:  "
						|| rtrim (substr (seg1, pos1 + 1, i - 1), NL) || NL
						|| "Should be replaced by literals such as &SP");
				     end;
				end;
			     end;

			     else do;
				if pos1 > len1 | index (ALPHABET, substr (seg1, pos1, 1)) = 0 then do;

				     found_sw = "1"b;  /* stop the loop */

				     if begin_line_sw then do; /* &word  begins line; convert line to comment */
					call warn (2, "Invalid stmt " || keyword_name ||
					     " converted to comment.");
					i = index (substr (seg1, pos1), NL);
					if i = 0 then call output ("&-" || keyword_name || substr (seg1, pos1));

					else do;

					     call output ("&-" || keyword_name || substr (seg1, pos1, i - 1));

					     pos1 = pos1 + i - 1;  /* skip to NL at end of line */
					end;
				     end;
				     else do;
					call warn (1, "Invalid keyword " || keyword_name
					     || " converted to literal string.");

					call output ("&" || keyword_name);  /* convert to literal &&string */
				     end;
				end;

				else next_char = substr (seg1, pos1, 1);
			     end;
			end;
		     end;
		end;
	     end;
NEXT:	end;

COPY_SEG:
	if ^check_sw then do;			/* write the converted seg */

	     if errors_sw & ^force_sw then do;
		call hcs_$set_bc_seg (ptr2, len2 * 9, 0);

		call hcs_$fs_get_path_name (ptr2, temp_dn, 0, temp_en, code);
		if code ^= 0 then do;
		     temp_dn = get_pdir_ ();
		     go to TERMINATE;
		end;

RENAME_TEMP:	call hcs_$chname_seg (ptr2, temp_en, target_en, code);
		if code ^= 0 then do;
		     if code = error_table_$namedup | code = error_table_$segnamedup then do;
			call com_err_ (0, ME, "Errors found.");
			call nd_handler_ (ME, temp_dn, target_en, code);
			if code = 0 then go to RENAME_TEMP;
			if code = error_table_$action_not_performed then go to DELETE_OFILE;
		     end;
		     call com_err_ (code, ME, "Errors found; unable to rename temp copy in ^[^a^;[pd]^]",
			temp_dn ^= get_pdir_ (), temp_dn);
		end;
		else do;
TERMINATE:	     call hcs_$terminate_noname (ptr2, code);
		     ptr2 = null;			/* so release_temp_segments_ doesn't get it */

		     call com_err_ (code, ME, "Errors found; look for copy ^[^a;^s[pd]>^a^]",
			temp_dn ^= get_pdir_ (), pathname_ (temp_dn, temp_en), temp_en);
		end;

DELETE_OFILE:	if target_ptr ^= null & target_ptr ^= ptr1 then do;
		     call delete_$ptr (target_ptr, "000100"b, ME, 0);
		     target_ptr = null;
		end;
	     end;

	     else do;
		call get_temp_segment_ (ME, safe_copy_ptr, safe_copy_code);  /* keep copy of orig */
		if code = 0 then safe_copy_ptr -> seg1 = ptr1 -> seg1;  /* in case replacement is interrupted */
		else safe_copy_ptr = null;

		replacing_orig_sw = "1"b;

		target_ptr -> seg2 = ptr2 -> seg2;

		call hcs_$set_bc_seg (target_ptr, len2 * 9, code);
	     end;
	end;

	call finish_up;

	return;
%page;
convert_trailing_white: proc (P_str);

/* Outputs up to the trailing whitespace, then outputs
   literals instead of the trailing whitespace */

dcl P_str char (*);
dcl white_len fixed;

	if length (P_str) = 0 then return;

	white_len = verify (reverse (P_str), WHITE) - 1;
	if white_len = -1 then white_len = length (P_str);

	call output (substr (P_str, 1, length (P_str) - white_len));

	call convert_white (substr (P_str, length (P_str) - white_len + 1));

end convert_trailing_white;
%page;
convert_white: proc (P_str);

/* P_str is all whitespace; output as literals */

dcl P_str char (*);
dcl LITERAL (4) char (2) int static options (constant) init ("SP", "HT", "VT", "FF");
dcl literal_string char (32) varying;
dcl (count, i, type, type2) fixed;

	if length (P_str) = 0 then return;

	type = index (WHITE, substr (P_str, 1, 1));
	count = 1;

	do i = 2 to length (P_str);

	     type2 = index (WHITE, substr (P_str, i, 1));

	     if type2 = type then count = count + 1;
	     else do;
ADD_LITERAL:	call ioa_$rsnnl ("&^a(^d)", literal_string, length (literal_string),
		     LITERAL (type), count);

		call output ((literal_string));

		type = type2;
		count = 1;
		if i >= length (P_str) then return;
	     end;
	end;

	go to ADD_LITERAL;

end convert_white;
%page;
clean_up: proc;

	if target_ptr ^= null & target_ptr ^= ptr1 then do;
	     call delete_$ptr (target_ptr, "000100"b, ME, 0);
	     target_ptr = null;
	end;
	if replacing_orig_sw then
	     if safe_copy_ptr = null then
		call com_err_ (safe_copy_code, ME, "Unable to get temp seg; can't restore original.");
	     else ptr1 -> seg1 = safe_copy_ptr -> seg1;
	call finish_up ();

end clean_up;


finish_up: proc;

	if ptr1 ^= null then call hcs_$terminate_noname (ptr1, 0);
	if ptr2 ^= null then call release_temp_segment_ (ME, ptr2, 0);
	if safe_copy_ptr ^= null then call release_temp_segment_ (ME, safe_copy_ptr, 0);
	if target_ptr ^= null then call hcs_$terminate_noname (target_ptr, 0);
	ptr1, ptr2, safe_copy_ptr, target_ptr = null;
	replacing_orig_sw = "0"b;

end finish_up;


output: proc (P_str);

dcl P_str char (*);
dcl i fixed;

	if check_sw then return;
	i = length (P_str);
	len2 = len2 + i;
	substr (seg2, len2 - i + 1) = P_str;

end output;


warn: proc (P_severity, P_str);

dcl P_severity fixed;
dcl P_str char (*);

	if P_severity >= 2 then errors_sw = "1"b;
	if P_severity < severity then return;
	call ioa_$ioa_switch (iox_$error_output, "(sv ^d) Line ^d: ^a", P_severity, line_number, P_str);

end warn;

end convert_one;
%page;
known: proc (P_keyword) returns (bit (1));

dcl P_keyword char (*) varying;
dcl i fixed;

	i = index (KEYWORDS_STRING, P_keyword || " ");

	return (i > 0);

end known;

end convert_ec;




		    signal_io_error_.pl1            11/04/82  1933.2rew 11/04/82  1618.0       12807



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


/* format: style3,idind30,ll122,ifthenstmt */

signal_io_error_:
     procedure (message, switch, status);

declare	message			char (*),
	switch			ptr,
	status			fixed bin (35);

declare	signal_			entry () options (variable);

declare	1 io_error_info		aligned,
	  2 length		fixed bin,
	  2 version		fixed bin initial (1),
	  2 action_flags,
	    3 cant_restart		bit (1) unaligned initial ("0"b),
	    3 default_restart	bit (1) unaligned initial ("0"b),
	    3 pad			bit (34) unaligned initial (""b),
	  2 info_string		char (256) varying initial (message),
	  2 status_code		fixed bin (35) initial (status),
	  2 stream		char (32) initial (switch -> iocb.name),
	  2 io_status		bit (72) initial (""b);

%include iocb;

	io_error_info.length = size (io_error_info);	/* Compiler won't allow this as initial attribute		*/

	call signal_ ("io_error", null (), addr (io_error_info));

	return;
     end signal_io_error_;




		    value_.pl1                      10/03/86  1244.3rew 10/02/86  1512.2      513315



/****^  ***********************************************************
        *                                                         *
        * 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-08-18,JSLove), approve(86-08-18,MCR7518),
     audit(86-08-18,Parisek), install(86-10-02,MR12.0-1175):
     Changed to call match_star_name_ instead of value_match_.  Value_match_
     was deleted when the new match_star_name_ was installed.
                                                   END HISTORY COMMENTS */


value_: proc;

/* Written 11/17/80 by Steve Herbst */
/* Fixed to catch deleted default value seg 08/81/81 Steve Herbst */
/* Fixed for $set to create default seg unless -pp specified 12/01/81 Steve Herbst */
/* Fixed to truncate value seg after compaction 02/01/82 Steve Herbst */
/* Fixed value_$list_data_names to return word lengths 03/20/82 Steve Herbst */
/* Modified: 29 March 1982 by G. Palter to garbage collect after adding/replacing values, to not release write lock in the
      middle of deleting a push-down list of nodes, and to free the temporary segment used for garbage collection if the
      user releases during GCing */
/* Fixed value_$list to free allocated things on cleanup 05/24/82 Steve Herbst */
/* Fixed value_$list to work on nonshareable value seg like exec_com uses 06/08/83 Steve Herbst */
/* Fixed $get_path to notice hcs_$fs_get_path_name error 02/07/84 Steve Herbst */
/* Fixed $list to return pushed values latest to earliest 07/26/84 Steve Herbst */
/* Optimize var-setting to reuse old node if same length and type 02/15/85 Steve Herbst */


/* The value database */

dcl 1 seg aligned based (seg_ptr),			/* value segment (shareable) */
     2 header,
      3 version fixed bin,
      3 banner bit (36),				/* identifying decoration (= BANNER) */
      3 ht_size fixed bin,				/* for later modifications */
      3 region_size fixed bin,			/* explicit size or rest of seg */
      3 remote_area_ptr ptr,				/* null=>use seg.node_region, alloc by addrel, salvage */
      3 lock bit (36),				/* standard interprocess lock */
      3 salvaging_sw bit (1),				/* ON while locked for salvage */
      3 change_count fixed bin (35),			/* incremented by writer when data is changed */
      3 next_free_offset bit (18),			/* for next node allocation in seg.node_region */
      3 trash_count fixed bin,			/* number of nodes freed before salvage */
      3 offset_ht (0:60) bit (18),			/* hash table of offsets into region */
     2 node_region (seg_region_size refer (seg.region_size)) fixed bin;  /* to contain nodes */

dcl 1 pp aligned based (pp_ptr),			/* perprocess value database */
     2 version fixed bin,
     2 banner bit (36),				/* = PP_BANNER to distinguish from shareable seg */
     2 ht_size fixed bin,
     2 remote_area_ptr ptr,				/* non-null: points  to an area for node allocation */
     2 pad (2) fixed bin,
     2 ptr_ht (0:60) ptr unaligned;			/* hash table of pointers */

dcl 1 node_header aligned based,			/* to be used in node structure */
     2 version fixed bin,
     2 banner bit (36),				/* for recognizing a node when salvaging (=BANNER) */
     2 next_offset bit (18),				/* forward offset, for seg (shared) */
     2 next_ptr ptr unaligned,			/* forward ptr, for pp (perprocess) */
     2 switches,
      3 pp_sw bit (1) unaligned,			/* ON for perprocess values */
      3 data_sw bit (1) unaligned,			/* ON only for values set by $set_data etc. */
      3 push_sw bit (1) unaligned,			/* ON if $push'ed on top of another value */
      3 pad bit (33) unaligned,
     2 name_len fixed bin (21),			/* length of variable name */
     2 value_len fixed bin (21);			/* length of value string */

dcl 1 node aligned based (node_ptr),			/* a single name-value pair */
     2 header like node_header,
     2 name char (node_name_len refer (node.name_len)) varying,
     2 value char (node_value_len refer (node.value_len)) varying;

dcl 1 old_node_format aligned based,			/* vestige from before version number */
     2 banner bit (36),				/* for recognizing a node when salvaging (=BANNER) */
     2 next_offset bit (18),				/* forward offset, for seg (shared) */
     2 next_ptr ptr unaligned,			/* forward ptr, for pp (perprocess) */
     2 name_len fixed bin (21),			/* length of variable name */
     2 value_len fixed bin (21),			/* length of value string */
     2 name char (node_name_len refer (old_node_format.name_len)),
     2 value char (node_value_len refer (old_node_format.value_len));


/* Other structures */

%include value_structures;

dcl 1 name_info aligned,				/* pointer and length of variable name_info */
     2 ptr ptr,
     2 len fixed bin (21);

dcl 1 value_info aligned,				/* pointer and length of value string */
     2 ptr ptr,
     2 len fixed bin (21),
     2 seg_ptr ptr,					/* for unlocking */
     2 change_count fixed bin;			/* for unlocking */

dcl 1 new_value_info aligned like value_info;		/* value to be set */
dcl 1 old_value_info aligned like value_info;		/* to test against existing value */

dcl 1 alloc_info aligned,				/* for freeing char string copy of value arg */
     2 ptr ptr,
     2 len fixed bin (21),
     2 area_ptr ptr;

dcl 1 node_ptrs aligned,
     2 this ptr,					/* pointer to current (found) node */
     2 last ptr,					/* pointer to previous node */
     2 segp ptr,					/* pointer to seg or pp header */
     2 hash fixed bin;				/* hash table index */

dcl 1 sort_array aligned based (sort_array_ptr),		/* for sorting var names for value_$list */
     2 count fixed bin,
     2 name_ptr (sort_array.count) ptr unaligned;

dcl 1 sort_entry aligned based (sort_entry_ptr),
   2 node_ptr ptr,
   2 sort_field,
    3 length fixed bin,				/* simulate a varying string */
    3 name char (node.name_len) unaligned,
    3 sequence pic"999999" unaligned,
   2 next_entry ptr;

/* Constants */

dcl MAX_TRASH_COUNT fixed bin int static options (constant) init (512);

dcl BANNER bit (36) int static options (constant) init ("707070707070"b3);
dcl PP_BANNER bit (36) int static options (constant) init ("070707070707"b3);
dcl HT_SIZE fixed int static options (constant) init (61);
dcl value_version_1 fixed bin int static options (constant) init (1);
dcl (PERMANENT init (0), PERPROCESS init (1)) fixed bin int static options (constant);
dcl (PERMANENT_SW init ("01"b), PERPROCESS_SW init ("10"b)) bit (2) int static options (constant);

dcl SUFFIX char (6) int static options (constant) init (".value");
dcl SUFFIX_LEN fixed bin int static options (constant) init (6);

dcl BIT_TYPE fixed bin int static options (constant) init (19);
dcl CHAR_TYPE fixed bin int static options (constant) init (21);
dcl FIXED_BIN_TYPE fixed bin int static options (constant) init (1);
dcl PTR_TYPE fixed bin int static options (constant) init (13);
dcl VARYING_CHAR_TYPE fixed bin int static options (constant) init (22);

dcl WHITE char (2) int static options (constant) init (" 	");  /* SP HT */


/* Static */

dcl perprocess_seg_ptr ptr int static init (null);	/* pointer to pp seg in process_dir */

dcl default_seg_ptr ptr int static init (null);		/* pointer to default value seg used by commands */


/* Arguments */

dcl (A_path, A_name) char (*);
dcl A_switches bit (36) aligned;
dcl A_create_sw bit (1);
dcl (A_area_ptr, A_data_ptr, A_new_data_ptr, A_old_data_ptr, A_remote_area_ptr, A_seg_ptr, A_value_ptr) ptr;
dcl (A_match_info_ptr, A_value_list_info_ptr) ptr;
dcl A_seg_type fixed bin;
dcl (A_data_size, A_new_data_size, A_old_data_size) fixed bin (18);
dcl A_region_size fixed bin (19);
dcl A_value_len fixed bin (21);
dcl A_code fixed bin (35);


/* Global arg info for options (variable) entries */

dcl options_var_sw bit (1) aligned;
dcl arg_list_ptr ptr;
dcl (code_arg_index, old_value_arg_index) fixed bin;


/* Based */

dcl char8 char (8) based;
dcl name_string char (name_info.len) based (name_info.ptr);
dcl value_string char (value_info.len) based (value_info.ptr);
dcl new_value_string char (new_value_info.len) based (new_value_info.ptr);
dcl old_value_string char (old_value_info.len) based (old_value_info.ptr);
dcl alloc_string char (alloc_info.len) based (alloc_info.ptr);

dcl based_area area based;

dcl bits bit (99 /* indefinite */) aligned based;		/* for copying data */

dcl 1 seg_mode_bits unaligned based (addr (seg_mode)),
   2 pad bit (32) unaligned,
   2 (R_BIT, E_BIT, W_BIT, pad1) bit (1) unaligned;


/* Automatic */

dcl (dn, path) char (168);
dcl en char (32);

dcl number_picture picture"999999";

dcl switches bit (36);
dcl pp_sw_arg bit (1) defined (switches) position (1);
dcl seg_sw_arg bit (1) defined (switches) position (2);

dcl node_offset bit (18);
dcl (alloc_entrypoint_sw, function_entrypoint_sw, pop_sw, push_sw, set_entrypoint_sw) bit (1) aligned init ("0"b);
dcl (data_entrypoint_sw, found_one_sw, local_pp_sw, locked_sw, test_entrypoint_sw) bit (1) aligned;

dcl (area_ptr, new_node_ptr, node_ptr, old_node_ptr, pp_ptr, seg_ptr) ptr;
dcl (sort_array_ptr, sort_entries_ptr, sort_entry_ptr, where_ptr) ptr;

dcl seg_mode fixed bin (5);
dcl (begin_change_count, i, saved_sort_count, sequential_number, sort_field_offset) fixed bin;
dcl (chars_index, node_name_len, node_value_len, saved_chars_len) fixed bin (21);
dcl (code, seg_code) fixed bin (35);

dcl error_table_$action_not_performed fixed bin (35) ext;
dcl error_table_$bad_conversion fixed bin (35) ext;
dcl error_table_$badcall fixed bin (35) ext;
dcl error_table_$boundviol fixed bin (35) ext;
dcl error_table_$invalid_lock_reset fixed bin (35) ext;
dcl error_table_$locked_by_this_process fixed bin (35) ext;
dcl error_table_$lower_ring fixed bin (35) ext;
dcl error_table_$noalloc fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;
dcl error_table_$oldnamerr fixed bin (35) ext;
dcl error_table_$no_r_permission fixed bin (35) ext;
dcl error_table_$no_w_permission fixed bin (35) ext;
dcl error_table_$not_seg_type fixed bin (35) ext;
dcl error_table_$out_of_sequence fixed bin (35) ext;

dcl sys_info$max_seg_size fixed bin (24) ext;

dcl assign_ entry (ptr, fixed bin, fixed bin (21), ptr, fixed bin, fixed bin (21));
dcl cu_$arg_list_ptr entry returns (ptr);
dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit (1) aligned, fixed bin, fixed bin, fixed bin);
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_temp_segment_ entry (char (*), ptr, fixed (35));
dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl match_star_name_ entry (char (*), char (*), fixed bin (35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));
dcl release_temp_segment_ entry (char (*), ptr, fixed (35));
dcl search_file_ entry (ptr, fixed bin (21), fixed bin (21), ptr, fixed bin (21), fixed bin (21),
	fixed bin (21), fixed bin (21), fixed bin (35));
dcl set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl sort_items_$varying_char entry (ptr);
dcl user_info_ entry options (variable);
dcl user_info_$homedir entry (char (*));

dcl (addr, addrel, baseno, bit, currentsize, divide, fixed) builtin;
dcl (length, mod, null, pointer, rel, rtrim, substr, unspec, wordno) builtin;

dcl (any_other, area, cleanup, conversion, no_write_permission, not_in_write_bracket, sub_error) condition;
%page;
defined: entry (A_seg_ptr, A_switches, A_name, A_code) returns (bit (1) aligned);

	data_entrypoint_sw, options_var_sw = "0"b;

	function_entrypoint_sw = "1"b;

	call copy_args;

	A_code = 0;

	call get_ptrs (seg_ptr, pp_ptr);

	if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then return ("1"b);

	else return ("0"b);
%page;
delete: entry (A_seg_ptr, A_switches, A_name, A_code);

	data_entrypoint_sw, options_var_sw = "0"b;
	A_code = 0;

	call copy_args;

	call get_ptrs (seg_ptr, pp_ptr);

	call lock_for_write (seg_ptr);

	on cleanup call unlock_for_write (seg_ptr);

	found_one_sw = "0"b;
DELETE:
	if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do;

	     found_one_sw = "1"b;
	     push_sw = node_ptrs.this -> node.push_sw;

	     call delete_node (node_ptrs);

	     if push_sw then go to DELETE;		/* delete all pushed values and the original */
	end;

	else if ^found_one_sw then A_code = error_table_$oldnamerr;

	call unlock_for_write (seg_ptr);

	return;
%page;
delete_data: entry (A_seg_ptr, A_switches, A_name, A_code);

	options_var_sw = "0"b;
	data_entrypoint_sw = "1"b;
	A_code = 0;

	call copy_args;

	call get_ptrs (seg_ptr, pp_ptr);

	call lock_for_write (seg_ptr);

	on cleanup call unlock_for_write (seg_ptr);

	found_one_sw = "0"b;
	go to DELETE;
%page;
get: entry options (variable);

/* call value_$get (seg_ptr, switches, name, value_arg, code); */

	options_var_sw = "1"b;
	code_arg_index = 5;				/* global; used by return_code */
	arg_list_ptr = cu_$arg_list_ptr ();

	call get_options_var_args (arg_list_ptr);

	data_entrypoint_sw = "0"b;

GET:	call get_ptrs (seg_ptr, pp_ptr);

	if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do;

FOUND1:	     call set_value_arg (arg_list_ptr, 4, value_info);  /* return the value */

	     if value_info.seg_ptr ^= null then		/* unlock for read */
		if value_info.seg_ptr -> seg.change_count ^= value_info.change_count then do;

		     if find_in (value_info.seg_ptr, name_info, value_info, node_ptrs) then go to FOUND1;  /* retry */

		     else go to NOT_FOUND1;
		end;

	     call return_code (0);			/* zero status code */
	end;
	else
NOT_FOUND1:    call return_code (error_table_$oldnamerr);

RETURN:
	if function_entrypoint_sw then return ("0"b);		/* value_$defined */
	else return;
%page;
get_alloc: entry (A_seg_ptr, A_switches, A_name, A_area_ptr, A_value_ptr, A_value_len, A_code);

	alloc_entrypoint_sw = "1"b;
	data_entrypoint_sw = "0"b;
	go to GET_DATA;
%page;
get_data: entry (A_seg_ptr, A_switches, A_name, A_area_ptr, A_data_ptr, A_data_size, A_code);

	data_entrypoint_sw = "1"b;
GET_DATA:
	options_var_sw = "0"b;

	if A_area_ptr = null then call return_code (error_table_$noalloc);

	call copy_args;

	go to GET;
%page;
get_path: entry (A_path, A_code);

	A_code = 0;

	options_var_sw = "0"b;

	if default_seg_ptr ^= null then
	     call hcs_$fs_get_path_name (default_seg_ptr, dn, 0, en, A_code);

	else call get_default_path (dn, en);

	if A_code = 0 then A_path = pathname_ (dn, en);

	call return_code (A_code);
%page;
init_seg: entry (A_seg_ptr, A_seg_type, A_remote_area_ptr, A_region_size, A_code);

/* See if already initiated */

	options_var_sw = "0"b;

	if A_seg_ptr -> seg.banner = BANNER then
	     if A_seg_type ^= PERMANENT then call return_code (error_table_$not_seg_type);
	     else if A_remote_area_ptr ^= null then call return_code (error_table_$out_of_sequence);
	     else call return_code (0);
	else if A_seg_ptr -> pp.banner = PP_BANNER then
	     if A_seg_type ^= PERPROCESS then call return_code (error_table_$not_seg_type);
	     else if A_remote_area_ptr ^= null then call return_code (error_table_$out_of_sequence);
	     else call return_code (0);

	call init_seg (A_seg_ptr);

	if A_seg_type = PERPROCESS then do;
	     A_seg_ptr -> pp.banner = PP_BANNER;
	     do i = 0 to A_seg_ptr -> pp.ht_size - 1;	/* fill hash table with null ptrs */
		A_seg_ptr -> pp.ptr_ht (i) = null;
	     end;
	     if A_remote_area_ptr ^= null then
		A_seg_ptr -> pp.remote_area_ptr = A_remote_area_ptr;
	     else A_seg_ptr -> pp.remote_area_ptr = get_system_free_area_ ();
	end;

	else do;
	     A_seg_ptr -> seg.banner = BANNER;		/* shareable seg */
	     unspec (A_seg_ptr -> seg.offset_ht) = "0"b;
	     if A_region_size > 0 then A_seg_ptr -> seg.region_size = A_region_size;
	end;

	call return_code (0);
%page;
list: entry (A_seg_ptr, A_switches, A_match_info_ptr, A_area_ptr, A_value_list_info_ptr, A_code);

/* Using A_match_info_ptr->match_info to select, returns names/values for matching variables */

	data_entrypoint_sw = "0"b;
LIST:
	options_var_sw = "0"b;

	A_code = 0;
	seg_ptr = A_seg_ptr;
	switches = A_switches;
	match_info_ptr = A_match_info_ptr;
	area_ptr = A_area_ptr;
	if area_ptr = null then area_ptr = get_system_free_area_ ();

	call get_ptrs (seg_ptr, pp_ptr);

	sort_entries_ptr, sort_array_ptr, value_list_info_ptr = null;

	on cleanup call list_cleanup;

	call get_temp_segment_ ("value_$list", sort_array_ptr, code);
	call get_temp_segment_ ("value_$list", sort_entries_ptr, code);

	sort_entry_ptr = sort_entries_ptr;
	sort_field_offset = wordno (addr (sort_entry)) - wordno (addr (sort_entry.sort_field));
	sort_array.count, alloc_chars_len, sequential_number = 0;

	if pp_ptr ^= null then do;			/* search perprocess values */

	     call list_pp (pp_ptr);
	end;

	if seg_ptr ^= null then

	     if seg_ptr -> seg.banner = PP_BANNER then call list_pp (seg_ptr);
						/* a private nonshareable value seg, as for exec_com */

	     else do;				/* a real value seg */

		saved_chars_len = alloc_chars_len;		/* in case we have to retry */
		saved_sort_count = sort_array.count;
SEARCH_SEG:
		call lock_for_read (seg_ptr, begin_change_count);

		do node_ptrs.hash = 0 to seg.ht_size - 1;
		     if seg.offset_ht (node_ptrs.hash) ^= "0"b then do;

			node_ptrs.this = pointer (seg_ptr, seg.offset_ht (node_ptrs.hash));
			node_ptrs.last = null;

			do while (node_ptrs.this ^= null);

			     if node_ptrs.this -> old_node_format.banner = BANNER then do;  /* COMPATIBILITY */

				old_node_ptr = node_ptrs.this;

				node_ptrs.this = add_node (seg_ptr, node_ptrs.this -> old_node_format.name_len,
				     node_ptrs.this -> old_node_format.value_len, node_ptrs);

				call copy_old_format_node (old_node_ptr, node_ptrs.this);
			     end;

			     if node_ptrs.this -> node.data_sw = data_entrypoint_sw then

				call match_one (node_ptrs.this);

			     node_ptrs.last = node_ptrs.this;
			     node_offset = node_ptrs.this -> node.next_offset;
			     if node_offset = "0"b then node_ptrs.this = null;
			     else node_ptrs.this = pointer (seg_ptr, node_offset);
			end;
		     end;
		end;

		if seg.change_count ^= begin_change_count then do;  /* changed while listing */
		     alloc_chars_len = saved_chars_len;
		     sort_array.count = saved_sort_count;
		     go to SEARCH_SEG;	     	/* retry the seg */
		end;
	     end;

	if sort_array.count = 0 then do;
	     A_code = error_table_$nomatch;
	     go to LIST_RETURN;
	end;

/* Sort the found var names alphabetically */

	call sort_items_$varying_char (sort_array_ptr);

	alloc_pair_count = sort_array.count;

	allocate value_list_info in (area_ptr -> based_area) set (value_list_info_ptr);

	value_list_info.version = value_list_info_version_1;
	chars_index = 1;

	do i = 1 to value_list_info.pair_count;

	     sort_entry_ptr = addrel (sort_array.name_ptr (i), sort_field_offset);
					/* sort_array.name(i) is addr of sort_entry.sort_field */
	     node_ptr = sort_entry.node_ptr;

	     if node_ptr -> node.pp_sw then value_list_info.type_switches (i) = PERPROCESS_SW;
	     else value_list_info.type_switches (i) = PERMANENT_SW;
	     value_list_info.name_index (i) = chars_index;
	     value_list_info.name_len (i) = node_ptr -> node.name_len;
	     substr (value_list_info.chars, chars_index, value_list_info.name_len (i)) = node_ptr -> node.name;
	     chars_index = chars_index + value_list_info.name_len (i);

	     if data_entrypoint_sw then do;		/* return word length only for data entry */
		value_list_info.value_index (i) = 0;
		value_list_info.value_len (i) = divide (node_ptr -> node.value_len + 3, 4, 21, 0);
	     end;
	     else do;				/* return char value otherwise */
		value_list_info.value_index (i) = chars_index;
		value_list_info.value_len (i) = node_ptr -> node.value_len;
		substr (value_list_info.chars, chars_index, value_list_info.value_len (i)) = node_ptr -> node.value;
		chars_index = chars_index + value_list_info.value_len (i);
	     end;
	end;

	value_list_info.chars_len = chars_index - 1;

	A_value_list_info_ptr = value_list_info_ptr;
	A_code = 0;
LIST_RETURN:
	call release_temp_segment_ ("value_$list", sort_array_ptr, code);
	call release_temp_segment_ ("value_$list", sort_entries_ptr, code);

	return;



list_cleanup: proc;

	if sort_array_ptr ^= null then call release_temp_segment_ ("value_$list", sort_array_ptr, code);
	if sort_entries_ptr ^= null then call release_temp_segment_ ("value_$list", sort_entries_ptr, code);
	if value_list_info_ptr ^= null then free value_list_info in (area_ptr -> based_area);

end list_cleanup;
%page;
list_data_names: entry (A_seg_ptr, A_switches, A_match_info_ptr, A_area_ptr, A_value_list_info_ptr, A_code);

/* Same as value_$list, but works on data values (value_$set_data) and returns only names */

	data_entrypoint_sw = "1"b;
	go to LIST;
%page;
pop: entry options (variable);

/* call value_$pop (seg_ptr, switches, name, old_value, code); */

	pop_sw = "1"b;
	old_value_arg_index = 4;
	code_arg_index = 5;

	go to VALUE_SET;
%page;
push: entry options (variable);

/* call value_$push (seg_ptr, switches, name, new_value, old_value, code); */

	push_sw = "1"b;
	old_value_arg_index = 5;
	code_arg_index = 6;

	go to VALUE_SET;
%page;
set: entry options (variable);

/* call value_$set (seg_ptr, switches, name, new_value, old_value, code); */

	seg_code = 0;

	old_value_arg_index = 5;
	code_arg_index = 6;
VALUE_SET:
	options_var_sw = "1"b;
	arg_list_ptr = cu_$arg_list_ptr ();

	call get_options_var_args (arg_list_ptr);

	data_entrypoint_sw, test_entrypoint_sw = "0"b;

SET:	set_entrypoint_sw = "1"b;

	call get_ptrs (seg_ptr, pp_ptr);

/* Pick up value to be set, convert to allocated char string */

	alloc_info.ptr = null;
	alloc_info.area_ptr = get_system_free_area_ ();

	locked_sw = "0"b;

	on cleanup begin;
	     if alloc_info.ptr ^= null then
		free alloc_info.ptr -> alloc_string in (alloc_info.area_ptr -> based_area);
	     if locked_sw then call unlock_for_write (seg_ptr);
	end;

	if data_entrypoint_sw then do;		/* value_$set_data */

	     if A_new_data_ptr = null then do;		/* delete existing value */

		call lock_for_write (seg_ptr);
		locked_sw = "1"b;

		if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then

		     call delete_node (node_ptrs);

		call unlock_for_write (seg_ptr);

		call return_code (0);
	     end;

	     new_value_info.ptr = A_new_data_ptr;
	     new_value_info.len = A_new_data_size * 4;
	end;
	else if ^pop_sw then
	     call get_value_arg (arg_list_ptr, 4, new_value_info, alloc_info);  /* convert from caller's type */

	call lock_for_write (seg_ptr);
	locked_sw = "1"b;

	if find (pp_ptr, seg_ptr, name_info, value_info, node_ptrs) then do;

	     if test_entrypoint_sw then do;		/* compare old value to argument */

		if value_info.len < old_value_info.len then
TEST_FAIL:	     call return_code (error_table_$action_not_performed);
		if old_value_info.len ^= 0 then
		     if substr (value_string, 1, old_value_info.len) ^=
			substr (old_value_string, 1, old_value_info.len) then go to TEST_FAIL;
	     end;

	     else call set_value_arg (arg_list_ptr, old_value_arg_index, value_info);  /* return old value */

	     if pop_sw then do;			/* delete current node only */

		call delete_node (node_ptrs);

		go to SET_RETURN;
	     end;

	     where_ptr = node_ptrs.segp;

	     if push_sw then go to ADD_NODE;		/* add before current node */

	     if where_ptr ^= null then do;		/* optimization: reuse old node if possible */
		local_pp_sw = (where_ptr -> seg.banner = PP_BANNER);
		if node_ptrs.this -> node.value_len = new_value_info.len &  /* reuse old node if same length and */
		     node_ptrs.this -> node.pp_sw = local_pp_sw &	 /* same class (perprocess vs value seg) and */
		     node_ptrs.this -> node.data_sw = data_entrypoint_sw then do;  /* same type (data vs char) */
			node_ptrs.this -> node.value = new_value_string;
			go to SET_RETURN;
		end;
	     end;
	end;

	else do;					/* no old value */

	     if pop_sw then call return_code (error_table_$oldnamerr);  /* no previous value */

	     if test_entrypoint_sw then go to TEST_FAIL;	/* test fails if no old value */

/* No old value: first choice is to set in value segment */

	     if seg_ptr ^= null then where_ptr = seg_ptr;
	     else if seg_sw_arg then call return_code (seg_code);  /* return code from get_ptrs */
	     else where_ptr = pp_ptr;

	     node_ptrs.this = null;			/* to be sure no old node for add_node */

	     value_info.ptr = where_ptr;
	     value_info.len = 0;

	     call set_value_arg (arg_list_ptr, old_value_arg_index, value_info);  /* return zero-length string */
	end;
ADD_NODE:
	new_node_ptr = add_node (where_ptr, name_info.len, new_value_info.len, node_ptrs);

	new_node_ptr -> node.name = name_string;
	new_node_ptr -> node.value = new_value_string;

SET_RETURN:
	if alloc_info.ptr ^= null then
	     free alloc_info.ptr -> alloc_string in (alloc_info.area_ptr -> based_area);

	if seg_ptr ^= null () then			/* check if we should GC a permanent value segment */
	     if (4 * seg.trash_count > fixed (seg.next_free_offset, 18, 0)) | (seg.trash_count > MAX_TRASH_COUNT) then
		call compact_trash (seg_ptr);

	call unlock_for_write (seg_ptr);		/* IMPROVE LOCKING STRATEGY (pp?) */

	call return_code (0);
%page;
set_data: entry (A_seg_ptr, A_switches, A_name, A_new_data_ptr, A_new_data_size,
		A_area_ptr, A_data_ptr, A_data_size, A_code);

	options_var_sw = "0"b;

	call copy_args;

	alloc_info.ptr = null;


	data_entrypoint_sw = "1"b;
	test_entrypoint_sw = "0"b;

	go to SET;
%page;
set_path: entry (A_path, A_create_sw, A_code);

	options_var_sw = "0"b;

	if A_path = "" then do;
	     call get_default_path (dn, en);
	     if dn = ">" then path = ">" || en;
	     else path = rtrim (dn) || ">" || en;
	end;
	else path = A_path;

	call hcs_$initiate (add_suffix (path), "", "", 0, 0, seg_ptr, code);
	if code = error_table_$noentry & A_create_sw then do;
	     call expand_pathname_ (add_suffix (path), dn, en, code);
	     if code ^= 0 then call return_code (code);
	     call hcs_$make_seg (dn, en, "", 01010b /* rw */, seg_ptr, code);
	     if seg_ptr = null then call return_code (code);

	     call init_seg (seg_ptr);

	     seg_ptr -> seg.banner = BANNER;
	     unspec (seg_ptr -> seg.offset_ht) = "0"b;
	end;

	if seg_ptr = null then call return_code (code);

	on cleanup call hcs_$terminate_noname (seg_ptr, code);

	call hcs_$fs_get_mode (seg_ptr, seg_mode, code);
	if code ^= 0 then call return_code (code);	/* no r: don't set */
	if ^addr (seg_mode) -> R_BIT then call return_code (error_table_$no_r_permission);
	if ^addr (seg_mode) -> W_BIT then code = error_table_$no_w_permission;  /* no w: set anyway but return code */

	call set_seg (seg_ptr);

	call return_code (code);
%page;
test_and_set: entry options (variable);

/* call value_$test_and_set (seg_ptr, switches, name, new_value, old_value, code); */

	options_var_sw = "1"b;
	code_arg_index = 6;
	arg_list_ptr = cu_$arg_list_ptr ();

	call get_options_var_args (arg_list_ptr);

	alloc_info.ptr = null;
	alloc_info.area_ptr = get_system_free_area_ ();

	call get_value_arg (arg_list_ptr, 5, old_value_info, alloc_info);

	test_entrypoint_sw = "1"b;
	data_entrypoint_sw = "0"b;

	go to SET;
%page;
test_and_set_data: entry (A_seg_ptr, A_switches, A_name, A_new_data_ptr, A_new_data_size,
			A_old_data_ptr, A_old_data_size, A_code);

	options_var_sw = "0"b;

	call copy_args;

	old_value_info.ptr = A_old_data_ptr;
	old_value_info.len = A_old_data_size * 4;
	alloc_info.ptr = null;

	data_entrypoint_sw, test_entrypoint_sw = "1"b;

	go to SET;
%page;
add_node: proc (P_ptr, P_name_len, P_value_len, P_node_ptrs) returns (ptr);

/* Adds a new node in place of P_node_ptrs.this -> node if any, returns ptr to new node */

dcl P_ptr ptr;					/* INPUT: ptr to segment (seg or pp) */
dcl (P_name_len, P_value_len) fixed bin (21);		/* INPUT: lengths for allocation */
dcl 1 P_node_ptrs aligned like node_ptrs;		/* INPUT: old and previous old nodes for threading */

dcl (area_ptr, new_node_ptr) ptr;
dcl new_node_offset bit (18);
dcl next_free_word fixed bin (18);

	if P_ptr -> seg.banner = PP_BANNER then do;	/* perprocess-type header */

	     area_ptr = P_ptr -> pp.remote_area_ptr;
	     node_name_len = P_name_len;
	     node_value_len = P_value_len;

	     on area call return_code (error_table_$noalloc);

	     allocate node in (area_ptr -> based_area) set (new_node_ptr);

	     new_node_ptr -> node.version = value_version_1;
	     new_node_ptr -> node.banner = BANNER;	/* for the hell of it, like in seg */
	     unspec (new_node_ptr -> node.switches) = "0"b;
	     new_node_ptr -> node.pp_sw = "1"b;
	     if data_entrypoint_sw then new_node_ptr -> node.data_sw = "1"b;

	     if P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = P_node_ptrs.this then
		P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = null;

	     if P_node_ptrs.this ^= null then		/* old node exists */
		if push_sw then do;			/* inserting a new node before current one */
		     new_node_ptr -> node.push_sw = "1"b;
		     new_node_ptr -> node.next_ptr = P_node_ptrs.this;
		end;
		else new_node_ptr -> node.next_ptr = P_node_ptrs.this -> node.next_ptr;  /* else use its fwd thread */

	     else new_node_ptr -> node.next_ptr = null;	/* else end of chain */

	     if P_node_ptrs.last ^= null then		/* previous node in chain exists */
		P_node_ptrs.last -> node.next_ptr = new_node_ptr;
	     else P_ptr -> pp.ptr_ht (P_node_ptrs.hash) = new_node_ptr;  /* else thread off hash table */

	     if P_node_ptrs.this ^= null then
		if push_sw then do;
		     new_node_ptr -> node.push_sw = "1"b;
		     new_node_ptr -> node.next_ptr = P_node_ptrs.this;
		end;
		else free P_node_ptrs.this -> node in (area_ptr -> based_area);  /* else free old node */
	end;

	else do;					/* shareable seg */

	     new_node_offset = P_ptr -> seg.next_free_offset;  /* use next block of node_region */
	     new_node_ptr = pointer (P_ptr, new_node_offset);
	     new_node_ptr -> node.version = value_version_1;
	     new_node_ptr -> node.banner = BANNER;	/* so it's findable by salvage */
	     unspec (new_node_ptr -> node.switches) = "0"b;
	     if data_entrypoint_sw then new_node_ptr -> node.data_sw = "1"b;
	     new_node_ptr -> node.name_len = P_name_len;
	     new_node_ptr -> node.value_len = P_value_len;

	     next_free_word = fixed (new_node_offset) + currentsize (new_node_ptr -> node);
	     if next_free_word >= sys_info$max_seg_size then  /* past end of segment */
		call return_code (error_table_$boundviol);
	     P_ptr -> seg.next_free_offset = bit (next_free_word, 18);  /* skip enough room for node */

	     if P_node_ptrs.this ^= null then		/* old node exists */
		if push_sw then do;			/* inserting a node before current node */
		     new_node_ptr -> node.push_sw = "1"b;
		     new_node_ptr -> node.next_offset = rel (P_node_ptrs.this);
		end;
		else do;				/* replacing current node */
		     if P_node_ptrs.this -> old_node_format.banner = BANNER then do;
			new_node_ptr -> node.next_offset = P_node_ptrs.this -> old_node_format.next_offset;
			P_ptr -> seg.trash_count = P_ptr -> seg.trash_count +
			     currentsize (P_node_ptrs.this -> old_node_format);
		     end;
		     else do;
			new_node_ptr -> node.next_offset = P_node_ptrs.this -> node.next_offset;  /* use its fwd thread */
			P_ptr -> seg.trash_count = P_ptr -> seg.trash_count +  /* increment # of freed words */
			     currentsize (P_node_ptrs.this -> node);  /* for later compacting of segment */
		     end;
		end;

	     else new_node_ptr -> node.next_offset = "0"b;  /* else end of chain */

	     if P_node_ptrs.last ^= null then		/* previous node in chain exists */
		P_node_ptrs.last -> node.next_offset = new_node_offset;
	     else P_ptr -> seg.offset_ht (P_node_ptrs.hash) = new_node_offset;  /* else thread off hash table */
	end;

	return (new_node_ptr);

end add_node;
%page;
add_suffix: proc (P_en) returns (char (*));

/* Appends .value suffix to an entryname if not already there */

dcl P_en char (*);					/* INPUT: entryname */

dcl entry_len fixed bin;

	entry_len = length (rtrim (P_en));

	if entry_len < SUFFIX_LEN + 1 then return (rtrim (P_en) || SUFFIX);
	else if substr (P_en, entry_len - SUFFIX_LEN + 1, SUFFIX_LEN) ^= SUFFIX then
	     return (rtrim (P_en) || SUFFIX);
	else return (P_en);

end add_suffix;
%page;
compact_trash: proc (P_ptr);

dcl P_ptr ptr;
dcl (last_node_ptr, old_node_ptr, temp_node_ptr, temp_ptr) ptr;
dcl (next_node_offset, next_word_offset) bit (18);
dcl next_free_word fixed (18) unaligned unsigned;
dcl (i, saved_region_size) fixed;

	if P_ptr -> seg.banner ^= BANNER then return;	/* not shareable value seg */

	call get_temp_segment_ ("value_", temp_ptr, code);
	if code ^= 0 then return;
	call hcs_$truncate_seg (temp_ptr, 0, code);
	if code ^= 0 then return;

	on cleanup call release_temp_segment_ ("value_", temp_ptr, (0));

	P_ptr -> seg.salvaging_sw = "1"b;

	temp_ptr -> seg.header = P_ptr -> seg.header;
	temp_ptr -> seg.trash_count = 0;
	temp_ptr -> seg.next_free_offset = rel (addr (P_ptr -> seg.node_region));
	next_word_offset = temp_ptr -> seg.next_free_offset;

	do i = 0 to temp_ptr -> seg.ht_size - 1;	/* for each hash table bucket */
	     if temp_ptr -> seg.offset_ht (i) ^= "0"b then do;  /* some nodes for this bucket */

		temp_ptr -> seg.offset_ht (i) = next_word_offset;

		temp_node_ptr = pointer (temp_ptr, next_word_offset);
		last_node_ptr = null;

		next_node_offset = "1"b;		/* dummy ^= 0 for first time through loop */

		do old_node_ptr = pointer (P_ptr, P_ptr -> seg.offset_ht (i))
		  repeat (pointer (P_ptr, next_node_offset))
		  while (next_node_offset ^= "0"b);

		     if old_node_ptr -> old_node_format.banner = BANNER then

			call copy_old_format_node (old_node_ptr, temp_node_ptr);

		     else do;
			temp_node_ptr -> node.name_len = old_node_ptr -> node.name_len;
			temp_node_ptr -> node.value_len = old_node_ptr -> node.value_len;
			temp_node_ptr -> node = old_node_ptr -> node;
		     end;

		     if last_node_ptr ^= null then last_node_ptr -> node.next_offset = next_word_offset;

		     next_free_word = fixed (next_word_offset) + currentsize (temp_node_ptr -> node);
		     next_word_offset = bit (next_free_word, 18);
		     last_node_ptr = temp_node_ptr;
		     temp_node_ptr = pointer (temp_ptr, next_word_offset);

		     next_node_offset = old_node_ptr -> node.next_offset;
		end;

		last_node_ptr -> node.next_offset = "0"b;  /* last node in chain */
	     end;
	end;

	temp_ptr -> seg.next_free_offset = next_word_offset;

/* Copy back to the original */

	saved_region_size = temp_ptr -> seg.region_size;
	temp_ptr -> seg.region_size, P_ptr -> seg.region_size = fixed (next_word_offset);
	P_ptr -> seg = temp_ptr -> seg;
	P_ptr -> seg.region_size = saved_region_size;

	P_ptr -> seg.salvaging_sw = "0"b;

	call hcs_$truncate_seg (P_ptr, fixed (next_word_offset, 19), 0);

	call release_temp_segment_ ("value_", temp_ptr, (0));


end compact_trash;
%page;
copy_args: proc;

/* Copies input args for non - options(var) entrypoints */

	A_code = 0;

	seg_ptr = A_seg_ptr;
	switches = A_switches;
	name_info.ptr = addr (A_name);
	name_info.len = length (rtrim (A_name));

	if name_info.len = 0 then call signal_error;

end copy_args;
%page;
copy_old_format_node: proc (P_old_ptr, P_new_ptr);

/* Converts an old pre-version node to the current version */

dcl (P_old_ptr, P_new_ptr) ptr;

	P_new_ptr -> node.version = value_version_1;
	P_new_ptr -> node.banner = P_old_ptr -> old_node_format.banner;
	P_new_ptr -> node.next_offset = P_old_ptr -> old_node_format.next_offset;
	P_new_ptr -> node.next_ptr = P_old_ptr -> old_node_format.next_ptr;
	unspec (P_new_ptr -> node.switches) = "0"b;
	P_new_ptr -> node.name_len = P_old_ptr -> old_node_format.name_len;
	P_new_ptr -> node.value_len = P_old_ptr -> old_node_format.value_len;
	P_new_ptr -> node.name = P_old_ptr -> old_node_format.name;
	P_new_ptr -> node.value = P_old_ptr -> old_node_format.value;

end copy_old_format_node;
%page;
delete_node: proc (P_node_ptrs);

/* Deletes (unthreads and frees/marks free) the node pointed to by P_node_ptrs.this */

dcl 1 P_node_ptrs aligned like node_ptrs;

dcl pp_sw bit (1);
dcl area_ptr ptr;

	pp_sw = (P_node_ptrs.segp -> seg.banner = PP_BANNER);

	if pp_sw then do;				/* perprocess: ptrs */

	     if P_node_ptrs.last ^= null then		/* previous node in chain exists */
		P_node_ptrs.last -> node.next_ptr = P_node_ptrs.this -> node.next_ptr;
	     else P_node_ptrs.segp -> pp.ptr_ht (P_node_ptrs.hash) = P_node_ptrs.this -> node.next_ptr;

	     area_ptr = P_node_ptrs.segp -> pp.remote_area_ptr;
	     free P_node_ptrs.this -> node in (area_ptr -> based_area);
	end;

	else do;					/* permanent: offsets */

	     if P_node_ptrs.last ^= null then		/* previous node in chain exists */
		P_node_ptrs.last -> node.next_offset = P_node_ptrs.this -> node.next_offset;
	     else P_node_ptrs.segp -> seg.offset_ht (P_node_ptrs.hash) = P_node_ptrs.this -> node.next_offset;

	     P_node_ptrs.segp -> seg.trash_count = P_node_ptrs.segp -> seg.trash_count +
		currentsize (P_node_ptrs.this -> node);	/* for later compaction of seg */

	     if (4 * P_node_ptrs.segp -> seg.trash_count > fixed (P_node_ptrs.segp -> seg.next_free_offset, 18, 0)) |
	        (P_node_ptrs.segp -> seg.trash_count > MAX_TRASH_COUNT) then
		call compact_trash (P_node_ptrs.segp);
	end;

end delete_node;
%page;
find: proc (P_pp_ptr, P_seg_ptr, P_name_info, P_value_info, P_node_ptrs) returns (bit (1));

/* Looks first in perprocess if appropriate, then in value segment. Returns "1"b if found */

dcl (P_pp_ptr, P_seg_ptr) ptr;			/* INPUT: header pointers */
dcl 1 P_name_info aligned like name_info;		/* INPUT: variable name */
dcl 1 P_value_info aligned like value_info;		/* OUTPUT: value string */
dcl 1 P_node_ptrs aligned like node_ptrs;		/* OUTPUT: ptrs to current (found) and previous nodes */

	if P_pp_ptr ^= null then do;			/* looking in perprocess */

	     if find_in (P_pp_ptr, P_name_info, P_value_info, P_node_ptrs) then return ("1"b);
	end;

	if P_seg_ptr ^= null then do;

	     if find_in (P_seg_ptr, P_name_info, P_value_info, P_node_ptrs) then return ("1"b);
	end;

	return ("0"b);

end find;
%page;
find_in: proc (P_ptr, P_name_info, P_value_info, P_node_ptrs) returns (bit (1));

/* Looks for the name in a specified segment; returns true if FOUND */

dcl P_ptr ptr;					/* INPUT: segment to look in */
dcl 1 P_name_info aligned like name_info;		/* INPUT: variable name */
dcl 1 P_value_info aligned like value_info;		/* OUTPUT: value string */
dcl 1 P_node_ptrs aligned like node_ptrs;		/* OUTPUT: ptrs to current (found) and previous nodes */

dcl name_str char (P_name_info.len) based (P_name_info.ptr);
dcl hash_str char (8);
dcl next_node_offset bit (18);
dcl pp_sw bit (1);
dcl (begin_change_count, hash_index, i) fixed bin;
dcl (first_node_ptr, old_node_ptr) ptr;

	pp_sw = (P_ptr -> seg.banner = PP_BANNER);

FIND:	if ^pp_sw then call lock_for_read (P_ptr, begin_change_count);

	i = length (rtrim (name_str, WHITE));
	if i > 8 then hash_str = substr (name_str, i - 7, 8);
	else hash_str = name_str;

	hash_index = mod (fixed (unspec (rtrim (hash_str, WHITE))), P_ptr -> seg.ht_size);

	P_node_ptrs.this, P_node_ptrs.last = null;	/* initialize to not found */
	P_node_ptrs.segp = P_ptr;
	P_node_ptrs.hash = hash_index;

	if pp_sw then do;
	     first_node_ptr = P_ptr -> pp.ptr_ht (hash_index);
	     if baseno (first_node_ptr) = "0"b | first_node_ptr = null then return ("0"b);
	end;
	else if P_ptr -> seg.offset_ht (hash_index) = "0"b then return ("0"b);

	if pp_sw then P_node_ptrs.this = P_ptr -> pp.ptr_ht (hash_index);
	else P_node_ptrs.this = pointer (P_ptr, P_ptr -> seg.offset_ht (hash_index));

	do while (P_node_ptrs.this ^= null);		/* search the list */

		if P_node_ptrs.this -> old_node_format.banner = BANNER then do;  /* COMPATIBILITY */

		     old_node_ptr = P_node_ptrs.this;

		     P_node_ptrs.this = add_node (P_ptr, P_node_ptrs.this -> old_node_format.name_len,
			P_node_ptrs.this -> old_node_format.value_len, P_node_ptrs);

		     call copy_old_format_node (old_node_ptr, P_node_ptrs.this);
		end;

		if P_node_ptrs.this -> node.name = name_str &
		  P_node_ptrs.this -> node.data_sw = data_entrypoint_sw then do;  /* FOUND */

		     P_value_info.ptr = addrel (addr (P_node_ptrs.this -> node.value), 1);  /* var string's text */
		     P_value_info.len = P_node_ptrs.this -> node.value_len;

		     if ^pp_sw then do;		/* if a shared segment */
						/* make sure another process has not changed seg meanwhile */
			if P_ptr -> seg.change_count ^= begin_change_count then go to FIND; /* retry */

			P_value_info.change_count = begin_change_count;  /* for later unlocking */
			P_value_info.seg_ptr = P_ptr;
		     end;
		     else P_value_info.seg_ptr = null;

		     return ("1"b);
		end;

		P_node_ptrs.last = P_node_ptrs.this;

		if pp_sw then P_node_ptrs.this = P_node_ptrs.this -> node.next_ptr;
		else do;
		     next_node_offset = P_node_ptrs.this -> node.next_offset;
		     if next_node_offset = "0"b then P_node_ptrs.this = null;
		     else P_node_ptrs.this = pointer (P_ptr, next_node_offset);
		end;
	end;

	return ("0"b);

end find_in;
%page;
get_default_path: proc (A_dn, A_en);

dcl (A_dn, A_en) char (*);
dcl person_id char (22);

	call user_info_$homedir (A_dn);

	call user_info_ (person_id);
	A_en = rtrim (person_id) || ".value";

end get_default_path;
%page;
get_default_ptr: proc () returns (ptr);

/* Returns a pointer to the current default value seg */

dcl dn char (168);
dcl en char (32);

	if default_seg_ptr = null then do;

INITIATE:	     call get_default_path (dn, en);

	     call hcs_$initiate (dn, en, "", 0, 0, default_seg_ptr, code);
	end;

	else do;

	     on any_other go to INITIATE;

	     if default_seg_ptr -> seg.banner ^= BANNER & default_seg_ptr -> seg.banner ^= PP_BANNER then
		go to INITIATE;

	     revert any_other;
	end;

	return (default_seg_ptr);

end get_default_ptr;
%page;
get_options_var_args: proc (P_arg_list_ptr);

/* Reads the argument list and returns the values of selected arguments */

dcl P_arg_list_ptr ptr;				/* INPUT: ptr to argument list */

dcl arg char (arg_len) based (arg_ptr);
dcl based_bit36 bit (36) based;
dcl based_packed_ptr ptr unaligned based;
dcl based_ptr ptr aligned based;
dcl based_varying_string char (261120 /* max chars in a segment */) varying based;

dcl (packed_sw, varying_sw) bit (1) aligned;
dcl arg_ptr ptr;
dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin;

/* Argument 1 */
	call decode_descriptor_ (P_arg_list_ptr, 1, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if arg_type ^= PTR_TYPE | ndims > 1 then
	     call signal_error;

	call cu_$arg_ptr_rel (1, arg_ptr, arg_len, code, P_arg_list_ptr);
	if packed_sw then seg_ptr = arg_ptr -> based_packed_ptr;
	else seg_ptr = arg_ptr -> based_ptr;

/* Argument 2 */
	call decode_descriptor_ (P_arg_list_ptr, 2, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if arg_type ^= BIT_TYPE | ndims > 1 then
	     call signal_error;

	call cu_$arg_ptr_rel (2, arg_ptr, arg_len, code, P_arg_list_ptr);
	unspec (switches) = "0"b;
	substr (switches, 1, arg_size) = substr (arg_ptr -> based_bit36, 1, arg_size);

/* Argument 3 */
	call decode_descriptor_ (P_arg_list_ptr, 3, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if ndims > 1 then call signal_error;
	else if arg_type = VARYING_CHAR_TYPE then varying_sw = "1"b;
	else do;
	     if arg_type ^= CHAR_TYPE then call signal_error;
	     varying_sw = "0"b;
	end;

	call cu_$arg_ptr_rel (3, arg_ptr, arg_len, code, P_arg_list_ptr);
	if varying_sw then do;
	     name_info.ptr = arg_ptr;
	     name_info.len = length (addrel (arg_ptr, -1) -> based_varying_string);
	end;
	else do;
	     name_info.ptr = arg_ptr;
	     name_info.len = length (rtrim (arg));
	end;

end get_options_var_args;
%page;
get_ptrs: proc (P_seg_ptr, P_pp_ptr);

/* Depending on the value of switches:
	gets ptr to the perprocess value segment or returns null.
	validates seg_ptr or sets it to null (pointer to the value seg) */

dcl P_seg_ptr ptr;					/* INPUT/OUTPUT: ptr to value segment */
dcl P_pp_ptr ptr;					/* OUTPUT: ptr to perprocess value segment */

dcl (pp_sw, seg_sw) bit (1);

	if ^pp_sw_arg & ^seg_sw_arg then call return_code (error_table_$badcall);
	else do;					/* explicitly specified which to use */
	     pp_sw = pp_sw_arg;
	     seg_sw = seg_sw_arg;
	end;

	if pp_sw then do;				/* using perprocess */
	     if perprocess_seg_ptr = null then do;	/* first time for process */
		call get_temp_segment_ ("value_", perprocess_seg_ptr, code);
		if code ^= 0 then call return_code (code);

		perprocess_seg_ptr -> pp.version = value_version_1;
		perprocess_seg_ptr -> pp.banner = PP_BANNER;
		perprocess_seg_ptr -> pp.ht_size = HT_SIZE;
		do i = 0 to HT_SIZE-1;
		     perprocess_seg_ptr -> ptr_ht (i) = null;
		end;

		perprocess_seg_ptr -> pp.remote_area_ptr = get_system_free_area_ ();
	     end;
	     P_pp_ptr = perprocess_seg_ptr;
	end;
	else P_pp_ptr = null;

	if seg_sw then do;				/* using value segment */
	     if P_seg_ptr = null then do;		/* default value seg */
		P_seg_ptr = get_default_ptr ();
		if P_seg_ptr = null then do;		/* no default value seg */
		     seg_code = code;
		     if pp_sw then return;	/* otherwise OK unless asking for permanent only */
		     else call return_code (code);
		end;
	     end;

	     if P_seg_ptr -> seg.banner ^= BANNER & P_seg_ptr -> seg.banner ^= PP_BANNER then
		call return_code (error_table_$not_seg_type);
	end;
	else P_seg_ptr = null;

end get_ptrs;
%page;
get_value_arg: proc (P_arg_list_ptr, P_arg_index, P_value_info, P_alloc_info);

/* Converts caller's input value argument to ptr and length of allocated char string copy */

dcl P_arg_list_ptr ptr;				/* INPUT: ptr to argument list */
dcl P_arg_index fixed bin;				/* INPUT: which arg to get */
dcl 1 P_value_info aligned like value_info;		/* OUTPUT: structure containing ptr and length */
dcl 1 P_alloc_info aligned like alloc_info;		/* OUTPUT: where char string has been allocated */

dcl alloc_string char (P_alloc_info.len) based (P_alloc_info.ptr);

dcl based_varying_string char (261120 /* max chars in a segment */) varying based;

dcl packed_sw bit (1) aligned;
dcl arg_ptr ptr;
dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin;

	call decode_descriptor_ (P_arg_list_ptr, P_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if ndims > 1 then call signal_error;

	call cu_$arg_ptr_rel (P_arg_index, arg_ptr, arg_len, code, P_arg_list_ptr);

/* Compute length for allocating a char string copy */

	if arg_type = CHAR_TYPE then P_alloc_info.len = arg_len;
	else if arg_type = VARYING_CHAR_TYPE then do;
	     arg_ptr = addrel (arg_ptr, -1);
	     P_alloc_info.len = length (arg_ptr -> based_varying_string);
	end;
	else P_alloc_info.len = 64;			/* arbitrary: 16 words ought to be enough */

	allocate alloc_string in (alloc_info.area_ptr -> based_area) set (P_alloc_info.ptr);

	on conversion call return_code (error_table_$bad_conversion);

	call assign_ (P_alloc_info.ptr, CHAR_TYPE * 2, P_alloc_info.len,  /* to target string */
	     arg_ptr, arg_type * 2 + fixed (packed_sw, 1), (arg_size));  /* from caller's arg */

	P_value_info.ptr = P_alloc_info.ptr;
	P_value_info.len = length (alloc_string);

end get_value_arg;
%page;
init_seg: proc (P_ptr);

/* Initializes the segment pointed to by P_ptr as a value segment */

dcl P_ptr ptr;					/* INPUT: ptr to value segment */

	on not_in_write_bracket call return_code (error_table_$lower_ring);
	on no_write_permission call return_code (error_table_$no_w_permission);

	P_ptr -> seg.version = value_version_1;
	P_ptr -> seg.ht_size = HT_SIZE;
	P_ptr -> seg.remote_area_ptr = null;

	P_ptr -> seg.next_free_offset = rel (addr (P_ptr -> seg.node_region));
	P_ptr -> seg.region_size =
	     sys_info$max_seg_size - fixed (P_ptr -> seg.next_free_offset);  /* rest of segment */

end init_seg;
%page;
list_pp: proc (P_ptr);

/* Does value_$list stuff for a nonshareable value seg, perprocess or otherwise (using ptrs rather than offsets) */

dcl P_ptr ptr;

	do node_ptrs.hash = 0 to P_ptr -> pp.ht_size - 1;

	     do node_ptrs.this = P_ptr -> pp.ptr_ht (node_ptrs.hash)
		repeat (node_ptrs.this -> node.next_ptr) while (node_ptrs.this ^= null);

		     if node_ptrs.this -> node.data_sw = data_entrypoint_sw then

			call match_one (node_ptrs.this);
	     end;
	end;

end list_pp;
%page;
lock_for_read: proc (P_ptr, P_change_count);

/* Locks a copy of the value seg's lock word, then returns seg.change_count */

dcl P_ptr ptr;					/* INPUT: ptr to value seg */
dcl P_change_count fixed bin;				/* OUTPUT: seg.change_count at lock time */

dcl i fixed bin;

	if P_ptr -> seg.salvaging_sw then do;		/* seg in use */

	     do i = 1 to 10;			/* try 10 times to catch seg unlocked */

		P_change_count = P_ptr -> seg.change_count;

		call set_lock_$lock ((P_ptr -> seg.lock), 0, code);	/* see if seg is locked (look at copy) */
		if code = 0
		     | code = error_table_$invalid_lock_reset
		     | code = error_table_$locked_by_this_process then return;
	     end;

	     call return_code (code);			/* give up */
	end;

	else P_change_count = P_ptr -> seg.change_count;	/* no need to lock except for salvage */

end lock_for_read;
%page;
lock_for_write: proc (P_ptr);

/* Locks the value seg's lock word and increments seg.change_count */

dcl P_ptr ptr;					/* INPUT: ptr to value seg */

	if P_ptr = null then return;
	if P_ptr -> seg.banner = PP_BANNER then return;

	on not_in_write_bracket call return_code (error_table_$lower_ring);
	on no_write_permission call return_code (error_table_$no_w_permission);

	call set_lock_$lock (P_ptr -> seg.lock, 1, code);
	if code ^= 0
	     & code ^= error_table_$invalid_lock_reset
	     & code ^= error_table_$locked_by_this_process then
		call return_code (code);

	if P_ptr -> seg.change_count > 10000 then P_ptr -> seg.change_count = 1;
	else P_ptr -> seg.change_count = P_ptr -> seg.change_count + 1;

end lock_for_write;
%page;
match_one: proc (P_ptr);

/* Adds P_ptr->node.name to the sort array if it matches what's in match_info.
   Global vars used: alloc_chars_len, data_entrypoint_sw, match_info_ptr, sort_entry_ptr,
	sequential_number, sort_array_ptr */

dcl P_ptr ptr;
dcl based_fb35 fixed bin (35) aligned based;
dcl (excluded_sw, matched_sw) bit (1);
dcl i fixed;
dcl code fixed (35);

	excluded_sw, matched_sw = "0"b;

	do i = 1 to match_info.name_count;

	     if match_info.name (i) = P_ptr -> node.name then go to MATCH;

	     else if match_info.regexp_sw (i) then
		call search_file_ (addrel (addr (match_info.name (i)), 1), 1, length (match_info.name (i)),
		     addrel (addr (P_ptr -> node.name), 1), 1, P_ptr -> node.name_len,
		     0, 0, code);

	     else call match_star_name_ ((P_ptr -> node.name), (match_info.name (i)), code);

	     if code = 0 then do;
MATCH:		if match_info.exclude_sw (i) then excluded_sw = "1"b;
		else matched_sw = "1"b;
	     end;
	end;

	if excluded_sw | ^matched_sw then return;

/* Append a sort_entry structure to the sort_entries temp seg, describing this node */

	node_ptr = P_ptr;				/* for sort_entry.name's length */
	sort_entry.node_ptr = P_ptr;
	sort_entry.name = P_ptr -> node.name;
	sort_entry.length = P_ptr -> node.name_len + length (sort_entry.sequence);
						/* include sequential number to be included */

/* Append a sequential number in char string form to the name, so that the order
   of multiple (pushed) values with the same name will be preserved by the sort */

	sequential_number = sequential_number + 1;
	sort_entry.sequence = sequential_number;	/* picture assignment, converted to char */

/* Add this entry to the sort_array passed to sort_items_$varying_char */

	sort_array.count = sort_array.count + 1;
	sort_array.name_ptr (sort_array.count) = addr (sort_entry.sort_field);

/* Bump sort_entry_ptr for the next entry, past end of this entry */

	sort_entry_ptr = addr (sort_entry.next_entry);

/* Reserve room for the output name */

	alloc_chars_len = alloc_chars_len + P_ptr -> node.name_len;
	if ^data_entrypoint_sw then alloc_chars_len = alloc_chars_len + P_ptr -> node.value_len;

end match_one;
%page;
return_code: proc (P_code);

/* Sets the value of the code argument and returns from the outer procedure */
/* options_var_sw and code_arg_index are global variables set by the entry points */

dcl P_code fixed bin (35);				/* INPUT: status code value */

dcl based_fb35 fixed bin (35) based;
dcl packed_sw bit (1) aligned;
dcl arg_ptr ptr;
dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin;

	if ^options_var_sw then do;
	     A_code = P_code;
	     go to RETURN;
	end;

	call decode_descriptor_ (arg_list_ptr, code_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if arg_type = FIXED_BIN_TYPE then do;
	     call cu_$arg_ptr_rel (code_arg_index, arg_ptr, arg_len, 0, arg_list_ptr);
	     arg_ptr -> based_fb35 = P_code;
	end;

	go to RETURN;

end return_code;
%page;
set_seg: proc (P_ptr);

/* Sets the default value seg to P_ptr, or to [hd]>[user name].value if P_ptr = null */

dcl P_ptr ptr;					/* INPUT: ptr to value seg */

	if P_ptr = null then do;
	     default_seg_ptr = null;
	     P_ptr = get_default_ptr ();
	end;
	else do;
	     if P_ptr -> seg.banner ^= BANNER then call return_code (error_table_$not_seg_type);
	     default_seg_ptr = P_ptr;
	end;

end set_seg;
%page;
set_value_arg: proc (P_arg_list_ptr, P_arg_index, P_value_info);

/* Converts ptr and length of string to value_arg argument */

dcl P_arg_list_ptr ptr;				/* INPUT: ptr to argument list */
dcl P_arg_index fixed bin;				/* INPUT: which arg to set */
dcl 1 P_value_info aligned like value_info;		/* INPUT: structure containing ptr and length */

dcl value_string char (P_value_info.len) based (P_value_info.ptr);
dcl alloc_value char (A_value_len) based (A_value_ptr);
dcl alloc_data (A_data_size) fixed bin aligned based (A_data_ptr);  /* for allocation */

dcl packed_sw bit (1) aligned;
dcl arg_ptr ptr;
dcl (arg_len, arg_scale, arg_size, arg_type, ndims) fixed bin;
dcl bit_size fixed bin (24);

	if alloc_entrypoint_sw then do;		/* value_$get_alloc */
	     A_value_len = P_value_info.len;
	     if A_area_ptr ^= null then do;		/* wants it returned */

		on area call return_code (error_table_$noalloc);

		allocate alloc_value in (A_area_ptr -> based_area) set (A_value_ptr);

		substr (alloc_value, 1, A_value_len) = substr (value_string, 1, A_value_len);
	     end;

	     return;
	end;

	if data_entrypoint_sw then do;		/* value_$get_data, value_$set_data */
	     A_data_size = divide (P_value_info.len + 3, 4, 17, 0);
	     if A_area_ptr ^= null then do;		/* wants it returned */

		on area call return_code (error_table_$noalloc);

		allocate alloc_data in (A_area_ptr -> based_area) set (A_data_ptr);

		bit_size = A_data_size * 36;
		substr (A_data_ptr -> bits, 1, bit_size) = substr (P_value_info.ptr -> bits, 1, bit_size);
	     end;

	     return;
	end;

	call decode_descriptor_ (P_arg_list_ptr, P_arg_index, arg_type, packed_sw, ndims, arg_size, arg_scale);
	if ndims > 1 then call signal_error;

	if arg_type = VARYING_CHAR_TYPE & arg_size = 0 then return;  /* caller testing whether defined */

	call cu_$arg_ptr_rel (P_arg_index, arg_ptr, arg_len, code, P_arg_list_ptr);

	if arg_type = VARYING_CHAR_TYPE then arg_ptr = addrel (arg_ptr, -1);  /* point to length word */

	on conversion call return_code (error_table_$bad_conversion);

	call assign_ (arg_ptr, arg_type * 2, (arg_size),	/* to caller's argument */
	     P_value_info.ptr, CHAR_TYPE * 2, P_value_info.len);  /* from value in node */

end set_value_arg;
%page;
signal_error: proc;

/* Signals nonrestartable sub_error (a better one someday?) because of bad args in value_ call */

	do while ("1"b);
	     signal sub_error;
	end;

end signal_error;
%page;
unlock_for_write: proc (P_ptr);

/* Unlock the value segment */

dcl P_ptr ptr;					/* INPUT: ptr to value seg */

	if P_ptr = null then return;
	if P_ptr -> seg.banner = PP_BANNER then return;

	call set_lock_$unlock (P_ptr -> seg.lock, code);

	call hcs_$set_bc_seg (P_ptr, fixed (P_ptr -> seg.next_free_offset, 18) * 36, code);

end unlock_for_write;
%page;
end value_;




		    value_defined.pl1               11/04/82  1933.2rew 11/04/82  1618.1       43749



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


value_defined: vdf: proc;

/* Written 11/17/80 by S. Herbst */

dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);

dcl name char (name_len) based (name_ptr);

dcl (seg_dn, seg_path) char (168);
dcl seg_en char (32);
dcl ME char (32) int static options (constant) init ("value");

dcl call_switches bit (36) aligned;
dcl (af_sw, defined_sw, got_name_sw, path_sw) bit (1);

dcl (arg_ptr, name_ptr, return_ptr, seg_ptr) ptr;

dcl (arg_len, name_len, return_len) fixed (21);
dcl (arg_count, i) fixed;
dcl (code, code1) fixed (35);

dcl error_table_$badopt fixed (35) ext;
dcl error_table_$not_act_fnc fixed (35) ext;
dcl error_table_$oldnamerr fixed (35) ext;

dcl complain entry variable options (variable);

dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
dcl ioa_ entry options (variable);
dcl value_$defined entry (ptr, bit (36) aligned, char (*), fixed (35)) returns (bit (1));
dcl value_$get_path entry (char (*), fixed (35));

dcl (index, null, substr) builtin;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	end;
	else do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;

	got_name_sw, path_sw = "0"b;
	call_switches = "0"b;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then

		if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call complain (0, ME, "No value specified for -name.");
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     got_name_sw = "1"b;
		     name_ptr = arg_ptr;
		     name_len = arg_len;
		end;

		else if arg = "-pathname" | arg = "-pn" then do;
		     i = i + 1;
		     if i > arg_count then do;
			call complain (0, ME, "No value specified for -pathname.");
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code);
		     if code ^= 0 then do;
			call complain (code, ME, "^a", arg);
			return;
		     end;
		     path_sw = "1"b;
		end;

		else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b;

		else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b;

		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_name_sw then do;
USAGE:		if af_sw then call active_fnc_err_$suppress_name (0, ME,
		     "Usage:  [value_defined name {-control_args}]");
		else call com_err_$suppress_name (0, ME, "Usage:  value_defined name {-control_args}");
		return;
	     end;

	     else do;
		got_name_sw = "1"b;
		name_ptr = arg_ptr;
		name_len = arg_len;
	     end;
	end;

	if ^got_name_sw then go to USAGE;

	if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b;  /* default is both */

	if path_sw then do;
	     call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then do;
		call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		return;
	     end;
	end;
	else seg_ptr = null;			/* default: user's default seg if -perm */

/* Do the work */

	defined_sw = value_$defined (seg_ptr, call_switches, name, code);

	if code ^= 0 then do;
	     if code = error_table_$oldnamerr then call complain (code, ME, "^a", name);
	     else if seg_ptr = null then do;
		call value_$get_path (seg_path, code1);
		if code1 ^= 0 then seg_path = "";
		call complain (code, ME, "Default value segment ^a", seg_path);
	     end;
	     else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
	     return;
	end;

	if af_sw then
	     if defined_sw then return_arg = "true";
	     else return_arg = "false";

	else call ioa_ ("^[true^;false^]", defined_sw);

	return;

end value_defined;




		    value_delete.pl1                09/24/92  2252.0r w 09/24/92  2237.3       90279



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1991   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(91-10-25,Schroth), approve(91-11-28,MECR0015),
     audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001):
     Correct MR12.4 source code corruption.
  2) change(92-05-14,Schroth), approve(91-11-25,MCR8251),
     audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016):
     Replace MECR0015: Correct MR12.4 source code corruption.
                                                   END HISTORY COMMENTS */



value_delete: vdl: proc;

/* Written 11/18/80 by S. Herbst */
/* Added -all, -brief, -data, -long 04/04/83 S. Herbst */
/* Fixed to reject name arg along with -match or -exclude 05/08/84 S. Herbst */

%include value_structures;

dcl ME char (32) int static options (constant) init ("value_delete");
dcl (REGULAR init ("0"b), DATA init ("1"b)) bit (1) int static options (constant);

dcl arg char (arg_len) based (arg_ptr);
dcl name char (name_len) based (name_ptr);

dcl based_area area based (area_ptr);

dcl (seg_dn, seg_path) char (168);
dcl seg_en char (32);

dcl call_switches bit (36) aligned;
dcl (all_sw, brief_sw, data_only_sw, got_name_sw, match_sw, match_arg_sw, path_sw, some_matches) bit (1);
dcl (name_ctl_arg_sw, name_nonctl_arg_sw) bit (1);
dcl (found_data, found_regular) bit (1);

dcl (area_ptr, arg_ptr, name_ptr, seg_ptr) ptr;

dcl (arg_len, name_len) fixed (21);
dcl (arg_count, i, name_index) fixed;
dcl (code, code1) fixed (35);

dcl error_table_$badopt fixed (35) ext;
dcl error_table_$nomatch fixed (35) ext;
dcl error_table_$not_act_fnc fixed (35) ext;
dcl error_table_$oldnamerr fixed (35) ext;


dcl active_fnc_err_ entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
dcl value_$delete entry (ptr, bit (36) aligned, char (*), fixed (35));
dcl value_$delete_data entry (ptr, bit (36) aligned, char (*), fixed (35));
dcl value_$get_path entry (char (*), fixed (35));
dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35));
dcl value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35));

dcl (index, max, null, rtrim, substr, unspec) builtin;
%page;
	call cu_$af_return_arg (arg_count, null, 0, code);
	if code ^= error_table_$not_act_fnc then do;
	     call active_fnc_err_ (0, ME, "Cannot be called as an active function.");
	     return;
	end;

	all_sw, brief_sw, data_only_sw, got_name_sw, match_sw, match_arg_sw, path_sw = "0"b;
	name_ctl_arg_sw, name_nonctl_arg_sw = "0"b;
	call_switches = "0"b;
	alloc_name_count, alloc_max_name_len = 0;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then

		if arg = "-all" | arg = "-a" then do;
		     all_sw = "1"b;
		     data_only_sw = "0"b;
		end;

		else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;

		else if arg = "-data" then do;
		     data_only_sw = "1"b;
		     all_sw = "0"b;
		end;

		else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do;
		     name_ctl_arg_sw = "1"b;
		     if arg = "-match" then match_arg_sw = "1"b;
		     i = i + 1;
		     if i > arg_count then do;
NO_CONTROL_VALUE:		call com_err_ (0, ME, "No value specified for ^a", arg);
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     got_name_sw, match_sw = "1"b;
		     alloc_name_count = alloc_name_count + 1;
		     alloc_max_name_len = max (alloc_max_name_len, arg_len);
		end;

		else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;

		else if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     got_name_sw, name_nonctl_arg_sw = "1"b;
		     name_ptr = arg_ptr;
		     name_len = arg_len;
		end;

		else if arg = "-pathname" | arg = "-pn" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code);
		     if code ^= 0 then do;
			call com_err_ (code, ME, "^a", arg);
			return;
		     end;
		     path_sw = "1"b;
		end;

		else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b;

		else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b;

		else do;
		     call com_err_ (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_name_sw then do;
USAGE:		call com_err_$suppress_name (0, ME, "Usage:  value_delete {name} {-control_args}");
		return;
	     end;

	     else do;
		got_name_sw, name_nonctl_arg_sw = "1"b;
		name_ptr = arg_ptr;
		name_len = arg_len;
	     end;
	end;

	if ^got_name_sw then go to USAGE;

	if name_ctl_arg_sw & name_nonctl_arg_sw then do;
	     call com_err_ (0, ME, "Name argument is incompatible with -match and -exclude.");
	     return;
	end;

	if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b;  /* default is both */

	if path_sw then do;
	     call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then do;
		call com_err_ (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		return;
	     end;
	end;
	else seg_ptr = null;

/* Do the work */

	if ^match_sw then do;

	     if ^data_only_sw then call delete_one (name, REGULAR, found_regular);
	     else found_regular = "0"b;

	     if all_sw | data_only_sw then call delete_one (name, DATA, found_data);
	     else found_data = "0"b;

	     if ^found_regular & ^found_data then call com_err_ (error_table_$oldnamerr, ME, "^a", name);
	end;

	else do;					/* -match or -exclude specified */

						/* if only -exclude's specified, start by matching "**" */
	     if ^match_arg_sw then alloc_name_count = alloc_name_count + 1;

/* Allocate and fill the match structure */

	     area_ptr = get_system_free_area_ ();

	     allocate match_info in (based_area) set (match_info_ptr);

	     unspec (match_info) = "0"b;
	     match_info.version = match_info_version_1;
	     match_info.name_count = alloc_name_count;
	     match_info.max_name_len = alloc_max_name_len;
	     name_index = 0;

	     if ^match_arg_sw then do;
		name_index = 1;
		match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b;
		match_info.name (1) = "**";
	     end;

	     do i = 1 to arg_count;

		call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		if arg = "-exclude" | arg = "-ex" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "1"b;
MATCH_NAME:	     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" then do;
			match_info.regexp_sw (name_index) = "1"b;
			match_info.name (name_index) = substr (arg, 2, arg_len - 2);
		     end;
		     else do;
			match_info.regexp_sw (name_index) = "0"b;  /* starname */
			match_info.name (name_index) = arg;
		     end;
		end;

		else if arg = "-match" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "0"b;
		     go to MATCH_NAME;
		end;
	     end;

	     some_matches = "0"b;

	     if data_only_sw then go to DELETE_DATA;

	     call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code);
	     if code ^= 0 then do;
		if code ^= error_table_$nomatch then do;
LIST_ERROR:	     if seg_ptr = null then call value_$get_path (seg_path, (0));
		     else if seg_dn = ">" then seg_path = ">" || seg_en;
		     else seg_path = rtrim (seg_dn) || ">" || seg_en;
		     call com_err_ (code, ME, "^a", seg_path);
		     return;
		end;
	     end;

	     else do;
		some_matches = "1"b;

		do i = 1 to value_list_info.pair_count;

		     call delete_one (substr (value_list_info.chars,
			value_list_info.name_index (i), value_list_info.name_len (i)), REGULAR, "0"b);
		end;
	     end;
DELETE_DATA:
	     if all_sw | data_only_sw then do;

		call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code);
		if code ^= 0 then do;
		     if code ^= error_table_$nomatch then go to LIST_ERROR;
		end;

		else do;
		     some_matches = "1"b;

		     do i = 1 to value_list_info.pair_count;

			call delete_one (substr (value_list_info.chars,
			     value_list_info.name_index (i), value_list_info.name_len (i)), DATA, "0"b);
		     end;
		end;
	     end;

	     if ^some_matches & ^brief_sw then call com_err_ (0, ME, "No matching names.");
	end;

RETURN: return;

%page;
delete_one: proc (P_name, P_data_sw, P_found_sw);

dcl P_name char (*);
dcl (P_data_sw, P_found_sw) bit (1);

	if P_data_sw then call value_$delete_data (seg_ptr, call_switches, P_name, code);
	else call value_$delete (seg_ptr, call_switches, P_name, code);

	if code = 0 then P_found_sw = "1"b;
	else if code = error_table_$oldnamerr then P_found_sw = "0"b;
	else do;					/* a problem with the value seg */
	     if seg_ptr = null then do;
		call value_$get_path (seg_path, code1);
		if code1 ^= 0 then seg_path = "";
		call com_err_ (code, ME, "Default value segment ^a", seg_path);
	     end;
	     else call com_err_ (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
	     go to RETURN;
	end;

end delete_one;

end value_delete;




		    value_get.pl1                   05/31/88  1417.5rew 05/31/88  1406.1       76752



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        *********************************************************** */
value_get: vg: proc;

/* Written 11/17/80 by S. Herbst */
/* Added -call 07/14/81 S. Herbst */
/* Changed to allow user to set value and restart if no value defined 01/25/82 S. Herbst */
/* Changed -df to -dft as short for -default 05/13/82 S. Herbst */
/* Added -pop 05/23/83 S. Herbst */


/****^  HISTORY COMMENTS:
  1) change(88-01-01,Gilcrease), approve(88-01-27,MCR7832),
     audit(88-05-25,Hunter), install(88-05-31,MR12.2-1049):
               Add -data control argument, to extract data-type names.
                                                   END HISTORY COMMENTS */


dcl arg char (arg_len) based (arg_ptr);
dcl call_string char (call_len) based (call_ptr);
dcl return_arg char (return_len) varying based (return_ptr);
dcl default_value char (default_value_len) based (default_value_ptr);
dcl name char (name_len) based (name_ptr);
dcl data char (data_size * 4) based (data_ptr);

dcl (seg_dn, seg_path) char (168);
dcl seg_en char (32);
dcl ME char (32) int static options (constant) init ("value_get");

dcl call_switches bit (36) aligned;
dcl (af_sw, call_sw, got_name_sw, default_sw, path_sw, pop_sw, data_sw) bit (1);

dcl (arg_ptr, call_ptr, default_value_ptr, name_ptr, return_ptr, seg_ptr, area_ptr, data_ptr) ptr;

dcl (arg_len, call_len, default_value_len, name_len, return_len) fixed (21);
dcl  data_size fixed binary (18);
dcl (arg_count, i) fixed;
dcl (code, code1) fixed (35);

dcl  error_table_$argerr fixed bin(35) ext static;
dcl error_table_$badopt fixed (35) ext;
dcl error_table_$not_act_fnc fixed (35) ext;
dcl error_table_$oldnamerr fixed (35) ext;

dcl complain entry variable options (variable);

dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$evaluate_active_string entry (ptr, char (*), fixed, char (*) varying, fixed (35));
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl get_temp_segment_ entry (char (*), ptr, fixed (35));
dcl  get_system_free_area_ entry() returns(ptr);
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl ioa_ entry options (variable);
dcl release_temp_segment_ entry (char (*), ptr, fixed (35));
dcl value_$get entry options (variable);
dcl value_$get_path entry (char (*), fixed (35));
dcl value_$pop entry options (variable);
dcl value_$set entry options (variable);
dcl  value_$get_data entry options (variable);

dcl (index, length, null, substr) builtin;

dcl cleanup condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;
	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     code = 0;
	end;
	else do;
	     call com_err_ (code, ME);
	     return;
	end;

	call_sw, default_sw, got_name_sw, path_sw, pop_sw, data_sw = "0"b;
	call_switches = "0"b;
	area_ptr, data_ptr = null ();

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then
		if arg = "-call" then do;
		     i = i + 1;
		     if i > arg_count then do;
NO_CONTROL_VALUE:
			call complain (0, ME, "No value specified for ^a", arg);
			return;
		     end;
		     call_sw = "1"b;
		     call cu_$arg_ptr (i, call_ptr, call_len, code);
		end;

		else if arg = "-default" | arg = "-dft" | arg = "-df" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     default_sw = "1"b;
		     call cu_$arg_ptr (i, default_value_ptr, default_value_len, code);
		end;

		else if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     got_name_sw = "1"b;
		     call cu_$arg_ptr (i, name_ptr, name_len, code);
		end;

		else if arg = "-pathname" | arg = "-pn" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
						/* How about a utility someday to find the dn>en */
						/* Maybe search rules, at least naming conventions */
		     call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code);
		     if code ^= 0 then do;
			call complain (code, ME, "^a", arg);
			return;
		     end;
		     path_sw = "1"b;
		end;

		else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b;

		else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b;

		else if arg = "-pop" then pop_sw = "1"b;

		else if arg = "-data" then data_sw = "1"b;

		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_name_sw then do;
USAGE:
		if af_sw then
		     call active_fnc_err_$suppress_name (0, ME, "Usage:  [value_get name {-control_args}]");
		else call com_err_$suppress_name (0, ME, "Usage:  value_get name {-control_args}");
		return;
	     end;

	     else do;
		got_name_sw = "1"b;
		name_ptr = arg_ptr;
		name_len = arg_len;
	     end;
	end;

	if ^got_name_sw then go to USAGE;

	if data_sw & (pop_sw | call_sw | default_sw | substr (call_switches, 1, 1)) = "1"b then do;
	     call complain (error_table_$argerr, ME, "
The -data argument is incompatible with -default, -perprocess, -pop or -call.");
	     return;
	end;

	if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b;
						/* default is both */

	if call_sw & default_sw then do;
	     call complain (0, ME, "-call incompatible with -default.");
	     return;
	end;

	seg_ptr = null;				/* default: user's default seg if -perm */

	on cleanup
	     begin;
		if ^af_sw then call release_temp_segment_ ("value_get", return_ptr, code);

		if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0);
	     end;

	if path_sw then do;
	     call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then do;
		call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		return;
	     end;
	end;

/* Do the work */

	if ^af_sw then do;
	     call get_temp_segment_ ("value_get", return_ptr, code);
	     return_len = WORDS_PER_SEGMENT;
	end;

GET:
	if pop_sw then call value_$pop (seg_ptr, call_switches, name, return_arg, code);

	else if ^data_sw then call value_$get (seg_ptr, call_switches, name, return_arg, code);

	else do;
	     area_ptr = get_system_free_area_ ();
	     call value_$get_data (seg_ptr, call_switches, name, area_ptr, data_ptr, data_size, code);
	end;

	if code ^= 0 then
	     if call_sw then do;
		call cu_$evaluate_active_string (null, call_string, NORMAL_ACTIVE_STRING, return_arg, code);
		if code ^= 0 then do;
		     call complain (code, ME, "Evaluating -call");
		     go to RETURN;
		end;

		call value_$set (seg_ptr, call_switches, name, substr (return_arg, 1, length (return_arg)), "", code);
		if code ^= 0 then call complain (code, ME, "Setting value with -call");
	     end;
	     else if default_sw then return_arg = default_value;
	     else do;
		if code = error_table_$oldnamerr then do;
		     call complain (code, ME, "^a", name);
		     if af_sw then go to GET;		/* in case user set a value while interrupted */
		end;
		else if seg_ptr = null then do;
		     call value_$get_path (seg_path, code1);
		     if code1 ^= 0 then seg_path = "";
		     call complain (code, ME, "Default value segment ^a", seg_path);
		end;
		else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		go to RETURN;
	     end;

	if data_sw then return_arg = data;
	if ^af_sw then call ioa_ ("^a", return_arg);

RETURN:
	if ^af_sw then call release_temp_segment_ ("value_get", return_ptr, code);

	if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0);

	return;
%page;
%include cp_active_string_types;
%page;
%include system_constants;
end value_get;




		    value_list.pl1                  02/27/89  1056.8rew 02/27/89  1051.4      159507



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




/****^  HISTORY COMMENTS:
  1) change(89-01-19,TLNguyen), approve(89-01-19,MCR8051),
     audit(89-02-03,Parisek), install(89-02-27,MR12.3-1015):
     Accept a starname whose length is longer than 32 characters
     (entryname length) when specifying the -match or -exclude
     control argument.
                                                   END HISTORY COMMENTS */


value_list: vls: proc;

/* Written 04/15/81 by S. Herbst */
/* Fixed bug in vls -all 06/02/82 S. Herbst */
/* Added -depth, changed to omit pushed values by default 07/26/84 S. Herbst */
/* Added -brief, changed to report nomatch's for individual args 07/27/84 S. Herbst */
/* Fixed -data erroneous "not found" error message 12/17/84 Steve Herbst */

%include check_star_name;
%include value_structures;

/* Constants */

dcl ME char (32) aligned int static options (constant) init ("value_list");
dcl PERPROCESS_SW bit (36) int static options (constant) init ("100000000000000000000000000000000000"b);


/* Based */

dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);


/* Automatic */

dcl based_area area based (area_ptr);

dcl (seg_dn, seg_path) char (168);
dcl seg_en char (32);
dcl num_str char (16);

dcl call_switches bit (36) aligned;
dcl (af_sw, all_sw, bad_starname_sw, brief_sw, data_only_sw, default_sw, exclude_first_sw) bit (1);
dcl (listed_data_sw, listed_sw, match_sw, match_arg_sw, path_sw, some_sw, some_data_sw, val_sw, var_sw) bit (1);

dcl (area_ptr, arg_ptr, return_ptr, seg_ptr) ptr;

dcl (arg_count, i, j, k, name_index) fixed bin;
dcl (bottom_index, more_count, print_count, push_depth, same_count, top_index) fixed bin;
dcl starname_type fixed bin (2);
dcl (arg_len, return_len) fixed bin (21);
dcl code fixed bin (35);

dcl complain entry variable options (variable);


/* External */

dcl error_table_$bad_conversion fixed bin (35) ext;
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$nomatch fixed bin (35) ext;
dcl error_table_$not_act_fnc fixed bin (35) ext;
dcl error_table_$oldnamerr fixed bin (35) ext;

dcl active_fnc_err_ entry options (variable);
dcl check_star_name_ entry (char (*), bit (36) aligned, fixed bin (2), fixed bin (35));
dcl check_star_name_$entry entry (char (*), fixed bin (35));
dcl com_err_ entry options (variable);
dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl get_system_free_area_ entry returns (ptr);
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl (ioa_, ioa_$rsnnl) entry options (variable);
dcl pathname_ entry (char (*), char (*)) returns (char (168));
dcl requote_string_ entry (char (*)) returns (char (*));
dcl value_$get_path entry (char (*), fixed bin (35));
dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35));
dcl value_$list_data_names entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35));

dcl (index, length, max, min, null, rtrim, substr, unspec) builtin;

dcl cleanup condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;
	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     code = 0;
	end;
	else do;
	     call com_err_ (code, ME);
	     return;
	end;

	area_ptr = get_system_free_area_ ();
	match_info_ptr, seg_ptr, value_list_info_ptr = null;

	on cleanup call clean_up ();

	all_sw, brief_sw, data_only_sw, exclude_first_sw, match_sw, match_arg_sw, path_sw, val_sw, var_sw = "0"b;
	call_switches = "0"b;
	push_depth = 1;				/* default = list latest only */
	alloc_name_count, alloc_max_name_len = 0;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then
		if arg = "-all" | arg = "-a" then all_sw = "1"b;

		else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;

		else if arg = "-data" then data_only_sw = "1"b;

		else if arg = "-depth" | arg = "-dh" then do;
		     i = i + 1;
		     if i > arg_count then call give_up ("No value specified for " || arg);
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     push_depth = cv_dec_check_ (arg, code);
		     if code ^= 0 then do;
			call complain (error_table_$bad_conversion, ME, "-depth value ^a", arg);
			return;
		     end;
		end;

		else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do;
		     i = i + 1;
		     if i > arg_count then call give_up ("No value specified for " || arg);
		     if ^match_sw & (arg = "-exclude" | arg = "-ex") then exclude_first_sw = "1"b;
		     match_sw = "1"b;
		     if arg = "-match" then match_arg_sw = "1"b;
NAME_NEXT:
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
NAME:
		     alloc_name_count = alloc_name_count + 1;
		     alloc_max_name_len = max (alloc_max_name_len, arg_len);
		end;

		else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;

		else if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i > arg_count then call give_up ("No value specified for -name");
		     match_sw, match_arg_sw = "1"b;
		     go to NAME_NEXT;
		end;

		else if arg = "-pathname" | arg = "-pn" then do;
		     i = i + 1;
		     if i > arg_count then call give_up ("No value specified for -pathname");
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code);
		     if code ^= 0 then do;
			call complain (code, ME, "^a", arg);
			return;
		     end;
		     path_sw = "1"b;
		end;

		else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b;

		else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b;

		else if arg = "-value" | arg = "-val" then val_sw = "1"b;

		else if arg = "-variable" | arg = "-var" then var_sw = "1"b;

		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else do;				/* individual name to be matched */
		match_sw, match_arg_sw = "1"b;
		go to NAME;
	     end;
	end;

	if ^val_sw & ^var_sw then
	     if af_sw then
		call give_up ("Either -var or -val required to the active function.");
	     else var_sw, val_sw = "1"b;

	if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b;
						/* default is both */

	if path_sw then do;
	     call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then do;
		call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		return;
	     end;
	end;

	default_sw = (alloc_name_count = 0);
	if default_sw then do;
	     alloc_name_count = 1;
	     alloc_max_name_len = 2;
	end;
	else if exclude_first_sw then alloc_name_count = alloc_name_count + 1;
						/* if -exclude is first, start by matching "**" */

/* Allocate and fill the match structure */

	allocate match_info in (based_area) set (match_info_ptr);

	unspec (match_info) = "0"b;
	match_info.version = match_info_version_1;
	match_info.name_count = alloc_name_count;
	match_info.max_name_len = alloc_max_name_len;
	name_index = 0;

	if default_sw | exclude_first_sw then do;
	     name_index = 1;
	     match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b;
	     match_info.name (1) = "**";
	end;

	bad_starname_sw = "0"b;

	if ^default_sw then
	     do i = 1 to arg_count;

		call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		if index (arg, "-") = 1 then do;

		     if arg = "-exclude" | arg = "-ex" then do;
			name_index = name_index + 1;
			match_info.exclude_sw (name_index) = "1"b;
MATCH_NAME:
			i = i + 1;
			call cu_$arg_ptr (i, arg_ptr, arg_len, code);
			if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" & arg ^= "/" then do;
						/* The specified STR for -ex is a qedx regular expression */
			     match_info.regexp_sw (name_index) = "1"b;
			     match_info.name (name_index) = substr (arg, 2, arg_len - 2);
			end;
			else do;                      /* The specified STR for either -ex or -match is a starname. */
                                                            /* We allow lengths of longer than 32 chars. */
			     call check_star_name_ (arg, (CHECK_STAR_IGNORE_LENGTH), starname_type, code);
			     if code ^= 0 then do;
				bad_starname_sw = "1"b;
				call complain (code, ME, "^a", arg);
			     end;
			     match_info.regexp_sw (name_index) = "0"b;
						/* a starname */
			     match_info.name (name_index) = arg;
			end;
		     end;


		     else if arg = "-match" then do;
			name_index = name_index + 1;
			match_info.exclude_sw (name_index) = "0"b;
			go to MATCH_NAME;
		     end;

		     else if arg = "-name" | arg = "-nm" then do;
			i = i + 1;
			call cu_$arg_ptr (i, arg_ptr, arg_len, code);
PLAIN_NAME:
			name_index = name_index + 1;
			match_info.exclude_sw (name_index), match_info.regexp_sw (name_index) = "0"b;
			match_info.name (name_index) = arg;
		     end;

		     else if arg = "-depth" | arg = "-dh" |
			arg = "-pathname" | arg = "-pn" then i = i + 1;
		end;

		else go to PLAIN_NAME;
	     end;

	if bad_starname_sw then go to RETURN;

	listed_data_sw, listed_sw = "0"b;
	if data_only_sw then go to LIST_DATA;

	call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code);
	if code ^= 0 then do;
ERROR:
	     if code = error_table_$nomatch then
		if all_sw & ^listed_data_sw then go to LIST_DATA;
		else if af_sw then return;		/* return null string */
		else call complain (0, ME, "No matching names.");
	     else do;
		if seg_ptr = null then
		     call value_$get_path (seg_path, (0));
		else seg_path = pathname_ (seg_dn, seg_en);
		call complain (code, ME, "^a", seg_path);
	     end;
	     go to RETURN;
	end;

	listed_sw = "1"b;				/* Note that we have had data to list.			*/

/* Show the results */

	do i = 1 to value_list_info.pair_count;

	     do j = i to value_list_info.pair_count while
		(substr (value_list_info.chars, value_list_info.name_index (j), value_list_info.name_len (j)) =
		 substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)));
	     end;
	     same_count = j - i;			/* number of pushed values for same var name */

	     if same_count > 1 then do;		/* some pushed values */

		top_index = i;
		print_count = min (same_count, push_depth);
		more_count = same_count - print_count;
		bottom_index = top_index + print_count - 1;

		do k = top_index to bottom_index;

		     call print_one (k, top_index, bottom_index, more_count);
		end;

		i = j - 1;
	     end;

	     else call print_one (i, i, i, 0);

	end;

	if ^all_sw then go to DONE_LISTING;		/* Don't list data variables unless requested.		*/

	free value_list_info_ptr -> value_list_info in (based_area);

LIST_DATA:
	listed_data_sw = "1"b;

	call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code);
	if code ^= 0 then
	     if listed_sw & code = error_table_$nomatch then go to RETURN;
	     else go to ERROR;

	do i = 1 to value_list_info.pair_count;

	     do j = i to value_list_info.pair_count while
		(substr (value_list_info.chars, value_list_info.name_index (j), value_list_info.name_len (j)) =
		 substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)));
	     end;
	     same_count = j - i;			/* number of pushed values for same var name */

	     if same_count > 1 then do;		/* some pushed values */
		top_index = i;
		print_count = min (same_count, push_depth);
		more_count = same_count - print_count;
		bottom_index = top_index + print_count - 1;

		do k = top_index to bottom_index;

		     call print_one_data (k, top_index, bottom_index, more_count);
		end;

		i = j - 1;
	     end;

	     else call print_one_data (i, i, i, 0);

	end;
DONE_LISTING:
	if ^brief_sw then do;			/* check for individual match failures */

	     match_info.name_count = 1;		/* do this name by name */
	     match_info.exclude_sw (1) = "0"b;

	     do i = 1 to arg_count;

		call cu_$arg_ptr (i, arg_ptr, arg_len, 0);
		if index (arg, "-") = 1 then do;
		     if arg = "-depth" | arg = "-dh" |
		        arg = "-exclude" | arg = "-ex" |  /* ignore the -exclude and -match names */
		        arg = "-match" |
		        arg = "-pathname" | arg = "-pn" then i = i + 1;
		end;
		else do;
		     match_info.name (1) = arg;
		     some_sw, some_data_sw = "0"b;
		     if ^data_only_sw then do;
			if value_list_info_ptr ^= null then free value_list_info in (based_area);

			call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr,
			     value_list_info_ptr, code);
			some_sw = (code = 0);
		     end;
		     if all_sw | data_only_sw then do;
			if value_list_info_ptr ^= null then free value_list_info in (based_area);

			call value_$list_data_names (seg_ptr, call_switches, match_info_ptr, area_ptr,
			     value_list_info_ptr, code);
			     some_data_sw = (code = 0);
		     end;
		     if ^some_sw & ^some_data_sw then do;
			call check_star_name_$entry (arg, code);
			if code = 0 then call complain (error_table_$oldnamerr, ME, "^a", arg);
			else call complain (error_table_$nomatch, ME, "^a", arg);
		     end;
		end;
	     end;
	end;
RETURN:
	call clean_up;

	return;
%page;
clean_up:
     proc;

	if match_info_ptr ^= null then free match_info_ptr -> match_info in (based_area);
	if value_list_info_ptr ^= null then free value_list_info_ptr -> value_list_info in (based_area);

	if seg_ptr ^= null then call hcs_$terminate_noname (seg_ptr, 0);

     end clean_up;





give_up:
     proc (P_str);

dcl P_str char (*);

	call complain (0, ME, "^a", P_str);
	go to RETURN;

     end give_up;
%page;
print_one: proc (P_index, P_top_index, P_bottom_index, P_more_count);

dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed;

	if af_sw then do;
	     if var_sw then do;
		if length (return_arg) > 0 then return_arg = return_arg || " ";
		return_arg = return_arg || requote_string_ (
		     substr (value_list_info.chars,
			value_list_info.name_index (P_index),
			value_list_info.name_len (P_index)));
	     end;
	     if val_sw then do;
		if length (return_arg) > 0 then return_arg = return_arg || " ";
		return_arg = return_arg || requote_string_ (
		     substr (value_list_info.chars,
			value_list_info.value_index (P_index),
			value_list_info.value_len (P_index)));
	     end;
	end;

	else call ioa_ ("^[^[PP^]^5t^a^[^31.2t^a^]^;^3s^a^]^a", var_sw,
	     value_list_info.type_switches (P_index) & PERPROCESS_SW,
	     substr (value_list_info.chars,
		value_list_info.name_index (P_index),
		value_list_info.name_len (P_index)),
	     val_sw,
	     requote_string_ (
		substr (value_list_info.chars,
		     value_list_info.value_index (P_index),
		     value_list_info.value_len (P_index))),
	     pushed_message (P_index, P_top_index, P_bottom_index, P_more_count));

end print_one;
%page;
print_one_data: proc (P_index, P_top_index, P_bottom_index, P_more_count);

dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed bin;

	if af_sw then do;
	     if var_sw then do;
		if length (return_arg) > 0 then return_arg = return_arg || " ";
		return_arg = return_arg || requote_string_ (
		     substr (value_list_info.chars,
			value_list_info.name_index (P_index),
			value_list_info.name_len (P_index)));
	     end;
	     if val_sw then do;			/* give length in words rather than the value */
		if length (return_arg) > 0 then return_arg = return_arg || " ";
		call ioa_$rsnnl ("^d", num_str, length (num_str), value_list_info.value_len (P_index));
		return_arg = return_arg || rtrim (num_str);
	     end;
	end;

	else call ioa_ ("^[^[PP^]^5t^a^[^31.2t^]^;^3s^]^[(^d word^[s^])^]^a", var_sw,
	     value_list_info.type_switches (P_index) & PERPROCESS_SW,
	     substr (value_list_info.chars,
		value_list_info.name_index (P_index),
		value_list_info.name_len (P_index)),
	     val_sw, val_sw, value_list_info.value_len (P_index),
	     value_list_info.value_len (P_index) ^= 1,
	     pushed_message (P_index, P_top_index, P_bottom_index, P_more_count));

end print_one_data;
%page;
pushed_message: proc (P_index, P_top_index, P_bottom_index, P_more_count) returns (char (32) varying);

dcl (P_index, P_top_index, P_bottom_index, P_more_count) fixed;
dcl message char (32) varying;

	message = "";
	if P_top_index ^= P_bottom_index then do;
	     if P_index = P_top_index then message = " (current value)";
	     else if P_index = P_bottom_index then
		if P_more_count > 0 then
		     call ioa_$rsnnl (" (^d more pushed value^[s^])", message, length (message),
			P_more_count, P_more_count > 1);
		else message = " (earliest value)";
	end;
	else if P_more_count > 0 then
	     call ioa_$rsnnl (" (^d pushed value^[s^])", message, length (message),
		P_more_count, P_more_count > 1);

	return (message);

end pushed_message;

end value_list;




		    value_path.pl1                  11/04/82  1933.2rew 11/04/82  1618.2       17208



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


value_path: vp: proc;

/* Constants */

dcl ME char (32) int static options (constant) init ("value_path");

/* Based */

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

/* Automatic */

dcl path char (168);
dcl af_sw bit (1) aligned;
dcl return_ptr ptr;
dcl return_len fixed bin (24);
dcl arg_count fixed bin;
dcl code fixed bin (35);

/* External */

dcl error_table_$not_act_fnc fixed bin (35) ext;

dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (24), fixed bin (35));
dcl ioa_ entry options (variable);
dcl value_$get_path entry (char (*), fixed bin (35));

dcl rtrim builtin;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	end;
	else do;
	     af_sw = "1"b;
	     return_arg = "";
	end;

	if arg_count ^= 0 then do;
	     if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage:  [vp]");
	     else call com_err_$suppress_name (0, ME, "Usage:  vp");
	     return;
	end;

	call value_$get_path (path, code);
	if code ^= 0 then do;
	     if af_sw then call active_fnc_err_ (code, ME);
	     else call com_err_ (code, ME);
	     return;
	end;

	if af_sw then return_arg = rtrim (path);
	else call ioa_ ("^a", path);

end value_path;




		    value_set.pl1                   10/18/84  0853.8rew 10/18/84  0838.1      141786



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


value_set: vs: proc;

/* Written 11/17/80 by S. Herbst */
/* Fixed vs -add to correctly return the value set 05/13/82 S. Herbst */
/* Fixed vs -pn not to query if error other than $noentry 02/07/84 S. Herbst */

%include value_structures;
%include query_info;

dcl ME char (32) int static options (constant) init ("value_set");
dcl PERMANENT fixed int static options (constant) init (0);

dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);
dcl temp_str char (262114 /* max segment length */) varying based (temp_ptr);

dcl if_value char (if_value_len) based (if_value_ptr);
dcl name char (name_len) based (name_ptr);
dcl value char (value_len) based (value_ptr);

dcl based_area area based (area_ptr);

dcl (seg_dn, seg_path) char (168);
dcl (old_value_num_str, seg_en, value_num_str) char (32);

dcl call_switches bit (36) aligned;
dcl (add_sw, af_sw, explicit_value_sw, got_name_sw, got_value_sw) bit (1);
dcl (if_sw, match_sw, match_arg_sw, path_sw, pop_sw, push_sw, update_sw) bit (1);

dcl temp_ptr ptr;
dcl (area_ptr, arg_ptr, if_value_ptr, name_ptr, return_ptr, seg_ptr, value_ptr) ptr;

dcl add_num fixed (35);
dcl (arg_len, if_value_len, name_len, return_len, value_len) fixed (21);
dcl (arg_count, i, name_index) fixed;
dcl code fixed (35);

dcl error_table_$badopt fixed (35) ext;
dcl error_table_$bad_conversion fixed (35) ext;
dcl error_table_$noentry fixed (35) ext;
dcl error_table_$nomatch fixed (35) ext;
dcl error_table_$not_act_fnc fixed (35) ext;

dcl complain entry variable options (variable);

dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable);
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl command_query_ entry options (variable);
dcl cu_$af_return_arg entry (fixed, ptr, fixed (21), fixed (35));
dcl cu_$arg_ptr entry (fixed, ptr, fixed (21), fixed (35));
dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed (21));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed (35));
dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_temp_segment_ entry (char (*), ptr, fixed (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed (1), fixed (2), ptr, fixed (35));
dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed (5), ptr, fixed (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl ioa_$rsnnl entry options (variable);
dcl release_temp_segment_ entry (char (*), ptr, fixed (35));
dcl value_$get entry options (variable);
dcl value_$get_path entry (char (*), fixed (35));
dcl value_$init_seg entry (ptr, fixed, ptr, fixed (19), fixed (35));
dcl value_$list entry (ptr, bit (36) aligned, ptr, ptr, ptr, fixed (35));
dcl value_$pop entry options (variable);
dcl value_$push entry options (variable);
dcl value_$set entry options (variable);
dcl value_$test_and_set entry options (variable);

dcl (addr, index, length, ltrim, max, null, rtrim, substr, unspec) builtin;

dcl cleanup condition;
%page;
	call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
	if code = 0 then do;
	     af_sw = "1"b;
	     complain = active_fnc_err_;
	end;
	else if code = error_table_$not_act_fnc then do;
	     af_sw = "0"b;
	     complain = com_err_;
	     code = 0;
	end;
	else do;
	     call com_err_ (code, ME);
	     return;
	end;

	add_sw, explicit_value_sw, got_name_sw, got_value_sw, if_sw, match_sw, match_arg_sw, path_sw, update_sw = "0"b;
	pop_sw, push_sw = "0"b;
	call_switches = "0"b;
	alloc_name_count, alloc_max_name_len = 0;

	do i = 1 to arg_count;			/* if -match etc. given, don't look for name arg */
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if arg = "-match" | arg = "-exclude" | arg = "-ex" then got_name_sw = "1"b;
	end;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then
		if arg = "-add" then do;
		     i = i + 1;
		     if i > arg_count then do;
NO_CONTROL_VALUE:
			call complain (0, ME, "No value specified for ^a", arg);
			return;
		     end;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     add_num = cv_dec_check_ (arg, code);
		     if code ^= 0 then do;
			call complain (code, ME, "^a", arg);
			return;
		     end;
		     add_sw, got_value_sw = "1"b;
		     value_ptr = arg_ptr;
		     value_len = arg_len;
		end;

		else if arg = "-exclude" | arg = "-ex" | arg = "-match" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     match_sw = "1"b;
		     match_arg_sw = (arg = "-match");
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     alloc_name_count = alloc_name_count + 1;
		     alloc_max_name_len = max (alloc_max_name_len, arg_len);
		end;

		else if arg = "-if" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if_sw = "1"b;
		     if_value_ptr = arg_ptr;
		     if_value_len = arg_len;
		end;

		else if arg = "-name" | arg = "-nm" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if got_value_sw & got_name_sw then go to USAGE;
		     else if got_name_sw then do;
			explicit_value_sw, got_value_sw = "1"b;
			value_ptr = arg_ptr;
			value_len = arg_len;
		     end;
		     else do;
			got_name_sw = "1"b;
			name_ptr = arg_ptr;
			name_len = arg_len;
		     end;
		end;

		else if arg = "-pathname" | arg = "-pn" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     call expand_pathname_$add_suffix (arg, "value", seg_dn, seg_en, code);
		     if code ^= 0 then do;
			call complain (code, ME, "-pathname arg ^a", arg);
			return;
		     end;
		     path_sw = "1"b;
		end;

		else if arg = "-perprocess" | arg = "-pp" then substr (call_switches, 1, 1) = "1"b;

		else if arg = "-permanent" | arg = "-perm" then substr (call_switches, 2, 1) = "1"b;

		else if arg = "-pop" then pop_sw = "1"b;
		else if arg = "-push" then push_sw = "1"b;

		else if arg = "-update" | arg = "-ud" then update_sw = "1"b;
		else if arg = "-no_update" | arg = "-nud" then update_sw = "0"b;

		else if arg = "-value" | arg = "-val" then do;
		     i = i + 1;
		     if i > arg_count then go to NO_CONTROL_VALUE;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     explicit_value_sw, got_value_sw = "1"b;
		     value_ptr = arg_ptr;
		     value_len = arg_len;
		end;

		else do;
		     call complain (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_value_sw & got_name_sw then do;
USAGE:
		if af_sw then
		     call active_fnc_err_$suppress_name (0, ME, "Usage:  [value_set {name} {value} {-control_args}]");
		else call com_err_$suppress_name (0, ME, "Usage:  value_set {name} {value} {-control_args}");
		return;
	     end;

	     else if got_name_sw then do;
		explicit_value_sw, got_value_sw = "1"b;
		value_ptr = arg_ptr;
		value_len = arg_len;
	     end;

	     else do;
		got_name_sw = "1"b;
		name_ptr = arg_ptr;
		name_len = arg_len;
	     end;
	end;

	if ^got_name_sw then go to USAGE;

	if pop_sw & got_value_sw then do;
	     call complain (0, ME, "-pop is incompatible with specifying a value.");
	     return;
	end;
	else if pop_sw then do;			/* set up a dummy for calling value_set_push_pop */
	     value_ptr = name_ptr;
	     value_len = name_len;
	end;
	else if ^got_value_sw then go to USAGE;

	if if_sw & (pop_sw | push_sw) then do;
	     call complain (0, ME, "-if is incompatible with -push or -pop");
	     return;
	end;

	if pop_sw & push_sw then do;
	     call complain (0, ME, "-push is incompatible with -pop");
	     return;
	end;

	if add_sw & explicit_value_sw then do;
	     call complain (0, ME, "-add incompatible with specifying a value.");
	     return;
	end;

	if substr (call_switches, 1, 2) = "00"b then substr (call_switches, 1, 2) = "11"b;
						/* default is both */

	match_info_ptr, seg_ptr, temp_ptr, value_list_info_ptr = null ();

	on cleanup
	     begin;
		if temp_ptr ^= null () then call release_temp_segment_ ("value_set", temp_ptr, code);
		if match_info_ptr ^= null () then free match_info in (based_area);
		if value_list_info_ptr ^= null () then free value_list_info in (based_area);
		if seg_ptr ^= null () then call hcs_$terminate_noname (seg_ptr, 0);
	     end;

	if path_sw then do;				/* user_specified value segment */
	     call hcs_$initiate (seg_dn, seg_en, "", 0, 0, seg_ptr, code);
	     if seg_ptr = null then do;
		if code = error_table_$noentry then do;
		     if query_create (seg_dn, seg_en, seg_ptr) then go to SEG_OK;
		end;
		else call complain (code, ME, "Value segment ^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
		return;
	     end;
	end;

	if af_sw & match_sw then do;			/* more than one return value to concatenate */
	     call get_temp_segment_ ("value_set", temp_ptr, code);
	end;

/* Do the work */

SEG_OK:
	if ^match_sw then
	     call set_value (name, "");

	else do;					/* -match or -exclude specified */

/* if only -exclude's specified, start by matching "**" */
	     if ^match_arg_sw then alloc_name_count = alloc_name_count + 1;

/* Allocate and fill the match structure */

	     area_ptr = get_system_free_area_ ();

	     allocate match_info in (based_area) set (match_info_ptr);

	     unspec (match_info) = "0"b;
	     match_info.version = match_info_version_1;
	     match_info.name_count = alloc_name_count;
	     match_info.max_name_len = alloc_max_name_len;
	     name_index = 0;

	     if ^match_arg_sw then do;
		name_index = 1;
		match_info.exclude_sw (1), match_info.regexp_sw (1) = "0"b;
		match_info.name (1) = "**";
	     end;

	     do i = 1 to arg_count;

		call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		if arg = "-exclude" | arg = "-ex" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "1"b;
MATCH_NAME:
		     i = i + 1;
		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
		     if substr (arg, 1, 1) = "/" & substr (arg, arg_len, 1) = "/" then do;
			match_info.regexp_sw (name_index) = "1"b;
			match_info.name (name_index) = substr (arg, 2, arg_len - 2);
		     end;
		     else do;
			match_info.regexp_sw (name_index) = "0"b;
						/* starname */
			match_info.name (name_index) = arg;
		     end;
		end;

		else if arg = "-match" then do;
		     name_index = name_index + 1;
		     match_info.exclude_sw (name_index) = "0"b;
		     go to MATCH_NAME;
		end;
	     end;

	     call value_$list (seg_ptr, call_switches, match_info_ptr, area_ptr, value_list_info_ptr, code);
	     if code ^= 0 then do;
		if code = error_table_$nomatch then
		     call complain (0, ME, "No matching names.");
		else do;
		     if seg_ptr = null then call value_$get_path (seg_path, (0));
		     else if seg_dn = ">" then seg_path = ">" || seg_en;
		     else seg_path = rtrim (seg_dn) || ">" || seg_en;
		     call complain (code, ME, "^a", seg_path);
		end;
		return;
	     end;

	     do i = 1 to value_list_info.pair_count;

		call set_value (
		     substr (value_list_info.chars, value_list_info.name_index (i), value_list_info.name_len (i)),
		     substr (value_list_info.chars, value_list_info.value_index (i), value_list_info.value_len (i)));
	     end;
	end;

RETURN:
	if temp_ptr ^= null () then call release_temp_segment_ ("value_set", temp_ptr, code);
	if match_info_ptr ^= null () then free match_info in (based_area);
	if value_list_info_ptr ^= null () then free value_list_info in (based_area);
	if seg_ptr ^= null () then call hcs_$terminate_noname (seg_ptr, 0);
%page;
query_create:
     proc (A_dn, A_en, A_seg_ptr) returns (bit (1));

dcl (A_dn, A_en) char (*);
dcl A_seg_ptr ptr;
dcl 1 qi aligned like query_info;
dcl answer char (32) varying;
dcl code fixed (35);

	unspec (qi) = "0"b;
	qi.version = query_info_version_5;
	qi.yes_or_no_sw = "1"b;
	qi.question_iocbp, qi.answer_iocbp = null;

	call command_query_ (addr (qi), answer, ME, "Do you want to create the value segment ^a^[>^]^a ?", A_dn,
	     A_dn ^= ">", A_en);

	if answer = "no" then go to RETURN;

	call hcs_$make_seg (A_dn, A_en, "", 01010b, A_seg_ptr, code);
	if code ^= 0 then do;
ERR:
	     call complain (code, ME, "^a^[>^]^a", A_dn, A_dn ^= ">", A_en);
	     go to RETURN;
	end;

	call value_$init_seg (A_seg_ptr, PERMANENT, null, 0, code);
	if code ^= 0 then go to ERR;

	return ("1"b);

     end query_create;
%page;
set_value:
     proc (P_name, P_old_value);

/* Sets a single value, modified by the control argument options. */

dcl (P_name, P_old_value) char (*);
dcl old_value_num fixed (35);

RETRY:
	if add_sw then do;
	     if match_sw then
		old_value_num_str = P_old_value;
	     else do;
		call value_$get (seg_ptr, call_switches, name, old_value_num_str, code);
		if code ^= 0 then do;
BAD_OLD:
		     call complain (code, ME, "^a", P_name);
		     return;
		end;
	     end;

	     if update_sw & af_sw then return_arg = rtrim (old_value_num_str);

	     old_value_num = cv_dec_check_ (old_value_num_str, code);
	     if code ^= 0 then do;
		code = error_table_$bad_conversion;
		go to BAD_OLD;
	     end;
	     call ioa_$rsnnl ("^d", value_num_str, length (value_num_str), old_value_num + add_num);
	     call value_$test_and_set (seg_ptr, call_switches, name, rtrim (value_num_str), rtrim (old_value_num_str),
		code);
	     value_ptr = addr (value_num_str);
	     value_len = length (rtrim (value_num_str));
	     go to TEST_CODE;
	end;

	if if_sw then
	     if match_sw then do;
		if if_value ^= P_old_value then return;
	     end;
	     else do;
		call value_$test_and_set (seg_ptr, call_switches, name, value, if_value, code);
		go to TEST_CODE;
	     end;

	if update_sw & af_sw then
	     if match_sw then do;
		call value_set_push_pop (seg_ptr, call_switches, P_name, value, temp_str, code);
		return_arg = ltrim (return_arg || " " || temp_str);
	     end;
	     else call value_set_push_pop (seg_ptr, call_switches, P_name, value, return_arg, code);

	else call value_set_push_pop (seg_ptr, call_switches, P_name, value, "", code);
TEST_CODE:
	if code ^= 0 then do;
	     if ^path_sw then do;
		call value_$get_path (seg_path, (0));
		call expand_pathname_ (seg_path, seg_dn, seg_en, (0));
	     end;
	     if code = error_table_$noentry then do;

		if query_create (seg_dn, seg_en, seg_ptr) then go to RETRY;
	     end;
	     else call complain (code, ME, "^a^[>^]^a", seg_dn, seg_dn ^= ">", seg_en);
	     return;
	end;

	if af_sw & ^update_sw then
	     if match_sw then
		return_arg = ltrim (return_arg || " " || value);
	     else return_arg = value;

	return;
%page;
value_set_push_pop:
	proc (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code);

dcl P_seg_ptr ptr;
dcl P_switches bit (36) aligned;
dcl (P_name, P_value) char (*);
dcl P_old_value char (*) varying;
dcl P_code fixed (35);

	     if pop_sw then call value_$pop (P_seg_ptr, P_switches, P_name, P_old_value, P_code);

	     else if push_sw then call value_$push (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code);

	     else call value_$set (P_seg_ptr, P_switches, P_name, P_value, P_old_value, P_code);

	end value_set_push_pop;

     end set_value;

end value_set;




		    value_set_path.pl1              11/04/82  1933.2rew 11/04/82  1618.3       24705



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


value_set_path: vsp: proc;

/* Written 03/06/81 by S. Herbst */
/* Changed to use default value seg when invoked with no args 08/18/81 S. Herbst */

/* Constants */

dcl ME char (32) int static options (constant) init ("value_set_path");
dcl CREATE bit (1) aligned int static options (constant) init ("1"b);

/* Based */

dcl arg char (arg_len) based (arg_ptr);

/* Automatic */

dcl (expanded_path, path) char (168);
dcl (brief_sw, got_path_sw) bit (1) aligned;
dcl arg_ptr ptr;
dcl arg_len fixed bin (24);
dcl (arg_count, i) fixed bin;
dcl code fixed bin (35);

/* External */

dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$no_w_permission fixed bin (35) ext;

dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl (com_err_, com_err_$suppress_name) entry options (variable);
dcl cu_$arg_count entry (fixed bin, fixed bin (35));
dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (24), fixed bin (35));
dcl ioa_ entry options (variable);
dcl value_$set_path entry (char (*), bit (1) aligned, fixed bin (35));

dcl index builtin;
%page;
	call cu_$arg_count (arg_count, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;

	got_path_sw, brief_sw = "0"b;

	do i = 1 to arg_count;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

	     if index (arg, "-") = 1 then
		if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
		else do;
		     call com_err_ (error_table_$badopt, ME, "^a", arg);
		     return;
		end;

	     else if got_path_sw then do;
USAGE:		call com_err_$suppress_name (0, ME, "Usage:  vsp {path} {-brief}");
		return;
	     end;

	     else do;
		got_path_sw = "1"b;
		path = arg;
	     end;
	end;

	if ^got_path_sw | path = "" then expanded_path = "";
	else do;
	     call absolute_pathname_ (path, expanded_path, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "^a", path);
		return;
	     end;
	end;

	call value_$set_path (expanded_path, CREATE, code);
	if code ^= 0 then
	     if code = error_table_$no_w_permission then do;
		if ^brief_sw then
		     call ioa_ ("Warning: You lack write access on value segment ^a", expanded_path);
	     end;
	     else call com_err_ (code, ME, "Value segment ^a", expanded_path);

end value_set_path;






		    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
