



		    report_writer.pl1               04/10/85  0841.2r w 04/08/85  1128.9      141498



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*
     
     This module creates and destroys a report_writer_ invocation. The
     following entries are provided:

     create_invocation

     This entry creates a report_writer_ invocation. It sets up all of the
     temp segments, areas, etc. that report_writer_ needs. It also calls
     the intialization code for other modules, like the ones needed to manage
     the report_writer_ standard table, format option values, etc.

     destroy_invocation

     This entry destroys a report_writer_ invocation. It gets rid of the
     temp segments, areas, etc. the create_invocation entry acquires. It also
     calls the termination code for the modules mentioned above in
     create_invocation.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - October 1984.

*/
%page;
report_writer: proc;
%skip(3);
/* These parameters are described at each entry where they are used. */
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl message_parm char (*) varying parm;
dcl report_cip_parm ptr parm;
dcl ssu_info_ptr_parm ptr parm;
dcl subsystem_name_parm char (*) parm;
%skip(3);
	call com_err_ (error_table_$badcall, "report_writer");
%skip(1);
	return;
%page;
create_invocation: entry (

	subsystem_name_parm,       /* input: Multics subsystem's name */
	ssu_info_ptr_parm,	       /* input: ssu_ info pointer */
	report_cip_parm,	       /* output: points to report_control_info */
	code_parm,                 /* output: success or failure */
	message_parm	       /* output: reason for the failure */
		       );
%skip(1);
/*

     This entrypoint sets up the environment for report_writer_. It performs
     the following steps:

     (1) Initializes automatic variables and sets up a cleanup handler so
         this entry can clean up gracefully if interrupted.

     (2) Sets up madatory subsystem info, like the ec suffix, subsystem name,
         etc.

     (3) Allocates/fills in report_control_info, and acquires the temp segments
         and area needed by report_writer_. Initializes the value_ segment
         used to hold the format option names and values.

     (4) Creates the entry variables for the calling subsystem's table
         manager procedure. Initializes the report_writer_ standard table
         structure. Sets the general report format options to their default
         values. Sets the report_writer_ info pointer in static storage so
         the report_writer_ subsystem requests will automagically get handed
         the correct report_writer_ info pointer from static storage. Adds
         the report_writer_ standard requests to the calling subsystem's
         set of requests. Adds the info directory for these requests.

*/
%skip(1);
	report_cip_parm = null;
%skip(1);
	call initialize_for_create_invocation;
%skip(1);
	on cleanup call cleanup_for_create_invocation;
%skip(1);
	call setup_subsystem_mandatory_info (code_parm, message_parm);
	if code_parm = 0
	then call setup_to_do_reporting (code_parm, message_parm);
	if code_parm = 0
	then call initialize_report_writer (code_parm, message_parm);
%skip(1);
	if code_parm = 0
	then report_cip_parm = report_cip;
	else call cleanup_for_create_invocation;
%skip(1);
	return;
%page;
destroy_invocation: entry (
%skip(1);
          report_cip_parm /* input: points to report_control_info */
	     );
%skip(1);
/*

     This entrypoint releases the environment setup for report_writer_. It 
     performs the following steps:

     (1) Cleans up the report_writer_ standard table structure.

     (2) Cleans up any report leftover by the user typing "display
         -keep_report", and then never invoking display again.

     (3) Gets rid of the temp segments and areas needed by report_writer_.

     (4) Removes the report_writer_ info pointer from static storage.

     (5) Removes the report_writer_ standard requests from the calling
         subsystem's set of requests, and the info dir for these requests.

*/
%skip(1);
	report_cip = report_cip_parm;
%skip(1);
	if report_cip ^= null
	then do;
	     call rw_table_manager$terminate_table (report_cip, (0));
	     if report_control_info.flags.permanent_report
	     then call rw_fr_delete_report (report_cip, (0));
	     call release_areas_and_temp_segments;
	     call rw_requests$delete_report_info_ptr (sci_ptr);
	     call ssu_$delete_request_table (sci_ptr,
		addr (report_writer_request_table_$standard_requests), (0));
	     call ssu_$delete_info_dir (sci_ptr,
		report_writer_info_dirs_$standard_requests, (0));
	     report_cip_parm = null;
	end;
%skip(1);
	return;
%page;
cleanup_for_create_invocation: proc;
%skip(1);
dcl cfci_loop fixed bin;
%skip(1);
	do cfci_loop = 1 to hbound (area_ptrs, 1);
	     call ssu_$release_area (sci_ptr, area_ptrs (cfci_loop));
	end;
%skip(1);
	do cfci_loop = 1 to hbound (temp_segment_ptrs, 1);
	     call ssu_$release_temp_segment (sci_ptr, temp_segment_ptrs (cfci_loop));
	end;
%skip(1);
	if work_area_ptr ^= null
	then call ssu_$release_area (sci_ptr, work_area_ptr);
%skip(1);
	return;
%skip(1);
     end cleanup_for_create_invocation;
%page;
initialize_for_create_invocation: proc;
%skip(1);
	work_area_ptr = null;
	report_cip = null;
	area_ptrs (*) = null;
	temp_segment_ptrs (*) = null;
%skip(1);
	return;
%skip(1);
     end initialize_for_create_invocation;
%page;
initialize_report_writer: proc (

	irw_code_parm,   /* output: success or failure */
	irw_message_parm /* output: reason for the failure */
			 );
%skip(1);
dcl irw_code_parm fixed bin (35) parm;
dcl irw_message_parm char (*) varying parm;
%skip(1);
	call rw_table_manager$set_table_manager (report_cip,
	     table_manager_name, irw_code_parm, irw_message_parm);
	if irw_code_parm ^= 0
	then return;
%skip(1);
	call rw_table_manager$initialize_table (report_cip, irw_code_parm);
	if irw_code_parm ^= 0
	then do;
	     call ioa_$rsnnl ("^/While initializing the internal table structure.",
		irw_message_parm, (0));
	     return;
	end;
%skip(1);
	call rw_options$set_all_to_system_defaults (report_cip, irw_code_parm);
	if irw_code_parm ^= 0
	then do;
	     call ioa_$rsnnl ("^/While setting the option values to their defaults.",
		irw_message_parm, (0));
	     return;
	end;
%skip(1);
	call rw_requests$set_initial_report_info_ptr (sci_ptr, report_cip, irw_code_parm);
	if irw_code_parm ^= 0
	then do;
	     call ioa_$rsnnl ("^/While setting the report writer info pointer.",
		irw_message_parm, (0));
	     return;
	end;
%skip(1);
	call ssu_$add_request_table (sci_ptr, addr (report_writer_request_table_$standard_requests),
	     99999, irw_code_parm);
	if irw_code_parm ^= 0
	then do;
	     call ioa_$rsnnl ("^/While adding the report_writer_ requests.",
		irw_message_parm, (0));
	     return;
	end;
%skip(1);
	call ssu_$add_info_dir (sci_ptr, report_writer_info_dirs_$standard_requests,
	     99999, irw_code_parm);
	if irw_code_parm ^= 0
	then do;
	     call ioa_$rsnnl ("^/While adding the report_writer_ info directory for the standard requests.",
		irw_message_parm, (0));
	     return;
	end;
%skip(1);
	return;
%skip(1);
     end initialize_report_writer;
%page;
release_areas_and_temp_segments: proc;
%skip(1);
dcl raats_loop ptr;
%skip(1);
	sci_ptr = report_control_info.subsystem_control_info_ptr;
%skip(1);
	do raats_loop = report_control_info.input_string_temp_seg_ptr,
	     report_control_info.output_string_temp_seg_ptr,
	     report_control_info.editing_strings_temp_seg_ptr,
	     report_control_info.headers_temp_seg_ptr,
	     report_control_info.row_value_temp_segment_ptr,
	     report_control_info.value_seg_ptr,
	     report_control_info.name_value_temp_seg_ptr,
	     report_control_info.report_temp_seg_ptr;
	     call ssu_$release_temp_segment (sci_ptr, raats_loop);
	end;
%skip(1);
	do raats_loop = report_control_info.name_value_area_ptr,
	     report_control_info.report_work_area_ptr,
	     report_control_info.general_work_area_ptr;
	     call ssu_$release_area (sci_ptr, raats_loop);
	end;
%skip(1);
	return;
%skip(1);
     end release_areas_and_temp_segments;
%page;
setup_subsystem_mandatory_info: proc (

	ssmi_code_parm,   /* output: success or failure */
	ssmi_message_parm /* output: reason for the failure */
			       );
%skip(1);
dcl ssmi_code_parm fixed bin (35) parm;
dcl ssmi_message_parm char (*) varying parm;
%skip(1);
	ssmi_code_parm = 0;
	ssmi_message_parm = "";
%skip(1);
	if ssu_info_ptr_parm = null
	then do;
	     ssmi_code_parm = error_table_$null_info_ptr;
	     ssmi_message_parm = "The ssu_ info pointer was null.";
	     return;
	end;
%skip(1);
	sci_ptr = ssu_info_ptr_parm;
	subsystem_info_ptr = ssu_$get_info_ptr (sci_ptr);
%skip(1);
	if subsystem_name_parm ^= ""
	then table_manager_name = subsystem_name_parm;
	else table_manager_name = ssu_$get_subsystem_name (sci_ptr);
%skip(1);
	ec_suffix = ssu_$get_ec_suffix (sci_ptr);
%skip(1);
	return;
%skip(1);
     end setup_subsystem_mandatory_info;
%page;
setup_to_do_reporting: proc (

	stdr_code_parm,	/* output: success or failure */
	stdr_message_parm	/* output: reason for failure */
		        );
%skip(1);
dcl stdr_code_parm fixed bin (35) parm;
dcl stdr_index fixed bin;
dcl stdr_loop char (32);
dcl stdr_message_parm char (*) varying parm;
%skip(1);
	stdr_code_parm = 0;
	stdr_message_parm = "";
%skip(1);
	area_infop = addr (automatic_area_info);
	area_info.version = area_info_version_1;
	unspec (area_info.control) = OFF;
	area_info.control.extend = ON;
	call ssu_$get_area (sci_ptr, area_infop, "rw_.general_use_area", work_area_ptr);
          allocate report_control_info in (work_area) set (report_cip);
          unspec (report_control_info) = OFF;
	report_control_info.general_work_area_ptr = work_area_ptr;
%skip(1);
	area_info.control.no_freeing = ON;
%skip(1);
	stdr_index = 1;
	do stdr_loop =  "rw_.names_and_values_area", "rw_.report_area";
	     call ssu_$get_area (sci_ptr, area_infop, stdr_loop, area_ptrs (stdr_index));
	     stdr_index = stdr_index + 1;
	end;
	report_control_info.name_value_area_ptr = area_ptrs (1);
	report_control_info.report_work_area_ptr = area_ptrs (2);
%skip(1);
	stdr_index = 1;
	do stdr_loop = "rw_.input_string_seg", "rw_.output_string_seg",
	     "rw_.editing_string_seg", "rw_.headers_seg", "rw_.row_value_seg",
	     "rw_.format_options_seg", "rw_.star_name_seg",  "rw_.formatted_page_seg";
	     call ssu_$get_temp_segment (sci_ptr, stdr_loop, temp_segment_ptrs (stdr_index));
	     stdr_index = stdr_index + 1;
	end;
%skip(1);
	report_control_info.input_string_temp_seg_ptr = temp_segment_ptrs (1);
	report_control_info.output_string_temp_seg_ptr = temp_segment_ptrs (2);
	report_control_info.editing_strings_temp_seg_ptr = temp_segment_ptrs (3);
	report_control_info.headers_temp_seg_ptr = temp_segment_ptrs (4);
	report_control_info.row_value_temp_segment_ptr = temp_segment_ptrs (5);
	report_control_info.value_seg_ptr = temp_segment_ptrs (6);
	report_control_info.name_value_temp_seg_ptr = temp_segment_ptrs (7);
	report_control_info.report_temp_seg_ptr = temp_segment_ptrs (8);
%skip(1);
	call value_$init_seg (report_control_info.value_seg_ptr, 0, null, 0, stdr_code_parm);
	if stdr_code_parm ^= 0
	then do;
	     stdr_message_parm = "^/While trying to initialize the options' value segment.";
	     return;
	end;
%skip(1);
	report_control_info.table_information_ptr = null;
	report_control_info.subsystem_control_info_ptr = sci_ptr;
	report_control_info.subsystems_info_ptr = subsystem_info_ptr;
	report_control_info.subsystems_ec_suffix = ec_suffix;
	report_control_info.format_report_info_ptr = null;
	report_control_info.display_iocb_ptr = null;
	report_control_info.temp_dir_name = get_pdir_ ();
	allocate status_branch in (work_area) set (status_ptr);
	call expand_pathname_ (report_control_info.temp_dir_name,
	     directory_name, entry_name, stdr_code_parm);
	if stdr_code_parm ^= 0
	then do;
	     stdr_message_parm = "^/Unable to expand the process dir directory name.";
	     return;
	end;
	call hcs_$status_long (directory_name, entry_name, 1,
	     status_ptr, null, stdr_code_parm);
	if stdr_code_parm ^= 0 & stdr_code_parm ^= error_table_$no_s_permission
	then do;
	     stdr_message_parm = "^/Unable to determine the unique id of the process dir.";
	     return;
	end;
	else stdr_code_parm = 0;
	report_control_info.temp_dir_unique_id = status_branch.long.uid;
	free status_branch in (work_area);
	allocate area_info in (work_area) set (area_infop);
	area_infop -> area_info = addr (automatic_area_info) -> area_info;
	report_control_info.area_info_ptr = area_infop;
%skip(1);
          return;
%skip(1);
     end setup_to_do_reporting;
%page;
dcl EXTENSIBLE bit (1) aligned static int options (constant) init ("1"b);
%skip(1);
dcl OFF bit (1) aligned static internal options (constant) init ("0"b);
dcl ON bit (1) aligned static internal options (constant) init ("1"b);
%skip(1);
dcl addr builtin;
dcl area_ptrs (2) ptr;
dcl 1 automatic_area_info like area_info;
%skip(1);
dcl cleanup condition;
dcl com_err_ entry () options (variable);
%skip(1);
dcl directory_name char (168);
%skip(1);
dcl ec_suffix char (32);
dcl entry_name char (32);
dcl error_table_$badcall fixed bin(35) ext static;
dcl error_table_$no_s_permission fixed bin(35) ext static;
dcl error_table_$null_info_ptr fixed bin(35) ext static;
dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
%skip(1);
dcl get_pdir_ entry() returns(char(168));
%skip(1);
dcl hbound builtin;
dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
%skip(1);
dcl ioa_$rsnnl entry() options(variable);
%skip(1);
dcl null builtin;
%skip(1);
dcl report_writer_info_dirs_$standard_requests char (168) external;
dcl report_writer_request_table_$standard_requests bit (36) aligned external;
dcl rw_options$set_all_to_system_defaults entry (ptr, fixed bin (35));
dcl rw_fr_delete_report entry (ptr, fixed bin (35));
dcl rw_requests$delete_report_info_ptr entry (ptr);
dcl rw_requests$set_initial_report_info_ptr entry (ptr, ptr, fixed bin (35));
dcl rw_table_manager$initialize_table entry (ptr, fixed bin (35));
dcl rw_table_manager$set_table_manager entry (ptr, char(*), fixed bin (35), char (*) varying);
dcl rw_table_manager$terminate_table entry (ptr, fixed bin (35));
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$add_info_dir entry (ptr, char(*), fixed bin, fixed bin(35));
dcl ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin(35));
dcl ssu_$delete_info_dir entry (ptr, char(*), fixed bin(35));
dcl ssu_$delete_request_table entry (ptr, ptr, fixed bin(35));
dcl ssu_$get_area entry (ptr, ptr, char(*), ptr);
dcl ssu_$get_ec_suffix entry (ptr) returns(char(32));
dcl ssu_$get_info_ptr entry (ptr) returns(ptr);
dcl ssu_$get_subsystem_name entry (ptr) returns(char(32));
dcl ssu_$get_temp_segment entry (ptr, char(*), ptr);
dcl ssu_$release_area entry (ptr, ptr);
dcl ssu_$release_temp_segment entry (ptr, ptr);
dcl subsystem_info_ptr ptr;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl table_manager_name char (32);
dcl temp_segment_ptrs (8) ptr;
%skip(1);
dcl unspec builtin;
%skip(1);
dcl value_$init_seg entry (ptr, fixed bin, ptr, fixed bin(19), fixed bin(35));
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include area_info;
%page;
%include access_mode_values;
%page;
%include rw_report_info;
%page;
%include rw_options_extents;
%page;
%include status_structures;
%skip(3);
     end report_writer;




		    report_writer_.alm              11/16/84  1405.2rew 11/16/84  1107.5        7407



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
" report_writer_ Transfer Vector.
" Written - Al Dupuis - October 1984
"
		name	report_writer_
macro	tv
	entry	&1
&1:	tra	<&2>|[&3]
&end

	tv	convert_and_move_row,rw_convert_and_move_row,rw_convert_and_move_row
	tv	create_invocation,report_writer,create_invocation
	tv	define_columns,rw_define_columns,rw_define_columns
	tv	destroy_invocation,report_writer,destroy_invocation
	tv	set_report_writer_info_ptr,rw_requests,set_report_writer_info_ptr
	tv	set_table_manager,rw_table_manager,set_table_manager

		end





		    report_writer_info_dirs_.cds    11/16/84  1403.0rew 11/16/84  1107.6       38781



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module creates the segment "report_writer_info_dirs_" which
     contains the pathnames of directories containing info segments
     provided with the report_writer_ (except for the subroutine info
     segment report_writer_.info).

     The following directories are provided:

     >doc>ss>report_writer_info_dirs
	contains all the report_writer_ request's info segments

     >doc>ss>report_writer_info_dirs>standard_requests
	contains links to all the report_writer_ request's info segments

     >doc>ss>report_writer_info_dirs>clv_request
	contains a link to the report_writer_ column_value request's info segment

     >doc>ss>report_writer_info_dirs>di_request
	contains a link to the report_writer_ display request's info segment

     >doc>ss>report_writer_info_dirs>dib_request
	contains a link to the report_writer_ display_builtins request's info segment

     >doc>ss>report_writer_info_dirs>lsfo_request
	contains a link to the report_writer_ list_format_options request's info segment

     >doc>ss>report_writer_info_dirs>rsfo_request
	contains a link to the report_writer_ restore_format_options request's info segment

     >doc>ss>report_writer_info_dirs>sfo_request
	contains a link to the report_writer_ set_format_options request's info segment

     >doc>ss>report_writer_info_dirs>svfo_request
	contains a link to the report_writer_ save_format_options request's info segment

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - October 1984.

*/

report_writer_info_dirs_: proc;
%skip(1);
	report_writer_info_dir_data.standard_requests 
	     = ">doc>ss>report_writer_info_dirs>standard_requests";
	report_writer_info_dir_data.clv_request
	     = ">doc>ss>report_writer_info_dirs>clv_request";
	report_writer_info_dir_data.di_request
	     = ">doc>ss>report_writer_info_dirs>di_request";
	report_writer_info_dir_data.dib_request
	     = ">doc>ss>report_writer_info_dirs>dib_request";
	report_writer_info_dir_data.lsfo_request
	     = ">doc>ss>report_writer_info_dirs>lsfo_request";
	report_writer_info_dir_data.rsfo_request
	     = ">doc>ss>report_writer_info_dirs>rsfo_request";
	report_writer_info_dir_data.sfo_request
	     = ">doc>ss>report_writer_info_dirs>sfo_request";
	report_writer_info_dir_data.svfo_request
	     = ">doc>ss>report_writer_info_dirs>svfo_request";
%skip(1);
	cds_data.sections (1).p = addr (report_writer_info_dir_data);
	cds_data.sections (1).len = currentsize (report_writer_info_dir_data);
	cds_data.sections (1).struct_name = "report_writer_info_dir_data";
%skip(1);
	cds_data.sections (2).p = null;
	cds_data.sections (2).len = 0;
	cds_data.sections (2).struct_name = "";
%skip(1);
	cds_data.seg_name = REPORT_WRITER_INFO_DIRS_;
	cds_data.num_exclude_names = 0;
	cds_data.exclude_array_ptr = null;
%skip(1);
	unspec (cds_data.switches) = OFF;
	cds_data.switches.have_text = ON;
%skip(1);
	call create_data_segment_ (addr (cds_data), code);
	if code ^= 0 then
	call com_err_ (code, REPORT_WRITER_INFO_DIRS_);
%skip(1);
	return;
%page;
dcl OFF bit (1) aligned internal static options (constant) init ("0"b);
dcl ON bit (1) aligned internal static options (constant) init ("1"b);
%skip(1);
dcl REPORT_WRITER_INFO_DIRS_ char (32) internal static options (constant) init ("report_writer_info_dirs_");
%skip(1);
dcl addr builtin;
%skip(1);
dcl 1 cds_data aligned like cds_args;
dcl code fixed bin (35);
dcl com_err_ entry() options(variable);
dcl create_data_segment_ entry (ptr, fixed bin(35));
dcl currentsize builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl 1 report_writer_info_dir_data aligned,
      2 standard_requests char (168),
      2 clv_request char (168),
      2 di_request char (168),
      2 dib_request char (168),
      2 lsfo_request char (168),
      2 rsfo_request char (168),
      2 sfo_request char (168),
      2 svfo_request char (168);
%skip(1);
dcl unspec builtin;
%page;
%include cds_args;
%skip(3);
     end report_writer_info_dirs_;




		    report_writer_request_table_.alm11/05/86  1302.0r w 11/04/86  1038.1       28080



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1984 *
" *                                                         *
" ***********************************************************
"
" report_writer_ Request Table.
"
" When the next request is added to report_writer_, it should be entered
" into the standard_requests request table, and also have its own request
" table. For example, if the request foo was added, it should also have a
" foo_request request table. This same philosophy should be duplicated
" when a request is deleted.
"
" Written - Al Dupuis - October 1984


	include 	ssu_request_macros

	name 	report_writer_request_table_

	begin_table standard_requests

	request	column_value,
		 rw_requests$column_value,
		 (clv),
		 (Return the value of a specified column.),
		 flags.allow_af

	request	display,
		 rw_requests$display,
		 (di),
		 (Retrieve data and produce a formatted report.),
		 flags.allow_command

	request	display_builtins,
		 rw_requests$display_builtins,
		 (dib),
		 (Return the value of a display builtin.),
		 flags.allow_af

	request	list_format_options,
		 rw_requests$list_format_options,
		 (lsfo),
		 (List formatting option values.),
		 flags.allow_both

	request   restore_format_options,
	           rw_requests$restore_format_options,
		 (rsfo),
		 (Restore formatting option values.),
		 flags.allow_command

	request	save_format_options,
	           rw_requests$save_format_options,
		 (svfo),
		 (Save formatting option values.),
		 flags.allow_command

	request	set_format_options,
		 rw_requests$set_format_options,
		 (sfo),
		 (Set formatting option values.),
		 flags.allow_command

	end_table	standard_requests

	begin_table clv_request

	request	column_value,
		 rw_requests$column_value,
		 (clv),
		 (Return the value of a specified column.),
		 flags.allow_af

	end_table clv_request

	begin_table di_request

	request	display,
		 rw_requests$display,
		 (di),
		 (Retrieve data and produce a formatted report.),
		 flags.allow_command

	end_table di_request

	begin_table dib_request

	request	display_builtins,
		 rw_requests$display_builtins,
		 (dib),
		 (Return the value of a display builtin.),
		 flags.allow_af

	end_table dib_request

	begin_table lsfo_request

	request	list_format_options,
		 rw_requests$list_format_options,
		 (lsfo),
		 (List formatting option values.),
		 flags.allow_both

	end_table lsfo_request

	begin_table rsfo_request

	request   restore_format_options,
	           rw_requests$restore_format_options,
		 (rsfo),
		 (Restore formatting option values.),
		 flags.allow_command

	end_table rsfo_request

	begin_table svfo_request

	request	save_format_options,
	           rw_requests$save_format_options,
		 (svfo),
		 (Save formatting option values.),
		 flags.allow_command

	end_table svfo_request

	begin_table sfo_request

	request	set_format_options,
		 rw_requests$set_format_options,
		 (sfo),
		 (Set formatting option values.),
		 flags.allow_command

	end_table sfo_request

	end




		    rw_column_value.pl1             11/16/84  1355.7rew 11/16/84  1354.2       85806



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the main level procedure called by ssu_ to implement the
     report_writer_ column_value request. Description and usage follows.

     Description:

     This active request returns the value of the current column, the
     previous column, or the next column. The column is named by the
     caller. If subtotals or totals are being generated, the subtotal
     or total for the referenced column is returned.
     
     Usage: "column_value STR {-control_args}"

     where STR is the name or number of the desired column.

     -control_args can be "-current_row", "-next_row", "-previous_row",
     or "-default STR".

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_. 

*/
%page;
rw_column_value: proc (

	sci_ptr_parm,    /* input: ptr to the ssu_ info structure */
	report_cip_parm  /* input: points to report_control_info */
		     );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
	call initialize;
	call verify_column_name_or_number;
	if status.flags.subtotals_ejection_in_progress
	then call get_subtotal_value;
	else if status.flags.totals_ejection_in_progress
	     then call get_total_value;
	     else call get_column_value;
%skip(1);
	spare_string_length = length (spare_string);
	spare_string_redefined_ptr = addrel (addr (spare_string), 1);
	return_value = requote_string_ (spare_string_redefined_as_nonvarying);
%skip(1);
	return;
%page;
get_column_value: proc;
%skip(3);
	if (status.flags.first_row_of_report & previous_row)
	| (status.flags.last_row_of_report & next_row)
	then do;
	     spare_string = default_return_value;
	     return;
	end;
%skip(1);
	if previous_row
	then the_row_value_ptr = status.previous_row_ptr;
	else if next_row
	     then the_row_value_ptr = status.next_row_ptr;
	     else the_row_value_ptr = status.current_row_ptr;
%skip(1);
	spare_string = substr (the_row_value,
	     table_info.columns.column_index (column_number),
	     table_info.columns.column_length (column_number));
%skip(1);
	return;
%skip(1);
     end get_column_value;
%page;
get_subtotal_value: proc;
%skip(3);
	not_found = ON;
	subtotal_ip = format_report_info.subtotal_info_ptr;
%skip(1);
	do loop = 1 to subtotal_info.number_of_columns_to_subtotal
	     while (not_found);
	     if column_number = subtotal_info.columns (loop).input_column
	     & subtotal_info.columns (loop).level = subtotal_info.current_level
	     then do;
		not_found = OFF;
		subtotal_number = loop;
	     end;
	end;
	if not_found
	then do;
	     call get_column_value;
	     return;
	end;
%skip(1);
	call ioa_$rsnnl (subtotal_info.columns.ioa_string (subtotal_number),
	     spare_string, spare_string_length,
	     subtotal_info.columns.subtotal (subtotal_number));
%skip(1);
	return;
%skip(1);
     end get_subtotal_value;
%page;
get_total_value: proc;
%skip(3);
	not_found = ON;
	total_ip = format_report_info.total_info_ptr;
%skip(1);
	do loop = 1 to total_info.number_of_columns_to_total
	     while (not_found);
	     if column_number = total_info.input_column (loop)
	     then do;
		not_found = OFF;
		total_number = loop;
	     end;
	end;
	if not_found
	then do;
	     call get_column_value;
	     return;
	end;
%skip(1);
	call ioa_$rsnnl (total_info.columns.ioa_string (total_number),
	     spare_string, spare_string_length,
	     total_info.columns.total (total_number));
%skip(1);
	return;
%skip(1);
     end get_total_value;
%page;
initialize: proc;
%skip(3);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
	next_row = OFF;
	previous_row = OFF;
	current_row = ON;
	default_return_value = "";
%skip(1);
	call ssu_$return_arg (sci_ptr, number_of_args_supplied,
	     active_request_flag, return_value_ptr, return_value_length);
	if number_of_args_supplied = 0
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
	     "A column name or number must be supplied.");
%skip(1);
	if report_cip = null ()
	then call ssu_$abort_line (sci_ptr, rw_error_$no_report);
	else if ^report_control_info.flags.report_has_been_started
	     then call ssu_$abort_line (sci_ptr, rw_error_$no_report);
%skip(1);
	format_report_ip = report_control_info.format_report_info_ptr;
	table_ip = format_report_info.table_info_ptr;
	table_control_ip = report_control_info.table_control_info_ptr;
	table_segments_ip = table_control_info.table_segments_info_ptr;
	status_pointer = format_report_info.status_ptr;
%skip(1);
          call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length);
	column_identifier = arg;
%skip(1);
	if number_of_args_supplied = 1
	then return;
%page;
	current_arg_number = 2;
	still_processing_args = ON;
%skip(1);
	do loop = 2 to number_of_args_supplied
	     while (still_processing_args);
	     call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length);
	     if arg = "-current_row" | arg = "-crw"
	     then do;
		current_row = ON;
		previous_row = OFF;
		next_row = OFF;
	     end;
	     else if arg = "-next_row" | arg = "-nrw"
		then do;
		     next_row = ON;
		     current_row = OFF;
		     previous_row = OFF;
		end;
		else if arg = "-previous_row" | arg = "-prw"
		     then do;
			previous_row = ON;
			current_row = OFF;
			next_row = OFF;
		     end;
		     else if arg = "-default" | arg = "-df"
			then do;
			     if current_arg_number >= number_of_args_supplied
			     then call ssu_$abort_line (sci_ptr,
				error_table_$inconsistent,
				"-default must be followed by a value.");
			     else;
			     current_arg_number = current_arg_number + 1;
			     call ssu_$arg_ptr (sci_ptr, current_arg_number, 
				arg_ptr, arg_length);
			     default_return_value = arg;
			end;
			else call ssu_$abort_line (sci_ptr, 
			     error_table_$badopt,
			     "^a is not a valid control argument.", arg);
	     current_arg_number = current_arg_number + 1;
	     if current_arg_number > number_of_args_supplied
	     then still_processing_args = OFF;
	end;
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
verify_column_name_or_number: proc;
%skip(3);
          if verify (column_identifier, DIGITS) = 0
	then do;
	     column_number = convert (column_number, column_identifier);
	     if column_number < 1
	     | column_number > table_info.column_count
	     then call ssu_$abort_line (sci_ptr, 0,
		"^d is not a valid column number.", column_number);
	     else;
	end;
	else do;
	     not_found = ON;
	     do loop = 1 to table_info.column_count while (not_found);
		if column_identifier = table_info.columns.column_name (loop)
		then do;
		     not_found = OFF;
		     column_number = loop;
		end;
	     end;
	     if not_found
	     then call ssu_$abort_line (sci_ptr, 0,
		"^a is not a valid column name.", column_identifier);
	end;
%skip(1);
	return;
%skip(1);
     end verify_column_name_or_number;
%page;
dcl DIGITS char (10) static int options (constant) init ("0123456789");
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
%skip(1);
dcl active_request_flag bit (1) aligned;
dcl addr builtin;
dcl addrel builtin;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl column_number fixed bin;
dcl column_identifier char (128) varying;
dcl convert builtin;
dcl current_arg_number fixed bin;
dcl current_row bit (1) aligned;
%skip(1);
dcl default_return_value char (128) varying;
%skip(1);
dcl error_table_$badopt fixed bin(35) ext static;
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$noarg fixed bin(35) ext static;
%skip(1);
dcl ioa_$rsnnl entry() options(variable);
%skip(1);
dcl length builtin;
dcl loop fixed bin;
%skip(1);
dcl next_row bit (1) aligned;
dcl not_found bit (1) aligned;
dcl null builtin;
dcl number_of_args_supplied fixed bin;
%skip(1);
dcl previous_row bit (1) aligned;
%skip(1);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl return_value char (return_value_length) varying based (return_value_ptr);
dcl return_value_length fixed bin (21);
dcl return_value_ptr ptr;
dcl rw_error_$no_report fixed bin(35) ext static;
%skip(1);
dcl sci_ptr ptr;
dcl spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl spare_string_length fixed bin (21);
dcl spare_string_redefined_as_nonvarying char (spare_string_length) based (spare_string_redefined_ptr);
dcl spare_string_redefined_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21));
dcl still_processing_args bit (1) aligned;
dcl substr builtin;
dcl subtotal_number fixed bin;
%skip(1);
dcl the_row_value char (table_info.row_value_length) based (the_row_value_ptr);
dcl the_row_value_ptr ptr;
dcl total_number fixed bin;
%skip(1);
dcl verify builtin;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%page;
%include rw_table_info;
%page;
%include rw_table_control_info;
%skip(3);
     end rw_column_value;




		    rw_convert_and_move_row.pl1     10/24/88  1657.1r w 10/24/88  1400.3       56151



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This is the subroutine called by the subsystem's table manager procedure
     to have a row converted from other data types to character format, and
     moved into the row value buffer.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - October 1984.

*/
%page;
rw_convert_and_move_row: proc (

	report_control_ip_parm,	/* input: points to report_control_info */
	value_ptrs_parm		/* input: an array of value ptrs */
			     );
%skip(1);
dcl report_control_ip_parm ptr parm;
dcl value_ptrs_parm (*) ptr;
%skip(1);
	report_cip = report_control_ip_parm;
%skip(1);
	call initialize;
	call convert_the_row;
%skip(1);
	return;
%page;
convert_the_row: proc;
%skip(1);
dcl ctr_column_value char (table_info.columns (ctr_loop).column_length) based;
dcl ctr_loop fixed bin;
dcl ctr_row_value char (table_info.row_value_length) based (table_info.row_value_ptr);
%skip(1);
	do ctr_loop = 1 to table_info.column_count;
	     character_descriptor_overlay.size
		= table_info.columns (ctr_loop).column_length;
	     if table_info.columns (ctr_loop).column_data_type = character_descriptor
	     then substr (ctr_row_value,
		table_info.columns (ctr_loop).column_index,
		table_info.columns (ctr_loop).column_length)
		= value_ptrs_parm (ctr_loop) -> ctr_column_value;
	     else do;
		source_arg_descriptor_ptr
		     = addr (table_info.columns.column_data_type (ctr_loop));
		string_data_class
		     = ((source_arg_descriptor.type = bit_dtype)
		     | (source_arg_descriptor.type = varying_bit_dtype)
		     | (source_arg_descriptor.type = char_dtype)
		     | (source_arg_descriptor.type = varying_char_dtype));
		if string_data_class
		then source_length = source_arg_descriptor.size;
		else do;
		     encoded_precision_ptr -> encoded_precision.scale
			= source_fixed_arg_descriptor.scale;
		     encoded_precision_ptr -> encoded_precision.prec
			= source_fixed_arg_descriptor.precision;
		end;
		source_ptr = value_ptrs_parm (ctr_loop);
		on any_other call handle_conditions;
		call assign_$assign_round_ (
		     addr (row_value_as_an_array (table_info.columns (ctr_loop).column_index)),
		     2 * character_descriptor_overlay.type + fixed (character_descriptor_overlay.packed),
		     fixed (character_descriptor_overlay.size, 35),
		     source_ptr,
		     2 * source_arg_descriptor.type + fixed (source_arg_descriptor.packed),
		     source_length);
	     end;
	end;
%skip(1);
	return;
%page;
handle_conditions: proc;
%skip(1);
dcl 1 hc_condition_info like condition_info;
dcl hc_loop fixed bin;
%skip(1);
/*
     These conditions defined in CONDITION_NAMES are the same ones that the
     mrds module mu_convert.pl1 handles. The thinking is that it has been
     out there for several releases handling conversions of the same data 
     types, so these must be the correct conditions to handle.
*/
%skip(1);
	condition_info_ptr = addr (hc_condition_info);
	unspec (condition_info) = OFF;
	condition_info.version = condition_info_version_1;
	call find_condition_info_ (null, condition_info_ptr, (0));
%skip(1);
	do hc_loop = 1 to hbound (CONDITION_NAMES, 1);
	     if condition_info.condition_name = CONDITION_NAMES (hc_loop)
	     then call ssu_$abort_line (sci_ptr, error_table_$unexpected_condition,
		"^/The ^a condition occurred while trying to convert the^/^a column value.",
		CONDITION_NAMES (hc_loop), table_info.columns (ctr_loop).column_name);
	end;
%skip(1);
	call continue_to_signal_ ((0));
%skip(1);
	return;
%skip(1);
     end handle_conditions;
%skip(1);
     end convert_the_row;
%page;
initialize: proc;
%skip(1);
	table_ip = report_control_info.table_information_ptr;
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	encoded_precision_ptr = addr (source_length);
	row_value_as_an_array_ptr = table_info.row_value_ptr;
	character_descriptor_overlay_ptr = addr (character_descriptor);
	character_descriptor_overlay.flag = "1"b;
	character_descriptor_overlay.type = char_dtype;
	character_descriptor_overlay.packed = "1"b;
	character_descriptor_overlay.number_dims = 0;
	character_descriptor_overlay.size = 0;
%skip(1);
	return;
%skip(1);
     end initialize;
%page;
dcl CONDITION_NAMES (7) char (32) varying internal static options (constant) init (
"conversion", "error", "fixedoverflow", "illegal_procedure",
"overflow", "size", "underflow");
%skip(1);
dcl OFF bit (1) aligned internal static options (constant) init ("0"b);
%skip(1);
dcl addr builtin;
dcl any_other condition;
dcl assign_$assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
%skip(1);
dcl character_descriptor bit (36) aligned;
dcl 1 character_descriptor_overlay like arg_descriptor based (character_descriptor_overlay_ptr);
dcl character_descriptor_overlay_ptr ptr;
dcl continue_to_signal_ entry (fixed bin(35));
%skip(1);
dcl encoded_precision_ptr ptr;
dcl error_table_$unexpected_condition fixed bin(35) ext static;
%skip(1);
dcl find_condition_info_ entry (ptr, ptr, fixed bin(35));
dcl fixed builtin;
%skip(1);
dcl hbound builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl row_value_as_an_array (table_info.row_value_length) char (1) based (row_value_as_an_array_ptr);
dcl row_value_as_an_array_ptr ptr;
%skip(1);
dcl sci_ptr ptr;
dcl 1 source_arg_descriptor like arg_descriptor based (source_arg_descriptor_ptr);
dcl source_arg_descriptor_ptr ptr;
dcl 1 source_fixed_arg_descriptor like fixed_arg_descriptor based (source_arg_descriptor_ptr);
dcl source_length fixed bin (35);
dcl source_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl string_data_class bit (1) aligned;
dcl substr builtin;
%skip(1);
dcl unspec builtin;
%page;
%include arg_descriptor;
%page;
%include condition_info;
%page;
%include encoded_precision;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_table_info;
%page;
%include std_descriptor_types;
%skip(3);
     end rw_convert_and_move_row;




		    rw_define_columns.pl1           10/24/88  1657.1r w 10/24/88  1400.3      116892



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the subroutine called by Multics subsystems to define
     a set of columns for report_writer_.

     Description:

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - October 1984.

*/
%page;
rw_define_columns: proc (

	report_control_ip_parm,	/* input: points to report_control_info */
	row_info_ptr_parm,            /* input: points to row_info */
	code_parm,		/* output: success or failure */
	message_parm		/* output: reason for the failure */
			     );
%skip(1);
dcl code_parm fixed bin (35) parm;
dcl message_parm char (*) varying parm;
dcl report_control_ip_parm ptr parm;
dcl row_info_ptr_parm ptr parm;
%skip(1);
	report_cip = report_control_ip_parm;
	row_info_ptr = row_info_ptr_parm;
	code_parm = 0;
	message_parm = "";
%skip(1);
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	work_area_ptr = report_control_info.general_work_area_ptr;
	column_print_lengths_ptr = null;
	table_ip = null;
	cleanup_has_been_signalled = OFF;
	on cleanup begin;
	     cleanup_has_been_signalled = ON;
	     call cleanup_allocated_things;
	end;
%skip(1);
	if row_info_ptr ^= null
	then do;
	     call check_row_info_validity (code_parm, message_parm);
	     if code_parm = 0
	     then call fill_in_row_info (code_parm, message_parm);
	     if code_parm ^= 0
	     then return;
	     call allocate_table_info;
	end;
%skip(1);
	if report_control_info.table_information_ptr ^= null
	then do;
	     free report_control_info.table_information_ptr -> table_info;
	     report_control_info.table_information_ptr = null;
	end;
	report_control_info.table_information_ptr = table_ip;
%skip(1);
	call rw_options$define_new_column_options (report_cip);
	call cleanup_allocated_things;
%skip(1);
	return;
%page;
allocate_table_info: proc;
%skip(1);
dcl ati_loop fixed bin;
%skip(1);
	ti_init_column_count = row_info.number_of_columns;
%skip(1);
	allocate table_info in (work_area) set (table_ip);
	table_info.version = TABLE_INFO_VERSION_1;
	table_info.maximum_column_name_length = the_maximum_column_name_length;
	table_info.maximum_column_value_length = the_maximum_column_value_length;
	table_info.row_value_length = row_info.value_length;
	table_info.row_value_ptr = row_info.value_ptr;
%skip(1);
	do ati_loop = 1 to ti_init_column_count;
	     table_info.columns (ati_loop).column_name
		= row_info.column (ati_loop).names;
	     table_info.columns (ati_loop).column_data_type
		= row_info.column (ati_loop).descriptors;
	     table_info.columns (ati_loop).column_length
		= row_info.column (ati_loop).lengths;
	     table_info.columns (ati_loop).column_index
		= row_info.column (ati_loop).indexes;
	end;
%skip(1);
	return;
%skip(1);
     end allocate_table_info;
%page;
check_row_info_validity: proc (

	criv_code_parm,	/* output: success or failure */
	criv_message_parm	/* output: reason for the failure */
			);
%skip(1);
dcl criv_code_parm fixed bin (35) parm;
dcl criv_loop fixed bin;
dcl criv_message_parm char (*) varying parm;
dcl criv_valid_data_type bit (1) aligned;
%skip(1);
	criv_code_parm = 0;
	criv_message_parm = "";
%skip(1);
	if row_info.version ^= ROW_INFO_VERSION_1
	then do;
	     criv_code_parm = error_table_$unimplemented_version;
	     call ioa_$rsnnl (
		"^/The row_info structure version number was ^a instead of ^a.",
		criv_message_parm, (0), row_info.version, ROW_INFO_VERSION_1);
	     return;
	end;
%skip(1);
	if row_info.number_of_columns ^> 0
	then do;
	     criv_code_parm = error_table_$improper_data_format;
	     call ioa_$rsnnl (
		"The number of columns supplied was ^d instead of a positive integer.",
		criv_message_parm, (0), row_info.number_of_columns);
	     return;
	end;
	the_maximum_column_name_length = 0;
	criv_code_parm = error_table_$improper_data_format;
%skip(1);
	do criv_loop = 1 to row_info.number_of_columns;
	     row_info.column (criv_loop).names = rtrim (row_info.column (criv_loop).names);
	     if index (row_info.column (criv_loop).names, BLANK_OR_TAB) ^= 0
	     then do;
		call ioa_$rsnnl (
		     "^/The column name ""^a"" contained blanks or tabs.",
		     criv_message_parm, (0), row_info.column (criv_loop).names);
		return;
	     end;
	     the_current_column_name_length = length (row_info.column (criv_loop).names);
	     if the_current_column_name_length > the_maximum_column_name_length
	     then the_maximum_column_name_length = the_current_column_name_length;
	     arg_descriptor_ptr = addr (row_info.column (criv_loop).descriptors);
	     if arg_descriptor_ptr -> bit_36_aligned = OFF
	     then if row_info.column (criv_loop).lengths ^> 0
		then call ioa_$rsnnl (
		     "^/The descriptor for ^a was zero and it's length field wasn't a positive integer.",
		     criv_message_parm, (0), row_info.column (criv_loop).names);
	          else if row_info.column (criv_loop).lengths ^< sys_info$max_seg_size * 4 + 1
		     then call ioa_$rsnnl (
		          "^/The descriptor for ^a was zero and it's length field was^/larger than the maximum Multics segment size.",
		          criv_message_parm, (0), row_info.column (criv_loop).names);
		     else criv_valid_data_type = ON;
	     else criv_valid_data_type = (arg_descriptor.type = real_fix_bin_1_dtype)
		| (arg_descriptor.type = real_fix_bin_2_dtype)
		| (arg_descriptor.type = real_flt_bin_1_dtype)
		| (arg_descriptor.type = real_flt_bin_2_dtype)
		| (arg_descriptor.type = cplx_fix_bin_1_dtype)
		| (arg_descriptor.type = cplx_fix_bin_2_dtype)
		| (arg_descriptor.type = cplx_flt_bin_1_dtype)
		| (arg_descriptor.type = cplx_flt_bin_2_dtype)
		| (arg_descriptor.type = real_fix_dec_9bit_ls_dtype)
		| (arg_descriptor.type = real_flt_dec_9bit_dtype)
		| (arg_descriptor.type = cplx_fix_dec_9bit_ls_dtype)
		| (arg_descriptor.type = cplx_flt_dec_9bit_dtype)
		| (arg_descriptor.type = bit_dtype)
		| (arg_descriptor.type = varying_bit_dtype)
		| (arg_descriptor.type = char_dtype)
		| (arg_descriptor.type = varying_char_dtype)
		| (arg_descriptor.type = real_fix_dec_9bit_ls_overp_dtype)
		| (arg_descriptor.type = real_fix_dec_9bit_ts_overp_dtype)
		| (arg_descriptor.type = real_fix_bin_1_uns_dtype)
		| (arg_descriptor.type = real_fix_bin_2_uns_dtype)
		| (arg_descriptor.type = real_fix_dec_9bit_uns_dtype)
		| (arg_descriptor.type = real_fix_dec_9bit_ts_dtype)
		| (arg_descriptor.type = real_fix_dec_4bit_uns_dtype)
		| (arg_descriptor.type = real_fix_dec_4bit_ts_dtype)
		| (arg_descriptor.type = real_fix_dec_4bit_bytealigned_uns_dtype)
		| (arg_descriptor.type = real_fix_dec_4bit_ls_dtype)
		| (arg_descriptor.type = real_flt_dec_4bit_dtype)
		| (arg_descriptor.type = real_fix_dec_4bit_bytealigned_ls_dtype)
		| (arg_descriptor.type = real_flt_dec_4bit_bytealigned_dtype)
		| (arg_descriptor.type = cplx_fix_dec_4bit_bytealigned_ls_dtype)
		| (arg_descriptor.type = cplx_flt_dec_4bit_bytealigned_dtype);
	     if criv_message_parm ^= ""
	     then return;
	     else if ^criv_valid_data_type
		then do;
		     call ioa_$rsnnl (
			"^/The descriptor ""^w"" for the ^a column isn't supported.",
			criv_message_parm, (0), row_info.column (criv_loop).descriptors,
			row_info.column (criv_loop).names);
		     return;
		end;
		else;
	end;
	criv_code_parm = 0;
%skip(1);
	return;
%skip(1);
     end check_row_info_validity;
%page;
cleanup_allocated_things: proc;
%skip(1);
	if column_print_lengths_ptr ^= null
	then free column_print_lengths;
%skip(1);
	if cleanup_has_been_signalled
	then do;
	     if table_ip ^= null
	     then free table_info;
	     report_control_info.table_information_ptr = null;
	end;
%skip(1);
	return;
%skip(1);
     end cleanup_allocated_things;
%page;
fill_in_row_info: proc (

	firi_code_parm,	/* output: success or failure */
	firi_message_parm	/* output: reason for the failure */
		   );
%skip(1);
dcl firi_code_parm fixed bin (35) parm;
dcl firi_current_index_position fixed bin (21);
dcl firi_loop fixed bin;
dcl firi_message_parm char (*) varying parm;
%skip(1);
	firi_code_parm = 0;
	firi_message_parm = "";
%skip(1);
	allocate column_print_lengths in (work_area)
	     set (column_print_lengths_ptr);
	the_maximum_column_value_length = 0;
	firi_current_index_position = 1;
%skip(1);
	do firi_loop = 1 to row_info.number_of_columns;
	     arg_descriptor_ptr = addr (row_info.column (firi_loop).descriptors);
	     if arg_descriptor_ptr -> bit_36_aligned = OFF
	     then do;
		column_print_lengths (firi_loop) = row_info.column (firi_loop).lengths;
		arg_descriptor.flag = ON;
		arg_descriptor.type = char_dtype;
		arg_descriptor.packed = ON;
		arg_descriptor.number_dims = 0;
		arg_descriptor.size = column_print_lengths (firi_loop);
	     end;
	     else do;
		if mdbm_util_$binary_data_class (arg_descriptor_ptr)
		then column_print_lengths (firi_loop) = divide (fixed_arg_descriptor.precision, 3, 21) + 5;
		else if mdbm_util_$number_data_class (arg_descriptor_ptr)
		     then column_print_lengths (firi_loop) = fixed_arg_descriptor.precision + 3;
		     else if mdbm_util_$string_data_class (arg_descriptor_ptr)
			then column_print_lengths (firi_loop) = arg_descriptor.size;
		          else column_print_lengths (firi_loop) = 20;
		if mdbm_util_$number_data_class (arg_descriptor_ptr) 
		then if mdbm_util_$fixed_data_class (arg_descriptor_ptr) 
		     then if (fixed_arg_descriptor.scale < 0)
			| (fixed_arg_descriptor.scale > 0 & fixed_arg_descriptor.precision < fixed_arg_descriptor.scale)
			then column_print_lengths (firi_loop) = column_print_lengths (firi_loop)
		               + ceil (log10 (abs (fixed_arg_descriptor.scale)));
			else;
		     else column_print_lengths (firi_loop) = column_print_lengths (firi_loop) + 5;
		else;
		if mdbm_util_$complex_data_class (arg_descriptor_ptr) 
		then column_print_lengths (firi_loop) = column_print_lengths (firi_loop) * 2;
	     end;
	     row_info.column (firi_loop).indexes = firi_current_index_position;
	     row_info.column (firi_loop).lengths = column_print_lengths (firi_loop);
	     firi_current_index_position = firi_current_index_position + column_print_lengths (firi_loop);
	     if column_print_lengths (firi_loop) > the_maximum_column_value_length
	     then the_maximum_column_value_length = column_print_lengths (firi_loop);
	end;
%skip(1);
	the_row_value_length = sum (column_print_lengths);
	if the_row_value_length > sys_info$max_seg_size * 4
	then do;
	     firi_code_parm = error_table_$improper_data_format;
	     call ioa_$rsnnl (
		"^/The ^d character length of the row exceeded one segment.",
		firi_message_parm, (0), the_row_value_length);
	     return;
	end;
%skip(1);
	row_info.value_ptr = report_control_info.row_value_temp_segment_ptr;
	row_info.value_length = the_row_value_length;
	row_info.current_column_number = 0;
%skip(1);
	return;
%skip(1);
     end fill_in_row_info;
%page;
dcl BLANK_OR_TAB char (2) internal static options (constant) init (" 	");
%skip(1);
dcl OFF bit (1) aligned internal static options (constant) init ("0"b);
dcl ON bit (1) aligned internal static options (constant) init ("1"b);
%skip(1);
dcl abs builtin;
dcl addr builtin;
%skip(1);
dcl bit_36_aligned bit (36) aligned based;
%skip(1);
dcl ceil builtin;
dcl cleanup condition;
dcl cleanup_has_been_signalled bit (1) aligned;
dcl column_print_lengths (row_info.number_of_columns) fixed bin (21) based (column_print_lengths_ptr);
dcl column_print_lengths_ptr ptr;
%skip(1);
dcl divide builtin;
%skip(1);
dcl error_table_$improper_data_format fixed bin(35) ext static;
dcl error_table_$unimplemented_version fixed bin(35) ext static;
%skip(1);
dcl index builtin;
dcl ioa_$rsnnl entry() options(variable);
%skip(1);
dcl length builtin;
dcl log10 builtin;
%skip(1);
dcl mdbm_util_$binary_data_class entry (ptr) returns(bit(1) aligned);
dcl mdbm_util_$complex_data_class entry (ptr) returns(bit(1) aligned);
dcl mdbm_util_$fixed_data_class entry (ptr) returns(bit(1) aligned);
dcl mdbm_util_$number_data_class entry (ptr) returns(bit(1) aligned);
dcl mdbm_util_$string_data_class entry (ptr) returns(bit(1) aligned);
%skip(1);
dcl null builtin;
%skip(1);
dcl rtrim builtin;
dcl rw_options$define_new_column_options entry (ptr);
%skip(1);
dcl sci_ptr ptr;
dcl sum builtin;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl the_current_column_name_length fixed bin;
dcl the_row_value_length fixed bin (21);
dcl the_maximum_column_name_length fixed bin;
dcl the_maximum_column_value_length fixed bin (21);
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include arg_descriptor;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_row_info;
%page;
%include rw_table_info;
%page;
%include std_descriptor_types;
%skip(3);
     end rw_define_columns;




		    rw_display.pl1                  11/16/84  1355.8rew 11/16/84  1354.2      300519



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the main level procedure called by ssu_ to implement the
     report writer display request. Description and usage follows.

     Description: This request takes far too many control arguments to
     list here (currently it accepts 55). See the info segment for details
     on the accepted control arguments and usage.
     
     Usage:

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_display: proc (

	sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
	report_cip_parm /* input: points to report_control_info */
	       );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
/*
	Mainline Processing Overview.

	(1) Make sure the format options are up to date and that there is
	    data to create a report from.

	(2) Have the subroutine rw_display_process_args fill in the
	    default control args and update the defaults with arguments
	    supplied on the request line.

	(3) Delete existing report and table if appropriate, start new ones
	    if appropriate, possibly sort the table, setup for multi-pass
	    mode if appropriate.

	(4) Setup any output file, output switch, or the video system
	    depending on what control arguments were given.

	(5) Print, scroll, or page the report.

	(6) Perform termination as instructed by the control args.

*/
%page;
	arguments_have_been_processed = OFF;
	cleanup_signalled = OFF;
%skip(1);
          on cleanup begin;
	     cleanup_signalled = ON;
	     call terminate;
	end;
%skip(1);
	call initialize;
	call rw_display_process_args (report_cip, work_area_ptr, 
	     table_ip, addr (display_arg_results));
	arguments_have_been_processed = ON;
	call fill_in_the_defaults;
%skip(1);
	call setup_io_switches;
%skip(1);
	if display_arg_results.scroll_flag
	then call scroll_the_report;
	else if display_arg_results.pages_flag
	     then call page_the_report;
	     else call print_report;
%skip(1);
	call terminate;
%skip(1);
          return;
%page;
begin_new_report: proc;
%skip(1);
	if display_arg_results.flags.keep_report_flag
	| display_arg_results.flags.scroll_flag
	then report_control_info.flags.permanent_report = ON;
	else report_control_info.flags.permanent_report = OFF;
%skip(1);
          if display_arg_results.time_flag
	then time1 = vclock;
%skip(1);
          call rw_fr_new_report (report_cip, code);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.report_setup_time = time2 - time1;
	     call ioa_$ioa_switch (iox_$error_output,
		"Time used to setup the report was ^10.5f seconds.",
		report_control_info.report_setup_time / 1000000);
	end;
%skip(1);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
	report_control_info.flags.report_has_been_started = ON;
	report_control_info.flags.report_is_formatted = OFF;
	report_control_info.flags.report_has_just_been_completed = OFF;
	report_control_info.report_identifier
	     = report_control_info.options_identifier;
	report_control_info.no_of_formatted_pages = 0;
	report_control_info.report_formatting_time = 0;
	report_control_info.report_display_time = 0;
	report_control_info.ssu_evaluate_active_string_time = 0;
%skip(1);
          return;
%skip(1);
     end begin_new_report;
%page;
begin_new_retrieval: proc;
%skip(1);
	if display_arg_results.keep_retrieval_flag
	| display_arg_results.sort_flag
	then report_control_info.permanent_table = ON;
	else report_control_info.permanent_table = OFF;
	report_control_info.flags.table_has_been_started = ON;
%skip(1);
          time1 = vclock;
          call rw_table_manager$create_table (report_cip, code);
	time2 = vclock;
	report_control_info.table_loading_time = time2 - time1;
%skip(1);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
	report_control_info.flags.table_is_full = OFF;
	report_control_info.flags.table_has_just_been_loaded = OFF;
	report_control_info.no_of_rows_retrieved = table_control_info.row_count;
%skip(1);
          return;
%skip(1);
     end begin_new_retrieval;
%page;
delete_report: proc;
%skip(1);
          if display_arg_results.time_flag
	then time1 = vclock;
%skip(1);
	call rw_fr_delete_report (report_cip, code);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.report_deletion_time = time2 - time1;
	     call ioa_$ioa_switch (iox_$error_output,
		"Time used to delete the report was ^10.5f seconds.",
		report_control_info.report_deletion_time / 1000000);
	end;
%skip(1);
	if code ^= 0
	then if cleanup_signalled
	     then call ssu_$print_message (sci_ptr, code);
	     else call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
	report_control_info.flags.report_has_been_started = OFF;
%skip(1);
          return;
%skip(1);
     end delete_report;
%page;
delete_table: proc;
%skip(1);
          if display_arg_results.time_flag
          then time1 = vclock;
%skip(1);
          call rw_table_manager$delete_table (report_cip, code);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.table_deletion_time = time2 - time1;
	     call ioa_$ioa_switch (iox_$error_output,
		"Time used to delete the table was ^10.5f seconds.",
		report_control_info.table_deletion_time / 1000000);
	end;
%skip(1);
	if code ^= 0
	then if cleanup_signalled
	     then call ssu_$print_message (sci_ptr, code);
	     else call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
	report_control_info.flags.table_has_been_started = OFF;
%skip(1);
          return;
%skip(1);
     end delete_table;
%page;
fill_in_the_defaults: proc;
%skip(1);
/*
          Delete the old table and old report if a new retrieval or report
          has been requested and it wasn't deleted on our last termination.
          The user may have asked for an existing table or report to be
          used when it isn't possible. Examples of this are: when there isn't
          an existing table; when invocations of the print, report, etc.
          requests have occured since we were last active; when there isn't
          an existing report; when the user has invoked the sfo request;
          etc. If this has happened then it is treated as if the user asked
          for a new report/table.
*/
%skip(3);
          if ^display_arg_results.new_retrieval_flag
	then do;
	     if ^report_control_info.flags.table_has_been_started
	     then do;
		if display_arg_results.long_flag
		then call ssu_$print_message (sci_ptr, 0,
		     "Warning: A new retrieval will be started.");
		display_arg_results.new_retrieval_flag = ON;
	     end;
	     else;
	end;
	else;
%skip(1);
          if display_arg_results.new_retrieval_flag 
	& report_control_info.flags.table_has_been_started
	then call delete_table;
%skip(1);
          if ^display_arg_results.new_report_flag
	then do;
	     if report_control_info.report_identifier
	     ^= report_control_info.options_identifier
	     | ^report_control_info.flags.report_has_been_started
	     | display_arg_results.new_retrieval_flag
	     then do;
		if display_arg_results.long_flag
		then call ssu_$print_message (sci_ptr, 0,
		     "Warning: A new report will be started.");
		display_arg_results.new_report_flag = ON;
	     end;
	     else;
	end;
	else;
%skip(1);
          if display_arg_results.new_report_flag 
	& report_control_info.flags.report_has_been_started
	then call delete_report;
%skip(1);
/* 

          Check for a new temp dir supplied by the user for placing the
          retrieved data table and formatted report.  We only allow a new
          temp_dir when we're about to create a new table and report, because
          the ptrs to the rows and formatted pages of existing reports and
          tables would be invalid.

*/
%skip(1);
          if display_arg_results.temp_dir_flag
	then do;
	     allocate status_branch in (work_area) set (status_ptr);
	     call expand_pathname_ (display_arg_results.temp_dir_pathname,
		directory_name, entry_name, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/While trying to expand the temp dir ^a.", 
		display_arg_results.temp_dir_pathname);
	     call hcs_$status_long (directory_name, entry_name, 1,
		status_ptr, null (), code);
	     if code ^= 0 & code ^= error_table_$no_s_permission
	     then call ssu_$abort_line (sci_ptr, code,
		"^/While trying to determine the unique id of ^a.",
		display_arg_results.temp_dir_pathname);
	     if display_arg_results.new_report_flag
	     & display_arg_results.new_retrieval_flag
	     then do;
		report_control_info.temp_dir_name
		     = display_arg_results.temp_dir_pathname;
		report_control_info.temp_dir_unique_id
		     = status_branch.long.uid;
	     end;
	     else if report_control_info.temp_dir_unique_id = status_branch.long.uid
		then;
	          else do;
		     if display_arg_results.long_flag
		     then call ssu_$print_message (sci_ptr, 0,
			"Warning: The temp_dir ^a won't be used.", 
			rtrim (display_arg_results.temp_dir_pathname));
		     display_arg_results.temp_dir_flag = OFF;
		end;
	end;
	else;
%page;
/*
	Check for multiple pass mode.
*/
%skip(1);
	if display_arg_results.flags.passes_flag
	then if ^display_arg_results.flags.new_report_flag 
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	          "^/The control argument -passes can only be used with a new report.");
	     else do;
		report_control_info.flags.multi_pass_mode = ON;
		report_control_info.number_of_passes = display_arg_results.number_of_passes;
	     end;
	else report_control_info.flags.multi_pass_mode = OFF;
/*
          Begin a new retrieval and report if appropriate.
*/
%skip(1);
          if display_arg_results.new_retrieval_flag
	then call begin_new_retrieval;
%skip(1);
          if display_arg_results.new_report_flag
	then call begin_new_report;
%skip(1);
/* 
          Sort the table if instructed.
*/
%skip(1);
          if display_arg_results.sort_flag
	then do;
	     if ^report_control_info.flags.table_is_full
	     then call load_the_entire_table;
	     if display_arg_results.time_flag
	     then time1 = vclock;
	     call rw_table_manager$sort (report_cip, 
		display_arg_results.sort_information_ptr, code);
	     if display_arg_results.time_flag
	     then do;
		time2 = vclock;
		report_control_info.table_sorting_time = time2 - time1;
		call ioa_$ioa_switch (iox_$error_output,
		     "Time used to sort the table was ^10.5f seconds.",
		     report_control_info.table_sorting_time / 1000000);
	     end;
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code);
	end;
%skip(1);
          return;
%skip(1);
     end fill_in_the_defaults;
%page;
format_page: proc;
%skip(3);
          if display_arg_results.time_flag
	then time1 = vclock;
	call rw_fr_build_page (report_cip, page_ip, code);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.report_formatting_time
		= report_control_info.report_formatting_time + (time2 - time1);
	end;
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
	if report_control_info.flags.report_has_just_been_completed
	then do;
	     report_control_info.flags.report_has_just_been_completed = OFF;
	     if display_arg_results.time_flag
	     then call ioa_$ioa_switch (iox_$error_output,
		"Time used to format the report was ^10.5f seconds."
		|| "^/(ssu_$evaluate_active_string used ^10.5f seconds of this time.)",
		report_control_info.report_formatting_time / 1000000,
		report_control_info.ssu_evaluate_active_string_time / 1000000);
	     else;
	end;
%skip(1);
	if report_control_info.flags.table_has_just_been_loaded
	then do;
	     report_control_info.flags.table_has_just_been_loaded = OFF;
	     if display_arg_results.time_flag
	     then call ioa_$ioa_switch (iox_$error_output,
		"Time used to load the table was ^10.5f seconds.",
		report_control_info.table_loading_time / 1000000);
	     else;
	end;
%skip(1);
	call format_page_or_get_page_extra_processing (report_control_info.no_of_formatted_pages);
%skip(1);
          return;
%skip(1);
     end format_page;
%page;
format_page_or_get_page_extra_processing: proc (

	fpgpep_page_number_parm /* input: number of page just got or formatted */
				    );
dcl fpgpep_page_number_parm fixed bin (21) parm;
%skip(3);
	if fpgpep_page_number_parm = 1
	then first_page_of_the_report = ON;
	else first_page_of_the_report = OFF;
%skip(1);
	if report_control_info.report_is_formatted
	& report_control_info.no_of_formatted_pages = fpgpep_page_number_parm
          then last_page_of_the_report = ON;
	else last_page_of_the_report = OFF;
%skip(1);
	if page_info.page_overstrike_info_ptr ^= null ()
	then do;
	     terminal_dependency = ON;
	     page_overstrike_ip = page_info.page_overstrike_info_ptr;
	end;
	else terminal_dependency = OFF;
%skip(1);
	return;
%skip(1);
     end format_page_or_get_page_extra_processing;
%page;
get_page: proc (target_page_parm);
%skip(1);
dcl target_page_parm fixed bin (21) parm;
%skip(3);
	call rw_fr_get_page (report_cip, target_page_parm, page_ip, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to get page ^d.", target_page_parm);
%skip(1);
	call format_page_or_get_page_extra_processing (target_page_parm);
%skip(1);
          return;
%skip(1);
     end get_page;
%page;
initialize: proc;
%skip(1);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
	display_arg_results.sort_information_ptr = null ();
	display_arg_results.scroll_info_ptr = null ();
%skip(1);
	/* Make sure that things are set up. */
%skip(1);
	table_ip = report_control_info.table_information_ptr;
	if table_ip = null
	then call ssu_$abort_line (sci_ptr, rw_error_$no_columns_defined);
%skip(1);
          /* Automatic versions of a few odds and sodds we will need. */
%skip(1);
	work_area_ptr = report_control_info.general_work_area_ptr;
	video_has_been_set_up = OFF;
	table_control_ip = report_control_info.table_control_info_ptr;
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
load_the_entire_table: proc;
%skip(3);
          if display_arg_results.time_flag
	then time1 = vclock;
%skip(1);
	call rw_table_manager$load_table (report_cip, code);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.table_loading_time
		= report_control_info.table_loading_time + (time2 - time1);
	     call ioa_$ioa_switch (iox_$error_output,
		"Time used to load the table was ^10.5f seconds.",
		report_control_info.table_loading_time / 1000000);
	end;
	if code ^= 0
	then if code = error_table_$end_of_info
	     then;
	     else call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
          report_control_info.flags.table_is_full = ON;
	report_control_info.no_of_rows_retrieved = table_control_info.row_count;
%skip(1);
          return;
%skip(1);
     end load_the_entire_table;
%page;
page_the_report: proc;
%skip(1);
dcl ptr_current_page_number fixed bin (21);
dcl ptr_specified_pages_as_a_string bit (NUMBER_OF_ALLOWED_SPECIFIED_PAGES) based (ptr_specified_pages_as_a_string_ptr);
dcl ptr_specified_pages_as_a_string_ptr ptr;
dcl ptr_still_paging bit (1) aligned;
%skip(3);
	if ^report_control_info.report_is_paginated
	then do;
	     call print_report;
	     return;
	end;
%skip(1);
	report_control_info.report_display_time = 0;
	ptr_specified_pages_as_a_string_ptr = addr (display_arg_results.specified_pages (1));
	ptr_current_page_number = 1;
	ptr_still_paging = ON;
%skip(1);
	do while (ptr_still_paging);
%skip(1);
	     if ptr_current_page_number > report_control_info.no_of_formatted_pages
	     then call format_page;
	     else if display_arg_results.specified_pages (ptr_current_page_number)
		then call get_page (ptr_current_page_number);
	          else;
%skip(1);
	     if display_arg_results.specified_pages (ptr_current_page_number)
	     then call print_page;
%skip(1);
	     if ^display_arg_results.last_page_flag
	     then if index (substr (ptr_specified_pages_as_a_string, ptr_current_page_number + 1), ON) = 0
		then ptr_still_paging = OFF;
	          else ptr_current_page_number = ptr_current_page_number + 1;
	     else ptr_current_page_number = ptr_current_page_number + 1;
%skip(1);
	     if report_control_info.report_is_formatted
	     & ptr_current_page_number > report_control_info.no_of_formatted_pages
	     then ptr_still_paging = OFF;
%skip(1);
	end;
%page;
	if display_arg_results.last_page_flag
	then if ^display_arg_results.specified_pages (report_control_info.no_of_formatted_pages)
	     then do;
		if ^display_arg_results.new_report_flag
		then call get_page (report_control_info.no_of_formatted_pages);
		else;
		call print_page;
	     end;
	     else;
	else;
%skip(1);
	if display_arg_results.flags.time_flag
	then call ioa_$ioa_switch (iox_$error_output,
	     "Time used to display the report was ^10.5f seconds.",
	     report_control_info.report_display_time / 1000000);
%skip(1);
	return;
%skip(1);
     end page_the_report;
%page;
print_page: proc;
%skip(1);
dcl pp_chunk_of_line char (pp_number_of_chars) based (pp_chunk_of_line_ptr);
dcl pp_chunk_of_line_ptr ptr;
dcl pp_code fixed bin (35);
dcl pp_ioa_string char (4);
dcl pp_left_margin fixed bin;
dcl pp_loop fixed bin;
dcl pp_loop_limit fixed bin;
dcl pp_number_of_chars fixed bin;
dcl pp_overstrike_index fixed bin;
dcl pp_right_margin fixed bin;
%skip(3);
	if display_arg_results.time_flag
	then time1 = vclock;
%skip(1);
	if ^display_arg_results.output_file_flag
	then if report_control_info.report_is_paginated
	     | first_page_of_the_report
	     then call ioa_$ioa_switch_nnl (
	          report_control_info.display_iocb_ptr, "^3/");
	     else;
	else;
%skip(1);
	if ^display_arg_results.character_positions_flag & ^terminal_dependency
	then do;
	     call iox_$put_chars (report_control_info.display_iocb_ptr,
		page_info.page_ptr, page_info.total_characters, pp_code);
	     if pp_code ^= 0
	     then call ssu_$abort_line (sci_ptr, pp_code);
	end;
	else do;
	     if display_arg_results.character_positions_flag
	     then do;
		pp_right_margin = display_arg_results.right_margin_position;
		pp_left_margin = display_arg_results.left_margin_position;
		if pp_left_margin < 1
		then pp_left_margin = 1;
		if pp_right_margin >= page_info.width
		then pp_right_margin = page_info.width - 1;
	     end;
	     else do;
		pp_right_margin = page_info.width - 1;
		pp_left_margin = 1;
	     end;
	     pp_number_of_chars = pp_right_margin - pp_left_margin + 1;
	     if pp_number_of_chars ^> 0
	     then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_display,
		"The specified character positions result in no characters being printed.");
	     pp_loop_limit = page_info.length - 1;
	     do pp_loop = 1 to pp_loop_limit;
		pp_overstrike_index = ((pp_loop - 1) * page_info.width) + pp_left_margin;
		pp_chunk_of_line_ptr = addr (page_defined_as_chars (pp_overstrike_index));
		if terminal_dependency
		& index (substr (page_overstrike_info_redefined.bit_map, pp_overstrike_index, pp_number_of_chars), ON) ^= 0
		then call make_terminal_dependent_string;
		call ioa_$ioa_switch (report_control_info.display_iocb_ptr,
		     "^a", pp_chunk_of_line);
		if terminal_dependency
		then pp_number_of_chars = pp_right_margin - pp_left_margin + 1;
	     end;
	     pp_overstrike_index = (pp_loop_limit * page_info.width) + pp_left_margin;
	     pp_chunk_of_line_ptr = addr (page_defined_as_chars (pp_overstrike_index));
	     if report_control_info.report_is_paginated | last_page_of_the_report
	     then pp_ioa_string = "^a^|";
	     else pp_ioa_string = "^a^/";
	     if terminal_dependency
	     & index (substr (page_overstrike_info_redefined.bit_map, pp_overstrike_index, pp_number_of_chars), ON) ^= 0
	     then call make_terminal_dependent_string;
	     call ioa_$ioa_switch_nnl (report_control_info.display_iocb_ptr,
		pp_ioa_string, pp_chunk_of_line);
	end;
%skip(1);
	if display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     report_control_info.report_display_time
		= report_control_info.report_display_time + (time2 - time1);
	end;
%skip(1);
	return;
%page;
make_terminal_dependent_string: proc;
%skip(1);
dcl mtds_loop fixed bin;
dcl mtds_overstrike_index fixed bin;
%skip(3);
	spare_string = "";
	mtds_overstrike_index = pp_overstrike_index;
	do mtds_loop = 1 to pp_number_of_chars;
	     spare_string = spare_string || substr (pp_chunk_of_line, mtds_loop, 1);
	     if page_overstrike_info.bit_map (mtds_overstrike_index)
	     then spare_string = spare_string 
		|| BACKSPACE || page_overstrike_info.chars (mtds_overstrike_index);
	     mtds_overstrike_index = mtds_overstrike_index + 1;
	end;
%skip(1);
	pp_number_of_chars = length (spare_string);
	pp_chunk_of_line_ptr = addrel (addr (spare_string), 1);
%skip(1);
	return;
%skip(1);
     end make_terminal_dependent_string;
%skip(1);
     end print_page;
%page;
print_report: proc;
%skip(1);
dcl pr_loop fixed bin (21);
dcl pr_loop_limit fixed bin (21);
%skip(3);
	report_control_info.report_display_time = 0;
%skip(1);
	if report_control_info.no_of_formatted_pages ^= 0
	then do;
	     pr_loop_limit = report_control_info.no_of_formatted_pages;
	     do pr_loop = 1 to pr_loop_limit;
		call get_page (pr_loop);
		call print_page;
	     end;
	end;
%skip(1);
	do while (^report_control_info.flags.report_is_formatted);
	     call format_page;
	     call print_page;
	end;
%skip(1);
	if display_arg_results.flags.time_flag
	then call ioa_$ioa_switch (iox_$error_output,
	     "Time used to display the report was ^10.5f seconds.",
	     report_control_info.report_display_time / 1000000);
%skip(1);
          return;
%skip(1);
     end print_report;
%page;
scroll_the_report: proc;
%skip(1);
dcl str_still_looking_for_the_page bit (1) aligned;
%skip(1);
	scroll_ip = display_arg_results.scroll_info_ptr;
%skip(1);
	on display_buffer_empty begin;
	     if scroll_info.target_page_number <= report_control_info.no_of_formatted_pages
	     then call get_page (scroll_info.target_page_number);
	     else call format_page;
	     scroll_info.page_info_pointer = page_ip;
	end;
%skip(1);
	do while (ON);
	     if scroll_info.flags.goto_line_number_pending
	     then call find_line_within_page;
	     else call find_page;
	     scroll_info.page_info_pointer = page_ip;
	     call rw_display_scroll$continue (scroll_ip, code);
	     if code ^= 0
	     then if code = error_table_$end_of_info
		then return;
	          else call ssu_$abort_line (sci_ptr, code);
	     else;
	end;
%skip(1);
	return;
%page;
check_for_end_of_report: proc;
%skip(3);
	scroll_info.flags.on_the_last_page = OFF;
%skip(1);
	if report_control_info.flags.report_is_formatted
	then if scroll_info.target_page_number > report_control_info.no_of_formatted_pages
	     then do;
		scroll_info.target_page_number = report_control_info.no_of_formatted_pages;
		scroll_info.flags.on_the_last_page = ON;
	     end;
	     else;
	else;
%skip(1);
	return;
%skip(1);
     end check_for_end_of_report;
%page;
find_line_within_page: proc;
%skip(1);
dcl flwp_beginning_line_number fixed bin (35);
dcl flwp_ending_line_number fixed bin (35);
dcl flwp_line_number_is_beyond_end_of_report bit (1) aligned;
dcl flwp_still_looking_for_the_line bit (1) aligned;
%skip(1);
	scroll_info.flags.goto_line_number_pending = OFF;
	flwp_still_looking_for_the_line = ON;
	flwp_line_number_is_beyond_end_of_report = OFF;
	scroll_info.target_page_number = 1;
	flwp_beginning_line_number = 1;
%skip(1);
	do while (flwp_still_looking_for_the_line);
	     if scroll_info.target_page_number
	     <= report_control_info.no_of_formatted_pages
	     then call get_page (scroll_info.target_page_number);
	     else call format_page;
%skip(1);
	     flwp_ending_line_number = flwp_beginning_line_number + page_info.length - 1;
	     if report_control_info.flags.report_is_formatted
	     then if scroll_info.target_page_number
		= report_control_info.no_of_formatted_pages
		then do;
		     scroll_info.flags.on_the_last_page = ON;
		     if scroll_info.target_line_number > flwp_ending_line_number
		     then flwp_line_number_is_beyond_end_of_report = ON;
		end;
	          else;
	     else;
%skip(1);
	     if (scroll_info.target_line_number >= flwp_beginning_line_number
	     & scroll_info.target_line_number <= flwp_ending_line_number)
	     | (flwp_line_number_is_beyond_end_of_report)
	     then flwp_still_looking_for_the_line = OFF;
	     else flwp_beginning_line_number = flwp_ending_line_number + 1;
%skip(1);
	     if ^flwp_still_looking_for_the_line
	     then do;
		if flwp_line_number_is_beyond_end_of_report
		then scroll_info.target_line_number
		     = (flwp_ending_line_number - flwp_beginning_line_number)
		     - scroll_info.vertical_scroll_distance + 1;
		else scroll_info.target_line_number
		     = scroll_info.target_line_number - flwp_beginning_line_number + 1;
	     end;
	     else scroll_info.target_page_number
		= scroll_info.target_page_number + 1;
	end;
%skip(1);
	return;
%skip(1);
     end find_line_within_page;
%page;
find_page: proc;
%skip(3);
	call check_for_end_of_report;
	if scroll_info.target_page_number <= report_control_info.no_of_formatted_pages
	then call get_page (scroll_info.target_page_number);
	else do;
	     str_still_looking_for_the_page = ON;
	     do while (str_still_looking_for_the_page);
		call format_page;
		call check_for_end_of_report;
		if scroll_info.target_page_number = report_control_info.no_of_formatted_pages
		then str_still_looking_for_the_page = OFF;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end find_page;
%skip(1);
     end scroll_the_report;
%page;
setup_io_switches: proc;
%skip(3);
	if display_arg_results.output_file_flag
	then call setup_output_file;
	else if display_arg_results.scroll_flag
	     then do;
		call rw_display_scroll$start (sci_ptr, report_cip, 
		     addr (display_arg_results), work_area_ptr);
		video_has_been_set_up = ON;
	     end;
	     else if display_arg_results.output_switch_flag
		then call setup_output_switch;
		else report_control_info.display_iocb_ptr
		     = iox_$user_output;
%skip(1);
	return;
%page;
setup_output_file: proc;
%skip(3);
	switch_name = unique_chars_ ("0"b) || ".rw_display";
	if display_arg_results.truncate_flag
	then attach_description = "vfile_ "
	     || rtrim (display_arg_results.output_file_directory_name)
	     || ">" || rtrim (display_arg_results.output_file_entry_name);
	else attach_description = "vfile_ "
	     || rtrim (display_arg_results.output_file_directory_name)
	     || ">" || rtrim (display_arg_results.output_file_entry_name)
	     || " -extend";
%skip(1);
	call iox_$attach_name (switch_name, iocb_ptr, attach_description,
	     null (), code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to attach file ^a in dir ^a.",
	     rtrim (display_arg_results.output_file_entry_name),
	     rtrim (display_arg_results.output_file_directory_name));
%skip(1);
	call iox_$open (iocb_ptr, Stream_output, "0"b, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to open file ^a in dir ^a.",
	     rtrim (display_arg_results.output_file_entry_name),
	     rtrim (display_arg_results.output_file_directory_name));
%skip(1);
	report_control_info.display_iocb_ptr = iocb_ptr;
%skip(1);
	return;
%skip(1);
     end setup_output_file;
%page;
setup_output_switch: proc;
%skip(3);
	call iox_$look_iocb (display_arg_results.output_switch_name,
	     report_control_info.display_iocb_ptr, code);
	if code = error_table_$no_iocb
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_display,
	     BAD_OUTPUT_SWITCH_MESSAGE);
%skip(1);
	if report_control_info.display_iocb_ptr -> iocb.attach_descrip_ptr = null ()
	| report_control_info.display_iocb_ptr -> iocb.open_descrip_ptr = null ()
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_display,
	     BAD_OUTPUT_SWITCH_MESSAGE);
%skip(1);
	return;
%skip(1);
     end setup_output_switch;
%skip(1);
     end setup_io_switches;
%page;
terminate: proc;
%skip(3);
	if display_arg_results.sort_information_ptr ^= null
	then do;
	     sort_info_ptr = display_arg_results.sort_information_ptr;
	     free sort_info;
	end;
%skip(1);
	if ^arguments_have_been_processed
	then return;
%skip(1);
          /* Delete the table and report if instructed to do so. */
%skip(1);
          if ^display_arg_results.keep_retrieval_flag 
	& report_control_info.flags.table_has_been_started
	then call delete_table;
%skip(1);
          if ^display_arg_results.keep_report_flag 
	& report_control_info.flags.report_has_been_started
	then call delete_report;
%skip(1);
	/* If we were writing the report to a file clean up. */
%skip(1);
	if display_arg_results.output_file_flag
	& (report_control_info.display_iocb_ptr ^= iox_$user_output
	& report_control_info.display_iocb_ptr ^= null ())
	then do;
	     iocb_ptr = report_control_info.display_iocb_ptr;
	     call iox_$close (iocb_ptr, code);
	     call iox_$detach_iocb (iocb_ptr, code);
	     call iox_$destroy_iocb (iocb_ptr, code);
	     if cleanup_signalled & report_control_info.no_of_formatted_pages > 0
	     then call ssu_$print_message (sci_ptr, 0,
		"The partial report is contained in ^/^a.",
		rtrim (display_arg_results.output_file_directory_name)
		|| ">" || rtrim (display_arg_results.output_file_entry_name));
	     else;
	end;
	else;
%skip(1);
	if display_arg_results.scroll_flag & video_has_been_set_up
	then call rw_display_scroll$stop (display_arg_results.scroll_info_ptr);
	if display_arg_results.scroll_info_ptr ^= null
	then do;
	     scroll_ip = display_arg_results.scroll_info_ptr;
	     free scroll_info;
	     display_arg_results.scroll_info_ptr = null;
	end;
%skip(1);
          return;
%skip(1);
     end terminate;
%page;
dcl BACKSPACE char (1) static int options (constant) init ("");
dcl BAD_OUTPUT_SWITCH_MESSAGE char (69) static int options (constant) init (
"^/When -output_switch is used the switch must be opened and attached.");
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
%page;
dcl addr builtin;
dcl addrel builtin;
dcl arguments_have_been_processed bit (1) aligned;
dcl attach_description char (256);
%skip(1);
dcl cleanup condition;
dcl cleanup_signalled bit (1) aligned;
dcl code fixed bin (35);
%skip(1);
dcl directory_name char (168);
dcl display_buffer_empty condition;
%skip(1);
dcl entry_name char (32);
dcl error_table_$end_of_info fixed bin(35) ext static;
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$no_iocb fixed bin(35) ext static;
dcl error_table_$no_s_permission fixed bin(35) ext static;
dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
%skip(1);
dcl first_page_of_the_report bit (1) aligned;
%skip(1);
dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
%skip(1);
dcl index builtin;
dcl ioa_$ioa_switch entry() options(variable);
dcl ioa_$ioa_switch_nnl entry() options(variable);
dcl iocb_ptr ptr;
%skip(1);
dcl last_page_of_the_report bit (1) aligned;
dcl length builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl rtrim builtin;
dcl rw_display_process_args entry (ptr, ptr, ptr, ptr);
dcl rw_display_scroll$continue entry (ptr, fixed bin(35));
dcl rw_display_scroll$start entry (ptr, ptr, ptr, ptr);
dcl rw_display_scroll$stop entry (ptr);
dcl rw_error_$bad_report_display fixed bin(35) ext static;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl rw_fr_build_page entry (ptr, ptr, fixed bin(35));
dcl rw_fr_delete_report entry (ptr, fixed bin(35));
dcl rw_fr_get_page entry (ptr, fixed bin (21), ptr, fixed bin (35));
dcl rw_fr_new_report entry (ptr, fixed bin(35));
dcl rw_table_manager$delete_table entry (ptr, fixed bin (35));
dcl rw_table_manager$load_table entry (ptr, fixed bin (35));
dcl rw_table_manager$create_table entry (ptr, fixed bin (35));
dcl rw_table_manager$sort entry (ptr, ptr, fixed bin (35));
%skip(1);
dcl sci_ptr ptr;
dcl spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$print_message entry() options(variable);
dcl substr builtin;
dcl switch_name char (42);
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl terminal_dependency bit (1) aligned;
dcl time1 float bin (63);
dcl time2 float bin (63);
%skip(1);
dcl unique_chars_ entry (bit(*)) returns(char(15));
%skip(1);
dcl vclock builtin;
dcl video_has_been_set_up bit (1) aligned;
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include iocb;
%page;
%include iox_dcls;
%page;
%include iox_modes;
%page;
%include rw_display_arg_list;
%page;
%include rw_options_extents;
%page;
%include rw_page_info;
%page;
%include rw_report_info;
%page;
%include rw_scroll_info;
%page;
%include rw_sort_info;
%page;
%include rw_table_info;
%page;
%include rw_table_control_info;
%page;
%include status_structures;
     end rw_display;




		    rw_display_builtins.pl1         11/16/84  1355.8rew 11/16/84  1354.2       45045



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the main level procedure called by ssu_ to implement the
     report_writer_ display_builtins request. Description and usage follows.

     Description:

     This active request returns the value of the named builtin.  The builtin
     is named by the user.
     
     Usage: "display_builtins STR"

     where STR is the name of the desired builtin. It can be chosen from:
     "current_row_number", "first_row", "last_row", "page_number",
     "previously_processed_row", "last_row_number", "last_page_number",
     "last_pass", or "current_pass_number".

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_display_builtins: proc (

	sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
	report_cip_parm /* input: points to report_control_info */
		     );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
	call initialize;
	call get_builtin_value;
%skip(1);
	return;
%page;
initialize: proc;
%skip(3);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
	call ssu_$return_arg (sci_ptr, number_of_args_supplied,
	     active_request_flag, return_value_ptr, return_value_length);
	if number_of_args_supplied ^= 1
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     USAGE_MESSAGE);
%skip(1);
	if report_cip = null ()
	then call ssu_$abort_line (sci_ptr, rw_error_$no_report);
	else if ^report_control_info.flags.report_has_been_started
	     then call ssu_$abort_line (sci_ptr, rw_error_$no_report);
%skip(1);
	format_report_ip = report_control_info.format_report_info_ptr;
	status_pointer = format_report_info.status_ptr;
%skip(1);
          call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length);
	desired_builtin = arg;
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
get_builtin_value: proc;
%skip(3);
	if desired_builtin = "current_row_number"
	then value = ltrim (convert (value, status.current_row_number));
	else if desired_builtin = "first_row"
	     then if status.flags.first_row_of_report
		then value = "true";
		else value = "false";
	     else if desired_builtin = "last_row"
		then if status.flags.last_row_of_report
		     then value = "true";
		     else value = "false";
		else if desired_builtin = "page_number"
		     then value = ltrim (convert (value, status.current_page_number));
		     else if desired_builtin = "previously_processed_row"
			then if status.flags.row_has_been_processed_before
			     then value = "true";
			     else value = "false";
			else if desired_builtin = "last_row_number"
			     then value = ltrim (convert (value, status.last_row_number));
			     else if desired_builtin = "last_page_number"
				then value = ltrim (convert (value, status.last_page_number));
			          else if desired_builtin = "current_pass_number"
				     then value = ltrim (convert (value, status.current_pass_number));
				     else if desired_builtin = "last_pass"
					then if status.flags.last_pass
					     then value = "true";
				               else value = "false";
					else call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
					     "^/^a is not the name of a display builtin.", desired_builtin);
%skip(1);
	return_value = requote_string_ (rtrim (value));
%skip(1);
	return;
%skip(1);
     end get_builtin_value;
%page;
dcl USAGE_MESSAGE char (31) static int options (constant) init (
"^/Usage: [display_builtins STR]");
%skip(1);
dcl active_request_flag bit (1) aligned;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl convert builtin;
%skip(1);
dcl desired_builtin char (32) varying;
%skip(1);
dcl error_table_$bad_arg fixed bin(35) ext static;
dcl error_table_$inconsistent fixed bin(35) ext static;
%skip(1);
dcl ltrim builtin;
%skip(1);
dcl null builtin;
dcl number_of_args_supplied fixed bin;
%skip(1);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl return_value char (return_value_length) varying based (return_value_ptr);
dcl return_value_length fixed bin (21);
dcl return_value_ptr ptr;
dcl rtrim builtin;
dcl rw_error_$no_report fixed bin(35) ext static;
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21));
%skip(1);
dcl value char (16);
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%skip(3);
     end rw_display_builtins;




		    rw_display_process_args.pl1     11/16/84  1355.8rew 11/16/84  1354.2      351900



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the procedure called by the  report writer display request to
     process its control args and return the result through the include
     file rw_display_arg_list. Description and usage follows.

     Description:

     This proc is called to setup the default control arguments, and then
     update them with any user supplied control args. It is broken out
     from the report writer display request so that it can (hopefully) be
     replaced when a general process_args subroutine comes along.
     
     Usage:

     See the paremeter list for usage.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 - Became report_writer_.

*/
%page;
rw_display_process_args: proc (

	report_cip_parm,		/* input: points to report_control_info */
	area_ptr_parm,		/* input: ptr to an area for allocations */
	table_info_ptr_parm,	/* input: ptr to table_info structure */
	display_arg_results_ptr_parm	/* input: ptr to the display_arg_results structure */
			   );
%skip(1);
dcl area_ptr_parm ptr parm;
dcl display_arg_results_ptr_parm ptr parm;
dcl report_cip_parm ptr parm;
dcl table_info_ptr_parm ptr parm;
%skip(1);
/*
          Mainline Processing Overview.

	1) Set the default control arg flags.
	2) Loop through the control args updating the default flags.
          3) Process any pathnames supplied.
	4) Print execution time if we're being timed.

*/
%skip(3);
          time1 = vclock;
%skip(1);
          call initialize;
	call process_args;
%skip(1);
	if based_display_arg_results.output_file_flag
	| based_display_arg_results.temp_dir_flag
	then call setup_additional_pathnames;
%skip(1);
	if based_display_arg_results.time_flag
	then do;
	     time2 = vclock;
	     call ioa_$ioa_switch (iox_$error_output,
		"Time used to process the arguments was ^10.5f seconds.",
		(time2 - time1) / 1000000);
	end;
%skip(1);
          return;
%page;
initialize: proc;
%skip(3);
	report_cip = report_cip_parm;
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	the_area_ptr = area_ptr_parm;
	table_ip = table_info_ptr_parm;
	based_display_arg_results_ptr = display_arg_results_ptr_parm;
%skip(1);
          /* Set the default control args up. */
%skip(1);
          unspec (based_display_arg_results.flags) = OFF;
	based_display_arg_results.pathnames = BLANK;
	unspec (based_display_arg_results.miscellaneous) = OFF;
	based_display_arg_results.sort_information_ptr = null ();
	based_display_arg_results.scroll_info_ptr = null ();
%skip(1);
	based_display_arg_results.flags.all_flag = ON;
	based_display_arg_results.flags.new_report_flag = ON;
	based_display_arg_results.flags.new_retrieval_flag = ON;
	based_display_arg_results.flags.long_flag = ON;
	based_display_arg_results.flags.truncate_flag = ON;
%skip(1);
	/* Setup the scrolling structure to it's default state. */
%skip(1);
	allocate scroll_info in (the_area) set (scroll_ip);
	unspec (scroll_info) = OFF;
	based_display_arg_results.scroll_info_ptr = scroll_ip;
	terminal_info_ptr = addr (local_terminal_info);
	terminal_info.version = terminal_info_version;
	call iox_$control (iox_$user_io, "terminal_info", terminal_info_ptr, code);
	if code ^= 0
	then if code = error_table_$no_operation
	     then window_system_cant_be_used = ON;
	     else call ssu_$abort_line (sci_ptr, code,
		"Unable to get the terminal information.");
	else do;
	     window_system_cant_be_used = OFF;
	     call ttt_info_$function_key_data (terminal_info.term_type,
		the_area_ptr, function_key_data_ptr, code);
	     if code ^= 0
	     then if code ^= error_table_$no_table
		then call ssu_$abort_line (sci_ptr, code,
		     "Unable to get the function key information.");
	          else function_keys_can_be_used = OFF;
	     else do;
		scroll_info.function_key_data_pointer = function_key_data_ptr;
		if function_key_data.highest < HIGHEST_NUMBERED_FUNCTION_KEY_NEEDED
		| (function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length = 0)
		| (function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length = 0)
		| (function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length = 0)
		| (function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length = 0)
		then function_keys_can_be_used = OFF;
	          else function_keys_can_be_used = ON;
	     end;
	     if function_keys_can_be_used
	     then call process_enable_function_keys;
	     else call process_enable_escape_keys;
	end;
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
process_args: proc;
%skip(3);
/* 
          Loop through the control args setting flags and collecting arguments
          to control args. Conflicting control args are overidden by the
          last one supplied. Args to control args (e.g. dir names, page 
          numbers) are processed immediately.
*/
%skip(1);
	call ssu_$arg_count (sci_ptr, no_of_args_supplied);
%skip(1);
	if no_of_args_supplied = 0
	then return;
%skip(1);
          still_processing_args = ON;
	current_arg = 1;
%skip(1);
          do while (still_processing_args);
%skip(1);
	     call get_next_arg;
	     argument_number = lookup_arg_number (arg);
	     if argument_number = 0
	     then call ssu_$abort_line (sci_ptr, error_table_$badopt,
		"^/^a is not a valid control argument. Type ""help display"" for correct usage.",
		     arg);
	     call process_arg_procs (argument_number);
%skip(1);
	end;
%skip(1);
          return;
%page;
lookup_arg_number: proc (arg_parm) returns (fixed bin);
%skip(3);
dcl arg_parm char (*) parm;
%skip(3);
          loop1 = 1;
	loop2 = hbound (ARGUMENT_NAME_TABLE, 1);
%skip(1);
	do while (loop1 <= loop2);
%skip(1);
	     loop3 = divide (loop1 + loop2, 2, 17);
	     if arg_parm = ARGUMENT_NAME_TABLE (loop3)
	     then return (loop3);
%skip(1);
	     if arg_parm < ARGUMENT_NAME_TABLE (loop3)
	     then loop2 = loop3 - 1;
	     else loop1 = loop3 + 1;
%skip(1);
	end;
%skip(1);
	return (0);
%skip(3);
%skip(1);
     end lookup_arg_number;
%skip(1);
     end process_args;
%page;
process_all: proc;
%skip(3);
          based_display_arg_results.all_flag = ON;
%skip(1);
	based_display_arg_results.pages_flag = OFF;
	based_display_arg_results.scroll_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_all;
%skip(5);
process_brief: proc;
%skip(3);
          based_display_arg_results.long_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_brief;
%page;
process_character_positions: proc;
%skip(3);     
	based_display_arg_results.scroll_flag = OFF;
	based_display_arg_results.character_positions_flag = ON;
%skip(1);
          if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-character_positions must be followed by a left, and optionally a right margin value.");
	call get_next_arg;
	based_display_arg_results.left_margin_position = cv_dec_check_ (arg, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-character_positions must be followed by a valid left margin value, not ^a.", arg);
	if ^still_processing_args
	then generate_right_margin_position = ON;
	else do;
	     call get_next_arg;
	     if substr (arg, 1, 1) = HYPHEN
	     then do;
		generate_right_margin_position = ON;
		current_arg = current_arg - 1;
		still_processing_args = ON;
	     end;
	     else do;
		generate_right_margin_position = OFF;
		based_display_arg_results.right_margin_position 
		     = cv_dec_check_ (arg, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "^/-character_positions must be followed by a valid left and right margin value, not ^a.", arg);
	     end;
	end;
	if generate_right_margin_position
	then do;
	     call rw_options$get (report_cip, OPTIONS.GENERAL_REPORT.NAME
		(INDEX_FOR_PAGE_WIDTH), "", normalized_option_name,
		option_value, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/While trying to get the default report page width.");
	     based_display_arg_results.right_margin_position = cv_dec_check_ ((option_value), code);
	     if based_display_arg_results.right_margin_position = 0
	     then based_display_arg_results.right_margin_position = 100000;
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
		"^/Could not convert the page width ""^a"" to a number.", option_value);
	end;
%skip(1);
          return;
%skip(1);
	end process_character_positions;
%page;
process_debug: proc;
%skip(3);
	based_display_arg_results.flags.debug_flag = ON;
%skip(1);
	return;
%skip(1);
     end process_debug;
%skip(5);
process_discard_report: proc;
%skip(3);
          based_display_arg_results.keep_report_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_discard_report;
%skip(5);
process_discard_retrieval: proc;
%skip(3);
          based_display_arg_results.keep_retrieval_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_discard_retrieval;
%page;
process_enable_escape_keys: proc;
%skip(3);
dcl peek_loop fixed bin;
%skip(1);
	if window_system_cant_be_used
	then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys);
%skip(1);
	scroll_info.flags.escapes_in_use = ON;
%skip(1);
	do peek_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER;
	     keys_as_a_table (peek_loop) = ESCAPE_KEYS_AS_A_TABLE (peek_loop);
	     mnemonic_key_sequences_as_a_table (peek_loop) = ESCAPE_KEY_MNEMONICS_AS_A_TABLE (peek_loop);
	end;
%skip(1);
	return;
%skip(1);
     end process_enable_escape_keys;
%page;
process_enable_function_keys: proc;
%skip(3);
dcl pefk_inner_loop fixed bin;
dcl pefk_loop fixed bin;
%skip(1);
	if window_system_cant_be_used
	then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys);
%skip(1);
	if ^function_keys_can_be_used
	then return;
%skip(1);
	scroll_info.flags.escapes_in_use = OFF;
	scroll_info.keys.forward = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length);
	scroll_info.keys.backward = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length);
	scroll_info.keys.left = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length);
	scroll_info.keys.right = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length);
%skip(1);
	pefk_inner_loop = 1;
	do pefk_loop = 5 to HIGHEST_DISPLAY_FUNCTION_NUMBER;
	     keys_as_a_table (pefk_loop) = substr (function_key_seqs,
		function_key_data.function_keys (pefk_inner_loop, KEY_PLAIN).sequence_index,
		function_key_data.function_keys (pefk_inner_loop, KEY_PLAIN).sequence_length);
	     pefk_inner_loop = pefk_inner_loop + 1;
	end;
%skip(1);
	do pefk_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER;
	     mnemonic_key_sequences_as_a_table (pefk_loop)
		= KEY_MNEMONICS_AS_A_TABLE (pefk_loop);
	end;
%skip(1);
	return;
%skip(1);
     end process_enable_function_keys;
%page;
process_extend: proc;
%skip(3);
	based_display_arg_results.truncate_flag = OFF;
%skip(1);
	return;
%skip(1);
     end process_extend;
%page;
process_keep_report: proc;
%skip(3);
	based_display_arg_results.keep_report_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_keep_report;
%skip(5);
process_keep_retrieval: proc;
%skip(3);
	based_display_arg_results.keep_retrieval_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_keep_retrieval;
%skip(3);
process_long: proc;
%skip(3);
          based_display_arg_results.long_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_long;
%page;
process_new_report: proc;
%skip(3);
	based_display_arg_results.new_report_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_new_report;
%skip(5);
process_new_retrieval: proc;
%skip(3);
	based_display_arg_results.new_retrieval_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_new_retrieval;
%page;
process_old_report: proc;
%skip(3);
          based_display_arg_results.new_report_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_old_report;
%skip(5);
process_old_retrieval: proc;
%skip(3);
          based_display_arg_results.new_retrieval_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_old_retrieval;
%page;
process_output_file: proc;
%skip(3);
	if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-output_file must be followed by a pathname.");
	call get_next_arg;
          based_display_arg_results.output_file_flag = ON;
	based_display_arg_results.output_file_pathname = arg;
          based_display_arg_results.scroll_flag = OFF;
          based_display_arg_results.output_switch_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_output_file;
%page;
process_output_switch: proc;
%skip(3);
	if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-output_switch must be followed by a switch name.");
	call get_next_arg;
          based_display_arg_results.output_switch_flag = ON;
	based_display_arg_results.output_switch_name = arg;
          based_display_arg_results.output_file_flag = OFF;
          based_display_arg_results.scroll_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_output_switch;
%page;
process_pages: proc;
%skip(3);
/*

          The page ranges are handled with a bit map (currently accomodates
	10,000 pages). Set bits in the array on for any page numbers given
	by the user.  Page numbers can be given as "N", a blank separated
	list "N N", a range "N,N", as N to the last page "N," (or "N,$"),
	and as $ (means the last page). There is a special flag to indicate
	the last page has been requested.

*/
%skip(1);
          based_display_arg_results.all_flag = OFF;
	based_display_arg_results.scroll_flag = OFF;
	based_display_arg_results.pages_flag = ON;
%skip(1);
	unspec (based_display_arg_results.specified_pages) = OFF;
%skip(1);
	smallest_page_number = 1;
	largest_page_number 
	     = hbound (based_display_arg_results.specified_pages, 1);
%skip(1);
          if still_processing_args
	then do;
	     call get_next_arg;
	     first_page_number_supplied = ON;
	end;
	else first_page_number_supplied = OFF;
%skip(1);
	if ^first_page_number_supplied | substr (arg, 1, 1) = HYPHEN
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-pages must be followed by at least one page number.");
%page;
          still_processing_page_numbers = ON;
	do while (still_processing_page_numbers);
	     if verify (arg, PAGE_RANGE_VALID_CHARACTERS) ^= 0
	     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		INVALID_PAGE_RANGE, arg);
	     if arg = DOLLAR
	     then based_display_arg_results.last_page_flag = ON;
	     else do;
		if index (arg, COMMA) = 0
		then do;
		     beginning_page_number = cv_dec_check_ (arg, code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
			INVALID_PAGE_RANGE, arg);
		     else ending_page_number = beginning_page_number;
		end;
		else do;
		     beginning_page_number = cv_dec_check_ (before (arg, COMMA), code);
		     if code ^= 0
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
			INVALID_PAGE_RANGE, arg);
		     test_string = after (arg, COMMA);
		     if test_string = "" | test_string = BLANK 
		     | test_string = DOLLAR
		     then ending_page_number = largest_page_number;
		     else do;
			ending_page_number = cv_dec_check_ ((test_string), code);
			if code ^= 0
			then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
			     INVALID_PAGE_RANGE, arg);
		     end;
		end;
		if (beginning_page_number > ending_page_number)
		| (beginning_page_number < smallest_page_number)
		| (ending_page_number > largest_page_number)
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		     INVALID_PAGE_RANGE, arg);
		do loop = beginning_page_number to ending_page_number;
		     based_display_arg_results.specified_pages (loop) = ON;
		end;
	     end;
	     if still_processing_args
	     then do;
		call get_next_arg;
		if substr (arg, 1, 1) = HYPHEN
		then do;
		     current_arg = current_arg - 1;
		     still_processing_page_numbers = OFF;
		     still_processing_args = ON;
		end;
	     end;
	     else still_processing_page_numbers = OFF;
	end;
%skip(1);
          return;
%skip(1);
     end process_pages;
%page;
process_passes: proc;
%skip(3);
	if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-passes must be followed by the number of passes.");
	call get_next_arg;
	if verify (arg, DIGITS) ^= 0 | arg_length > REASONABLE_NUMBER_OF_DIGITS
	then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
	     "^/The value ^a is unacceptable for the number of passes.", arg);
	based_display_arg_results.flags.passes_flag = ON;
	based_display_arg_results.miscellaneous.number_of_passes
	     = convert (based_display_arg_results.miscellaneous.number_of_passes, arg);
	if based_display_arg_results.miscellaneous.number_of_passes = 0
	then call ssu_$abort_line (sci_ptr, error_table_$bad_conversion,
	     "^/The value zero is unacceptable for the number of passes.");
	else if based_display_arg_results.miscellaneous.number_of_passes = 1
	     then based_display_arg_results.flags.passes_flag = OFF;
	     else;
%skip(1);
	return;
%skip(1);
     end process_passes;
%page;
process_scroll: proc;
%skip(3);
	if window_system_cant_be_used
	then call ssu_$abort_line (sci_ptr, video_et_$unable_to_call_wsys);
%skip(1);
	based_display_arg_results.scroll_flag = ON;
%skip(1);
	based_display_arg_results.all_flag = OFF;
	based_display_arg_results.character_positions_flag = OFF;
	based_display_arg_results.pages_flag = OFF;
          based_display_arg_results.output_file_flag = OFF;
          based_display_arg_results.output_switch_flag = OFF;
%skip(1);
          return;
%skip(1);
     end process_scroll;
%page;
process_set_keys: proc;
%skip(3);
dcl psk_pair_of_key_bindings_found bit (1) aligned;
dcl psk_function_name char (32);
dcl psk_function_key_sequence char (32);
%skip(1);
	if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, SET_KEYS_ERROR_MESSAGE);
%skip(1);
	psk_pair_of_key_bindings_found = OFF;
	still_processing_set_key_args = ON;
%skip(1);
	do while (still_processing_set_key_args);
	     call get_next_arg;
	     if substr (arg, 1, 1) = HYPHEN | ^still_processing_args
	     then do;
		if ^psk_pair_of_key_bindings_found | ^still_processing_args
		then call ssu_$abort_line (sci_ptr, 
		     error_table_$inconsistent, SET_KEYS_ERROR_MESSAGE);
		current_arg = current_arg - 1;
		still_processing_args = ON;
		return;
	     end;
	     psk_function_name = arg;
	     call get_next_arg;
	     psk_function_key_sequence = arg;
	     psk_pair_of_key_bindings_found = ON;
	     call rw_display_scroll$set_fkey (scroll_ip, 
		psk_function_name, psk_function_key_sequence, code);
	     if code ^= 0
	     then if code = rw_error_$bad_fkey_name
		then call ssu_$abort_line (sci_ptr, rw_error_$bad_fkey_name,
		     "^/^a is not a valid display scroll function name.", psk_function_name);
	          else if code = rw_error_$bad_fkey_sequence
		     then call ssu_$abort_line (sci_ptr, rw_error_$bad_fkey_sequence,
		          "^/^a is not a valid mnemonic function key sequence.", psk_function_key_sequence);
	     else call ssu_$abort_line (sci_ptr, code);
	     if ^still_processing_args
	     then still_processing_set_key_args = OFF;
	end;
%skip(1);
	return;
%skip(1);
     end process_set_keys;
%page;
process_sort: proc;
%skip(3);
	if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-sort must be followed by at least one column name or number.");
%skip(1);
	call get_next_arg;
	if substr (arg, 1, 1) = HYPHEN
	then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
	     "^/-sort must be followed by a column name or number, not ^a.", arg);
%skip(1);
/*
          Allocate the info structure big enough to hold all columns
          if they are all given. Keep track of which ones are given during
          the processing and if duplicates are given then shut things down.
          A bit map is used to keep track of duplicates.
*/
	no_of_candidate_columns = table_info.column_count;
	allocate sort_info in (the_area)
	     set (sort_info_ptr);
	based_display_arg_results.sort_information_ptr = sort_info_ptr;
	unspec (sort_info) = OFF;
%skip(1);
	allocate sort_bit_map in (the_area)
	     set (sort_bit_map_ptr);
	unspec (sort_bit_map) = OFF;
%skip(1);
          based_display_arg_results.sort_flag = ON;
	still_processing_sort_specs = ON;
	sort_info.number_of_columns_to_sort = 0;
%skip(1);
/*
          (1) The name can be given as a name or number so it's normalized
          so that it's a name. If its not found things are shut down. 
          (2) The name is looked up to find out its order in the
          selection expression. This operation can't fail because the name
          used for the lookup is the normalized name. (3) The name found is
          checked to make sure it's the first time it was given. If its been
          given before then things are shut down. (4) The number of columns
          to be sorted is bumped and the number of the column is stored.
          (5) The next arg (if there is one) is checked to see if its 
          -ascending or one of its brothers. If it is fine. If it's a new
          control arg then a backup in necessary. If it's the next column
          name or number then it will be processed the next time through the
          loop. If it was one of the -ascending family then the next column
          name or number must be gotten before the loop is repeated (which
          may cause another backup operation), if there is another column
          name or number.
*/
%skip(1);
	do while (still_processing_sort_specs);
%skip(1);
	/* Have column name or number changed to a name. */
%skip(1);
	     call rw_options$check_identifier (report_cip, 
		OPTIONS.SPECIFIC_COLUMN.NAME (1), (arg), 
		normalized_option_name, code);
	     if code ^= 0
	     then if code = rw_error_$bad_option_identifier
		then call ssu_$abort_line (sci_ptr, error_table_$bad_arg,
		     "^/^a is not a valid column name or number.", arg);
	          else call ssu_$abort_line (sci_ptr, code);
	     else;
%skip(1);
	     /* Find the number of the column. */
%skip(1);
	     not_found = ON;
	     the_column_name = after (normalized_option_name, BLANK);
	     do loop = 1 to table_info.column_count while (not_found);
		if table_info.columns.column_name (loop) = the_column_name
		then do;
		     not_found = OFF;
		     column_number = loop;
		end;
	     end;
%skip(1);
	     /* Reject duplicates, mark ones we've found. */
%skip(1);
               if not_found
	     then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
		"^/Logic error while trying to find the column ^a.", arg);
	     if sort_bit_map (column_number)
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"^/The ^a column (#^d) was given more than once in the sort description.",
		table_info.columns.column_name (column_number), column_number);
	     else sort_bit_map (column_number) = ON;
%skip(1);
	     sort_info.number_of_columns_to_sort 
		= sort_info.number_of_columns_to_sort + 1;
	     sort_info.columns.number (sort_info.number_of_columns_to_sort) 
		= column_number;
%page;
	     if still_processing_args
	     then do;
		still_processing_additional_sort_args = ON;
		do while (still_processing_additional_sort_args);
		     backup_necessary = OFF;
		     next_column_name_found = OFF;
		     call get_next_arg;
		     if arg = HYPHEN_DESCENDING | arg = HYPHEN_DSC
		     then sort_info.columns.descending 
			(sort_info.number_of_columns_to_sort) = ON;
		     else if arg = HYPHEN_ASCENDING | arg = HYPHEN_ASC
			then;
		          else if arg = HYPHEN_NON_CASE_SENSITIVE | arg = HYPHEN_NCS
			     then sort_info.columns.non_case_sensitive
			          (sort_info.number_of_columns_to_sort) = ON;
			     else if arg = HYPHEN_CASE_SENSITIVE | arg = HYPHEN_CS
				then;
			          else if substr (arg, 1, 1) = HYPHEN
				     then backup_necessary = ON;
				     else next_column_name_found = ON;
		     if next_column_name_found | backup_necessary
		     then still_processing_additional_sort_args = OFF;
		     else if ^still_processing_args
			then do;
			     still_processing_additional_sort_args = OFF;
			     still_processing_sort_specs = OFF;
			end;
			else;
		     if backup_necessary
		     then do;
			current_arg = current_arg - 1;
			still_processing_args = ON;
			still_processing_sort_specs = OFF;
		     end;
		end;
	     end;
	     else still_processing_sort_specs = OFF;
	end;
	free sort_bit_map;
%skip(1);
          return;
%skip(1);
     end process_sort;
%page;
process_temp_dir: proc;
%skip(3);
          if ^still_processing_args
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/-temp_dir must be followed by a directory name.");
	call get_next_arg;
	based_display_arg_results.temp_dir_flag = ON;
	based_display_arg_results.temp_dir_pathname = arg;
%skip(1);
          return;
%skip(1);
     end process_temp_dir;
%page;
process_truncate: proc;
%skip(3);
	based_display_arg_results.truncate_flag = ON;
%skip(1);
	return;
%skip(1);
     end process_truncate;
%page;
process_window: proc;
%skip(3);
	if ^still_processing_args
	then if arg = "-window" | arg = "-win"
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	          "^/-window must be followed by the name of a window.");
	     else call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	          "^/-io_switch must be followed by the name of a switch.");
	else;
	call get_next_arg;
          based_display_arg_results.window_flag = ON;
	based_display_arg_results.window_name = arg;
%skip(1);
          return;
%skip(1);
     end process_window;
%page;
process_time: proc;
%skip(3);
          based_display_arg_results.time_flag = ON;
%skip(1);
          return;
%skip(1);
     end process_time;
%page;
get_next_arg: proc;
%skip(3);
          call ssu_$arg_ptr (sci_ptr, current_arg, arg_ptr, arg_length);
	current_arg = current_arg + 1;
	if current_arg > no_of_args_supplied
	then still_processing_args = OFF;
%skip(1);
          return;
%skip(1);
     end get_next_arg;
%page;
setup_additional_pathnames: proc;
%skip(3);
/*

          If the user has requested the report be saved then expand the
          pathname given and stash away the dir and entry names. If a
          temp_dir was specified then expand and stash it away also.

*/
%skip(1);
          if based_display_arg_results.output_file_flag
	then do;
	     call expand_pathname_ (
		based_display_arg_results.output_file_pathname, 
		based_display_arg_results.output_file_directory_name, 
		based_display_arg_results.output_file_entry_name, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/Unable to expand the -output_file pathname ^a.", 
		based_display_arg_results.output_file_pathname);
	end;
%skip(1);
          if based_display_arg_results.temp_dir_flag
	then do;
	     call expand_pathname_ (
		based_display_arg_results.temp_dir_pathname, 
		temporary_dir_name, entry_name, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/Unable to expand the -temp_dir name ^a.", 
		based_display_arg_results.temp_dir_pathname);
	     call hcs_$status_minf (temporary_dir_name, entry_name, 1, 
		type, bit_count, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/Unable to get the status of the directory ^a.", 
		rtrim (based_display_arg_results.temp_dir_pathname));
	     if type ^= DIRECTORY | (type = DIRECTORY & bit_count > 0)
	     then call ssu_$abort_line (sci_ptr, error_table_$notadir,
		"^/-temp_dir must be followed by a directory name.");
	     based_display_arg_results.temp_dir_pathname
		= rtrim (temporary_dir_name) || ">"
		|| rtrim (entry_name);
	end;
%skip(1);
          return;
%skip(1);
     end setup_additional_pathnames;
%page;
/* To change this table also change the process_arg_procs table. */
%skip(1);
dcl ARGUMENT_NAME_TABLE (55) char (21) varying static int options (constant) init (

"-a",			 /* process_all */
"-all",			 /* process_all */
"-bf",			 /* process_brief */
"-brief",			 /* process_brief */
"-character_positions",	 /* process_character_positions */
"-chpsn",			 /* process_character_positions */
"-debug",			 /* process_debug */
"-discard_report",		 /* process_discard_report */
"-discard_retrieval",	 /* process_discard_retrieval */
"-dsr",			 /* process_discard_retrieval */
"-dsrp",			 /* process_discard_report */
"-eek",			 /* process_enable_escape_keys */
"-efk",			 /* process_enable_function_keys */
"-enable_escape_keys",	 /* process_enable_escape_keys */
"-enable_function_keys",	 /* process_enable_function_keys */
"-extend",		 /* process_extend */
"-io_switch",		 /* process_window */
"-iosw",			 /* process_window */
"-keep_report",		 /* process_keep_report */
"-keep_retrieval",		 /* process_keep_retrieval */
"-kr",			 /* process_keep_retrieval */
"-krp",			 /* process_keep_report */
"-lg",			 /* process_long */
"-long",			 /* process_long */
"-new_report",		 /* process_new_report */
"-new_retrieval",		 /* process_new_retrieval */
"-nr",			 /* process_new_retrieval */
"-nrp",			 /* process_new_report */
"-of",			 /* process_output_file */
"-old_report",		 /* process_old_report */
"-old_retrieval",		 /* process_old_retrieval */
"-or",			 /* process_old_retrieval */
"-orp",			 /* process_old_report */
"-osw",			 /* process_output_switch */
"-output_file",		 /* process_output_file */
"-output_switch",		 /* process_output_switch */
"-page",			 /* process_pages */
"-pages",			 /* process_pages */
"-pass",			 /* process_passes */
"-passes",		 /* process_passes */
"-pg",			 /* process_pages */
"-pgs",			 /* process_pages */
"-scroll",		 /* process_scroll */
"-set_key",		 /* process_set_keys */
"-set_keys",		 /* process_set_keys */
"-sk",			 /* process_set_keys */
"-sks",			 /* process_set_keys */
"-sort",			 /* process_sort */
"-tc",			 /* process_truncate */
"-td",			 /* process_temp_dir */
"-temp_dir",		 /* process_temp_dir */
"-time",			 /* process_time */
"-truncate",		 /* process_truncate */
"-win",			 /* process_window */
"-window" 		 /* process_window */
);
dcl BLANK char (1) static int options (constant) init (" ");
dcl COMMA char (1) static int options (constant) init (",");
dcl DIRECTORY fixed bin (2) static int options (constant) init (2);
dcl DIGITS char (10) static int options (constant) init ("0123456789");
dcl DOLLAR char (1) static int options (constant) init ("$");
dcl HYPHEN char (1) static int options (constant) init ("-");
dcl HYPHEN_ASCENDING char (10) static int options (constant) init ("-ascending");
dcl HYPHEN_ASC char (4) static int options (constant) init ("-asc");
dcl HYPHEN_CASE_SENSITIVE char (15) static int options (constant) init ("-case_sensitive");
dcl HYPHEN_CS char (3) static int options (constant) init ("-cs");
dcl HYPHEN_DESCENDING char (11) static int options (constant) init ("-descending");
dcl HYPHEN_DSC char (4) static int options (constant) init ("-dsc");
dcl HYPHEN_NON_CASE_SENSITIVE char (19) static int options (constant) init ("-non_case_sensitive");
dcl HYPHEN_NCS char (4) static int options (constant) init ("-ncs");
dcl INVALID_PAGE_RANGE char (46) static int options (constant) init ("^/^a is not a valid page number or page range.");
dcl OFF bit (1) static int options (constant) init ("0"b);
dcl ON bit (1) static int options (constant) init ("1"b);
dcl PAGE_RANGE_VALID_CHARACTERS char (13) static int options (constant) init (" ,$0123456789");
dcl REASONABLE_NUMBER_OF_DIGITS fixed bin static int options (constant) init (5);
dcl SET_KEYS_ERROR_MESSAGE char (66) static internal options (constant) init (
"^/-set_keys must be followed by at least one pair of key bindings.");
%page;
dcl addr builtin;
dcl after builtin;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
dcl argument_number fixed bin;
%skip(1);
dcl backup_necessary bit (1) aligned;
dcl 1 based_display_arg_results like display_arg_results based (based_display_arg_results_ptr);
dcl based_display_arg_results_ptr ptr;
dcl before builtin;
dcl beginning_page_number fixed bin;
dcl bit_count fixed bin (24);
%skip(1);
dcl code fixed bin (35);
dcl column_number fixed bin;
dcl convert builtin;
dcl current_arg fixed bin;
dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
%skip(1);
dcl divide builtin;
%skip(1);
dcl ending_page_number fixed bin;
dcl entry_name char (32);
dcl error_table_$bad_arg fixed bin(35) ext static;
dcl error_table_$bad_conversion fixed bin(35) ext static;
dcl error_table_$badopt fixed bin(35) ext static;
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$no_operation fixed bin(35) ext static;
dcl error_table_$no_table fixed bin(35) ext static;
dcl error_table_$notadir fixed bin(35) ext static;
dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
%skip(1);
dcl first_page_number_supplied bit (1) aligned;
dcl function_keys_can_be_used bit (1) aligned;
%skip(1);
dcl generate_right_margin_position bit (1) aligned;
%skip(1);
dcl hbound builtin;
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
%skip(1);
dcl index builtin;
dcl ioa_$ioa_switch entry() options(variable);
dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35));
dcl iox_$error_output ptr ext static;
dcl iox_$user_io ptr ext static;
%skip(1);
dcl largest_page_number fixed bin;
dcl 1 local_terminal_info like terminal_info;
dcl loop fixed bin;
dcl loop1 fixed bin;
dcl loop2 fixed bin;
dcl loop3 fixed bin;
%skip(1);
dcl next_column_name_found bit (1) aligned;
dcl no_of_args_supplied fixed bin;
dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
dcl not_found bit (1) aligned;
dcl null builtin;
%skip(1);
dcl option_value char (32) varying;
%skip(1);
/* To change this table also change the ARGUMENT_NAME_TABLE table. */
%skip(1);
dcl process_arg_procs (55) entry init (

process_all,		 /* "-a" */
process_all,		 /* "-all" */
process_brief,		 /* "-bf" */
process_brief,		 /* "-brief" */
process_character_positions,	 /* "-character_positions" */
process_character_positions,	 /* "-chpsn" */
process_debug,		 /* "-debug" */
process_discard_report,	 /* "-discard_report" */
process_discard_retrieval,	 /* "-discard_retrieval" */
process_discard_retrieval,	 /* "-dsr" */
process_discard_report,	 /* "-dsrp" */
process_enable_escape_keys,	 /* "-eek" */
process_enable_function_keys,	 /* "-efk" */
process_enable_escape_keys,	 /* "-enable_escape_keys" */
process_enable_function_keys,	 /* "-enable_function_keys" */
process_extend,		 /* "-extend" */
process_window,		 /* "-io_switch" */
process_window,		 /* "-iosw" */
process_keep_report,	 /* "-keep_report" */
process_keep_retrieval,	 /* "-keep_retrieval" */
process_keep_retrieval,	 /* "-kr" */
process_keep_report,	 /* "-krp" */
process_long,		 /* "-lg" */
process_long,		 /* "-long" */
process_new_report,		 /* "-new_report" */
process_new_retrieval,	 /* "-new_retrieval" */
process_new_retrieval,	 /* "-nr" */
process_new_report,		 /* "-nrp" */
process_output_file,	 /* "-of" */
process_old_report,		 /* "-old_report" */
process_old_retrieval,	 /* "-old_retrieval" */
process_old_retrieval,	 /* "-or" */
process_old_report,		 /* "-orp" */
process_output_switch,	 /* "-osw" */
process_output_file,	 /* "-output_file" */
process_output_switch,	 /* "-output_switch" */
process_pages,		 /* "-page" */
process_pages,		 /* "-pages" */
process_passes,		 /* "-pass" */
process_passes,		 /* "-passes" */
process_pages,		 /* "-pg" */
process_pages,		 /* "-pgs" */
process_scroll,		 /* "-scroll" */
process_set_keys,	 	 /* "-set_key" */
process_set_keys,	 	 /* "-set_keys" */
process_set_keys,	 	 /* "-sk" */
process_set_keys,	 	 /* "-sks" */
process_sort,		 /* "-sort" */
process_truncate,		 /* "-tc" */
process_temp_dir,		 /* "-td" */
process_temp_dir,		 /* "-temp_dir" */
process_time,		 /* "-time" */
process_truncate,		 /* "-truncate" */
process_window,		 /* "-win" */
process_window		 /* "-window" */
);
%skip(1);
dcl rtrim builtin;
dcl rw_display_scroll$set_fkey entry (ptr, char(*), char(*), fixed bin(35));
dcl rw_error_$bad_fkey_name fixed bin(35) ext static;
dcl rw_error_$bad_fkey_sequence fixed bin(35) ext static;
dcl rw_error_$bad_option_identifier fixed bin(35) ext static;
dcl rw_error_$bad_report_setup fixed bin(35) ext static;
dcl rw_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35));
dcl rw_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35));
%skip(1);
dcl sci_ptr ptr;
dcl smallest_page_number fixed bin;
dcl sort_bit_map (no_of_candidate_columns) bit (1) based (sort_bit_map_ptr);
dcl sort_bit_map_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_count entry (ptr, fixed bin);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl still_processing_additional_sort_args bit (1) aligned;
dcl still_processing_args bit (1) aligned;
dcl still_processing_page_numbers bit (1) aligned;
dcl still_processing_set_key_args bit (1) aligned;
dcl still_processing_sort_specs bit (1) aligned;
dcl substr builtin;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl temporary_dir_name char (168);
dcl test_string char (8) varying;
dcl the_area area (sys_info$max_seg_size) based (the_area_ptr);
dcl the_area_ptr ptr;
dcl the_column_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
dcl time1 float bin (63);
dcl time2 float bin (63);
dcl type fixed bin (2);
%skip(1);
dcl unspec builtin;
dcl ttt_info_$function_key_data entry (char(*), ptr, ptr, fixed bin(35));
%skip(1);
dcl vclock builtin;
dcl verify builtin;
dcl video_et_$unable_to_call_wsys fixed bin(35) ext static;
%skip(1);
dcl window_system_cant_be_used bit (1) aligned;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include function_key_data;
%page;
%include rw_display_arg_list;
%page;
%include rw_format_options;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_scroll_info;
%page;
%include rw_sort_info;
%page;
%include rw_table_info;
%page;
%include terminal_info;
%skip(1);
     end rw_display_process_args;




		    rw_display_scroll.pl1           11/16/84  1355.8rew 11/16/84  1354.3      590193



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the subroutine called by the display request to implement the
     report writer display scrolling feature. Description and usage follows.

     Description:
     
     This module provides for the display of paginated and unpaginated
     reports through the video system. It also provides the function of
     setting a scroll function to a provided key sequence. This program
     operates in conjunction with rw_display_process_args (initial
     setup of the scroll_info structure) and rw_display (the caller of
     this subroutine).

     Usage:

     See the entrypoints for parameter descriptions.  The entrypoint set_fkey
     is called by rw_display_process_args to set any functions to key
     sequences provided on the request line when the display request is given.
     The start, continue, and stop entrypoints are called by the rw_display
     module for setup, scrolling, and termination respectively.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 - Became report_writer_.

*/
%page;
rw_display_scroll: proc;
%skip(3);
	/* These parameters are described at each entry where they are used. */
%skip(1);
dcl code_parm fixed bin (35) parm;
dcl display_arg_results_ptr_parm ptr parm;
dcl function_name_parm char (*) parm;
dcl function_key_sequence_parm char (*) parm;
dcl rci_ptr_parm ptr parm;
dcl sci_ptr_parm ptr parm;
dcl scroll_info_ptr_parm ptr parm;
dcl work_area_ptr_parm ptr parm;
%skip(3);
RETURN_TO_CALLING_PROGRAM:
%skip(1);
	return;
%page;
continue: entry (

	scroll_info_ptr_parm,	/* input: ptr to the scroll_info structure */
	code_parm			/* output: success, failure, or user quit (error_table_$end_of_info) */
	 );
%skip(3);
/*

	Mainline Processing Overview

	(1) Perform initialization.

	(2) Display a portion of the current page or buffer. Signal 
	    display_buffer_empty if we cross a buffer boundary in the
	    middle of the display (unpaginated reports only).

	(3) Read a key sequence which tells us what to do next.

	(4) Perform the function the user has requested (e.g. forward).

	(5) Repeat 2 through 4 if we're still in the current page or buffer.
	    Return to caller if we're outside of it, or if we crossed a
	    buffer boundary during the display.

*/
%skip(3);
	scroll_ip = scroll_info_ptr_parm;
	code_parm = 0;
	call housekeeping;
	call scroll_the_report;
	code_parm = code;
%skip(1);
	return;
%page;
set_fkey: entry (

	scroll_info_ptr_parm,	/* input: ptr to the scroll_info strucure */
	function_name_parm,		/* input: function to set the key to */
	function_key_sequence_parm,	/* input: the key sequence */
	code_parm			/* output: success or failure */
	     );
%skip(3);
/*

	Mainline Processing Overview

	(1) Translate any mnemonic key sequences into the characters
	    the terminal generates ("escape-", "esc-", "control-" and
	    "ctl-" are translated).

	(2) Translate key sequences given as mnemonics into the characters
	    the terminal generates (i.e. translate "up_arrow" into whatever
	    the particular terminal generates when the up arrow is pressed).

	(3) Assign the translated key sequence to the table entry for that
	    particular function.

*/
%skip(3);
	scroll_ip = scroll_info_ptr_parm;
	function_key_data_ptr = scroll_info.function_key_data_pointer;
	function_name = function_name_parm;
	function_key_sequence = function_key_sequence_parm;
	call set_function_key (function_name, function_key_sequence, code);
	code_parm = code;
%skip(1);
	return;
%page;
start: entry (

	sci_ptr_parm,		/* input: ptr to the subsystem control info structure */
	rci_ptr_parm,		/* input: ptr to the report_control_info structure */
	display_arg_results_ptr_parm,	/* input: ptr to the display_arg_results structure */
	work_area_ptr_parm		/* input: ptr to a work area */
	  );
%skip(3);
/*

	Mainline Processing Overview

	(1) Allocate various structures needed for the video system.

	(2) Turn on the video system if it's not already on.

	(3) If window was specified by the user check it out to make sure it 
	    meets the requirements. If window wasn't  specified, then set
	    one up and shrink user_i/o.

	(4) Setup the format_document_options structure for filling of help
	    strings to the window width.

*/
%skip(3);
	sci_ptr = sci_ptr_parm;
	report_cip = rci_ptr_parm;
	display_results_ptr = display_arg_results_ptr_parm;
	work_area_ptr = work_area_ptr_parm;
	call setup_scroll;
%skip(1);
	return;
%page;
stop: entry (

	scroll_info_ptr_parm	/* input: ptr to the scroll_info structure */
	 );
%skip(3);
/*

	Mainline Processing Overview

	(1) If window wasn't specified by the user then destroy the
	    window we created and put back user_i/o to the same state
	    as we found it.

	(2) Turn off the video system if we turned it on.

*/
%skip(3);
	if scroll_info_ptr_parm = null ()
	then return;
	scroll_ip = scroll_info_ptr_parm;
	call housekeeping;
	call terminate_scroll;
%skip(1);
	return;
%page;
abort_line: proc (

	code_parm,	/* input: the code that caused the error */
	message_parm	/* input: additional information */
	       );
%skip(1);
dcl code_parm fixed bin (35) parm;
dcl message_parm_length fixed bin;
dcl message_parm char (*) parm;
%skip(3);
	if code_parm ^= 0
	then do;
	     call convert_status_code_ (code_parm, short_message, long_message);
	     error_message = "^/" || rtrim (long_message);
	end;
	else error_message = "";
%skip(1);
	message_parm_length = length (rtrim (message_parm));
	if message_parm_length > 0
	then error_message = error_message || "^/" || rtrim (message_parm);
%skip(1);
	call ssu_$abort_line (sci_ptr, rw_error_$bad_report_display, error_message);
%skip(1);
     end abort_line;
%page;
check_code: proc;
%skip(3);
/*

	It is only valid to call this proc if the entrypoint "continue" 
	was called. This proc takes care of the details of hiding the
	"window_status_pending" error code returned by any of the many,
	many different window_ entrypoints this subroutine calls. When this
	ugly error code is returned there is not enough information that
	can be gotten to do anything reasonable. For example, if we could
	determine from the video system where in the window the asyncronous
	output was written to, we could at least write around it or prompt
	the user to see if she has read it. But there isn't anything like
	that. Instead we get two bits, saying if there was asyncronous
	output or that the screen is invalid. This proc does a 
	get_window_status control order, returns to rw_display, who 
	immediately calls back here, resulting in a redisplay of the window.
	Invalid screens are the only thing we get in the default case, so 
	this is always the correct action. In the case of the experienced
	user who has set up her own windows, if she has missed a message
	through this redisplay she can see them again with the multics_mode
	function or set up her windows more intelligently next time.

*/
%skip(1);
	if code = 0
	then return;
%skip(1);
	if code = video_et_$window_status_pending
	then call iox_$control (window_iocb_ptr, "get_window_status",
	     window_status_info_ptr, code);
%skip(1);
	code_parm = code;
	goto RETURN_TO_CALLING_PROGRAM;
%skip(1);
     end check_code;
%page;
display_chunk_of_page: proc;
%skip(1);
dcl dcop_buffer_empty_pending bit (1) aligned;
dcl dcop_current_line_on_page fixed bin;
dcl dcop_current_line_on_screen fixed bin;
dcl dcop_number_of_chars_to_write fixed bin;
dcl dcop_loop fixed bin;
dcl dcop_loop_limit fixed bin;
dcl display_buffer_empty condition;
%skip(1);
	dcop_buffer_empty_pending = OFF;
	call window_$clear_window (window_iocb_ptr, code);
	call check_code;
%skip(1);
	/* Set the width so we don't exceed the portion of the page left or the window width. */
%skip(1);
	if page_info.width - 1 <= report_output_window_position_info.width
	then;
	else if scroll_info.left_vertical_position + report_output_window_position_info.width > page_info.width
	     then scroll_info.left_vertical_position = page_info.width - report_output_window_position_info.width;
	dcop_number_of_chars_to_write = min (page_info.width - scroll_info.left_vertical_position,
	     report_output_window_position_info.width);
%skip(1);
	/* target_line_number can be less than 1 or greater than the page length. Adjust accordingly. */
%skip(1);
	if scroll_info.target_line_number < 1
	then scroll_info.target_line_number = 1;
	else if report_control_info.flags.report_is_paginated
	     then if scroll_info.target_line_number > page_info.length
	          then scroll_info.target_line_number
	               = max (1, page_info.length - scroll_info.vertical_scroll_distance);
	          else;
	     else;
%skip(1);
	/* Simulate the line printer software's 3 blank lines if appropriate. */
%skip(1);
	if scroll_info.target_line_number = 1
	& (report_control_info.flags.report_is_paginated	| scroll_info.target_page_number = 1)
	then scroll_info.top_margin_offset = 3;
	else scroll_info.top_margin_offset = 0;
%skip(1);
	/* Set limits, prepare to hit a buffer boundary for unpaginated reports in the middle of the display. */
%skip(1);
	dcop_current_line_on_page = scroll_info.target_line_number;
	dcop_current_line_on_screen = scroll_info.top_margin_offset + 1;
	dcop_loop_limit = min (
	     report_output_window_position_info.height - dcop_current_line_on_screen + 1,
	     page_info.length - dcop_current_line_on_page + 1);
%skip(1);
	if ^report_control_info.flags.report_is_paginated
	then if (page_info.length - dcop_current_line_on_page + 1 
	     < report_output_window_position_info.height - dcop_current_line_on_screen + 1)
	     & (^report_control_info.flags.report_is_formatted
	     | (report_control_info.flags.report_is_formatted
	     & scroll_info.target_page_number ^= report_control_info.no_of_formatted_pages))
	     then do;
		dcop_loop_limit = report_output_window_position_info.height - dcop_current_line_on_screen + 1;
		dcop_buffer_empty_pending = ON;
	     end;
	     else;
	else;
%skip(1);
	/* Do the display, don't bother to write blank lines. */
%skip(1);
	do dcop_loop = 1 to dcop_loop_limit;
	     call window_$position_cursor (window_iocb_ptr, dcop_current_line_on_screen, 1, code);
	     call check_code;
	     if substr (page_defined_as_lines (dcop_current_line_on_page),
	     scroll_info.left_vertical_position, dcop_number_of_chars_to_write) = BLANK
	     then;
	     else do;
		call window_$overwrite_text (window_iocb_ptr,
		     substr (page_defined_as_lines (dcop_current_line_on_page),
		     scroll_info.left_vertical_position, dcop_number_of_chars_to_write), code);
		call check_code;
	     end;
	     dcop_current_line_on_screen = dcop_current_line_on_screen + 1;
	     dcop_current_line_on_page = dcop_current_line_on_page + 1;
	     if dcop_buffer_empty_pending
	     then if dcop_current_line_on_page > page_info.length
		then do;
		     scroll_info.target_page_number = scroll_info.target_page_number + 1;
		     scroll_info.last_line_number_in_previous_buffer = page_info.length;
		     signal display_buffer_empty;
		     scroll_info.flags.buffer_boundary_just_crossed = ON;
		     scroll_info.target_page_number = scroll_info.target_page_number - 1;
		     dcop_current_line_on_page = 1;
		     page_ip = scroll_info.page_info_pointer;
		end;
		else;
	     else;
	end;
%skip(1);
	/* Position cursor to bottom right hand side of window. */
%skip(1);
	call window_$position_cursor (window_iocb_ptr,
	     report_output_window_position_info.height,
	     report_output_window_position_info.width, code);
	call check_code;
%skip(1);
	return;
%skip(1);
     end display_chunk_of_page;
%page;
get_users_response: proc (gur_buffer_parm);
%skip(1);
dcl gur_buffer_parm char (*) parm;
dcl gur_character_read char (1) varying;
dcl gur_loop fixed bin;
dcl gur_partial_match bit (1) aligned;
%skip(1);
	/* Keep reading characters until we get a match, get a mis-match, or fill the buffer. */
%skip(1);
	gur_buffer_parm = "";
	gur_partial_match = ON;
%skip(1);
	do gur_loop = 1 to length (gur_buffer_parm)
	     while (gur_partial_match);
	     call window_$get_one_unechoed_char (window_iocb_ptr, gur_character_read, ON, code);
	     call check_code;
	     substr (gur_buffer_parm, gur_loop, 1) = gur_character_read;
	     if (gur_buffer_parm = scroll_info.keys.forward)
	     | (gur_buffer_parm = scroll_info.keys.backward)
	     | (gur_buffer_parm = scroll_info.keys.left)
	     | (gur_buffer_parm = scroll_info.keys.right)
	     | (gur_buffer_parm = scroll_info.keys.help)
	     | (gur_buffer_parm = scroll_info.keys.set_key)
	     | (gur_buffer_parm = scroll_info.keys.set_scroll_increment)
	     | (gur_buffer_parm = scroll_info.keys.quit)
	     | (gur_buffer_parm = scroll_info.keys.redisplay)
	     | (gur_buffer_parm = scroll_info.keys.start_of_report)
	     | (gur_buffer_parm = scroll_info.keys.end_of_report)
	     | (gur_buffer_parm = scroll_info.keys.multics_mode)
	     | (gur_buffer_parm = scroll_info.keys.goto)
	     then return;
	     gur_partial_match
		= (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.forward, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.backward, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.left, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.right, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.help, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.set_key, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.set_scroll_increment, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.quit, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.redisplay, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.start_of_report, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.end_of_report, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.multics_mode, 1, gur_loop))
		| (substr (gur_buffer_parm, 1, gur_loop) = substr (scroll_info.keys.goto, 1, gur_loop));
	end;
%skip(1);
	return;
%skip(1);
     end get_users_response;
%page;
housekeeping: proc;
%skip(3);
	/* Move the pointers for our needed structures. */
%skip(1);
	display_results_ptr = scroll_info.display_arg_results_ptr;
	report_cip = scroll_info.report_control_info_ptr;
	work_area_ptr = scroll_info.area_ptr;
	user_io_window_position_ip = scroll_info.user_io_window_position_info_ptr;
	report_output_window_position_ip = scroll_info.report_output_window_position_info_ptr;
	sci_ptr = scroll_info.ssu_info_ptr;
	window_iocb_ptr = report_control_info.display_iocb_ptr;
	page_ip = scroll_info.page_info_pointer;
	window_status_info_ptr = scroll_info.window_status_info_pointer;
	function_key_data_ptr = scroll_info.function_key_data_pointer;
	format_document_options_ptr = scroll_info.format_document_op;
%skip(1);
	return;
%skip(1);
     end housekeeping;
%page;
prompt_for_more: proc (

	pfm_line_in_window_parm,	/* input: where to write the prompt */
	pfm_user_wants_more_parm	/* output: on if user wants more */
		  );
%skip(3);
dcl pfm_break_character char (1) varying;
dcl pfm_buffer char (1);
dcl pfm_line_in_window_parm fixed bin parm;
dcl pfm_number_of_chars_read fixed bin (21);
dcl pfm_still_looking_for_a_valid_response bit (1) aligned;
dcl pfm_user_wants_more_parm bit (1) aligned parm;
%skip(1);
	/* Write the more prompt on caller designated line. Accept CR and DEL and mark parm accordingly. */
%skip(1);
	pfm_still_looking_for_a_valid_response = ON;
%skip(1);
	do while (pfm_still_looking_for_a_valid_response);
	     pfm_still_looking_for_a_valid_response = OFF;
	     call window_$position_cursor (window_iocb_ptr, pfm_line_in_window_parm, 1, code);
	     call check_code;
	     call window_$clear_to_end_of_line (window_iocb_ptr, code);
	     call check_code;
	     call window_$write_sync_read (window_iocb_ptr, MORE_PROMPT, 1,
		pfm_buffer, pfm_number_of_chars_read, pfm_break_character, code);
	     call check_code;
	     if pfm_number_of_chars_read = 0
	     then if pfm_break_character = CARRIAGE_RETURN
		then pfm_user_wants_more_parm = ON;
	          else if pfm_break_character = DEL
		     then pfm_user_wants_more_parm = OFF;
		     else pfm_still_looking_for_a_valid_response = ON;
	     else pfm_still_looking_for_a_valid_response = ON;
	     if pfm_still_looking_for_a_valid_response
	     then do;
		call window_$bell (window_iocb_ptr, code);
		call check_code;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end prompt_for_more;
%page;
prompt_user: proc (

	pu_prompt_parm,	/* input: the prompt */
	pu_number_parm,	/* output: the numeric response, or, */
	pu_response_parm,	/* output: the character response */
          pu_numeric_parm	/* input: if on a numeric response is required */
	        );
%skip(1);
dcl pu_number_of_chars_read fixed bin (21);
dcl pu_number_parm fixed bin (35) parm;
dcl pu_numeric_parm bit (1) aligned parm;
dcl pu_prompt_parm char (*) parm;
dcl pu_response_buffer char (256);
dcl pu_response_line fixed bin;
dcl pu_response_parm char (*) parm;
dcl pu_still_looking_for_a_valid_response bit (1) aligned;
dcl pu_window_status_pending condition;
dcl pu_window_status_pending_flag bit (1) aligned;
%skip(3);
/*
	Prompt the user with the supplied prompt in the last line of the 
	window. Accept a numeric or character response depending on the
	setting of pu_numeric_parm. Keep prompting until we get a valid
	response. If we get a window_status_pending then re-write prompt
	on the first line of the window after doing a get_window_status
	control order. Use the iox_ entry point rather than a window_
	entrypoint because the window_ system still doesn't have an
	equivalent. Note that the horrid window_status_pending never
	comes back from the iox_ entrypoint.
*/
%skip(1);
	pu_window_status_pending_flag = OFF;
%skip(1);
	on pu_window_status_pending begin;
	     pu_window_status_pending_flag = ON;
	     pu_response_line = 1;	     
	     call write_prompt;
	end;
%skip(1);
	pu_number_parm = 0;
	pu_response_parm = "";
	pu_still_looking_for_a_valid_response = ON;
	pu_response_line = report_output_window_position_info.height;
%page;
	do while (pu_still_looking_for_a_valid_response);
	     call write_prompt;
	     call iox_$get_line (window_iocb_ptr, addr (pu_response_buffer),
		length (pu_response_buffer), pu_number_of_chars_read, code);
	     if code ^= 0
	     then if code = error_table_$long_record
		then;
	          else call abort_line (code, "Unable to read prompt response.");
	     else do;
		pu_number_of_chars_read = pu_number_of_chars_read - 1;
		if pu_numeric_parm
		then if pu_number_of_chars_read > 0 & pu_number_of_chars_read < 10
		     then pu_still_looking_for_a_valid_response
			= (verify (substr (pu_response_buffer, 1, pu_number_of_chars_read), DIGITS) ^= 0);
		     else;
		else pu_still_looking_for_a_valid_response = OFF;
	     end;
	     if pu_still_looking_for_a_valid_response
	     then do;
		call window_$bell (window_iocb_ptr, code);
		if code ^= 0
		then signal pu_window_status_pending;
		else;
	     end;
	end;
%skip(1);
	if pu_numeric_parm
	then pu_number_parm = convert (pu_number_parm,
	     substr (pu_response_buffer, 1, pu_number_of_chars_read));
	else pu_response_parm = substr (pu_response_buffer, 1, pu_number_of_chars_read);
%skip(1);
	return;
%page;
write_prompt: proc;
%skip(3);
	/* Repeat the sequence until we correctly write the prompt. */
%skip(1);
	if pu_window_status_pending_flag
	then do;
	     call iox_$control (window_iocb_ptr, "get_window_status",
		window_status_info_ptr, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to peform a get_window_status control order.");
	     pu_window_status_pending_flag = OFF;
	end;
%skip(1);
	call window_$position_cursor (window_iocb_ptr, pu_response_line, 1, code);
	call window_$clear_to_end_of_line (window_iocb_ptr, code);
	call window_$overwrite_text (window_iocb_ptr,
	     rtrim (pu_prompt_parm) || " (end with RETURN) ->", code);
%skip(1);
	if code ^= 0
	then if code = video_et_$window_status_pending
	     then signal pu_window_status_pending;
	     else call abort_line (code, "Unable to write the prompt.");
	else;
%skip(1);
	return;
%skip(1);
     end write_prompt;
%skip(1);
     end prompt_user;
%page;
scroll_the_report: proc;
%skip(3);
/*
	Display a chunk of the page or buffer. Perform the scrolling
	function requested by the user. Return to the caller if we're
	outside of the current page, or if we just crossed a buffer boundary.
*/
%skip(1);
	still_in_the_scrolling_business = ON;
%skip(1);
	do while (still_in_the_scrolling_business);
	     call display_chunk_of_page;
	     call setup_for_next_chunk;
	end;
%skip(1);
          return;
%skip(1);
     end scroll_the_report;
%page;
set_function_key: proc (

	sfk_function_name_parm,	  /* input: function to set key to */
	sfk_function_key_sequence_parm, /* input: key sequence to set */
	sfk_code_parm		  /* output: success or failure */
		   );
%skip(3);
dcl sfk_char_10 char (10);
dcl sfk_character_loop char (length (CONTROL_HYPHEN));
dcl sfk_code_parm fixed bin (35) parm;
dcl sfk_function_name_parm char (*) parm;
dcl sfk_function_key_sequence_parm char (*) parm;
dcl sfk_function_key_sequence char (32);
dcl sfk_function_key_sequence_buffer char (32);
dcl sfk_loop fixed bin;
dcl sfk_no_match bit (1) aligned;
%skip(3);
/*
	Translate "escape-", "esc-", "control-X", "ctl-X", to the sequence
	the terminal generates, where X is the character following the
	"control-" or "ctl-" mnemonic. Next translate any of the recognized
	mnemonics in the provided key sequence to what the terminal generates
	(i.e. translate "down_arrow" into whatever the terminal generates).
	Look up the supplied scrolling function name and assign the key
	sequence to the slot in the table. Assign the mnemonic key sequence
	to the slot in another table for it's display when help is invoked.
*/
%skip(1);
	sfk_code_parm = 0;
	if index (sfk_function_key_sequence_parm, ESCAPE_HYPHEN) = 0
	&  index (sfk_function_key_sequence_parm, ESC_HYPHEN) = 0
	&  index (sfk_function_key_sequence_parm, CONTROL_HYPHEN) = 0
	&  index (sfk_function_key_sequence_parm, CTL_HYPHEN) = 0
	then sfk_function_key_sequence = sfk_function_key_sequence_parm;
	else do;
	     sfk_function_key_sequence = sfk_function_key_sequence_parm;
	     do sfk_character_loop = ESCAPE_HYPHEN, ESC_HYPHEN, CONTROL_HYPHEN, CTL_HYPHEN;
		call translate_mnemonics (sfk_function_key_sequence,
		     sfk_character_loop, sfk_function_key_sequence_buffer, sfk_code_parm);
		if sfk_code_parm ^= 0
		then return;
		sfk_function_key_sequence = sfk_function_key_sequence_buffer;
	     end;
	end;
%page;
	if sfk_function_key_sequence = KEY_MNEMONICS.FORWARD
	then sfk_function_key_sequence = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.down (KEY_PLAIN).sequence_length);
	else if sfk_function_key_sequence = KEY_MNEMONICS.BACKWARD
	then sfk_function_key_sequence = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.up (KEY_PLAIN).sequence_length);
	else if sfk_function_key_sequence = KEY_MNEMONICS.LEFT
	then sfk_function_key_sequence = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.left (KEY_PLAIN).sequence_length);
	else if sfk_function_key_sequence = KEY_MNEMONICS.RIGHT
	then sfk_function_key_sequence = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.right (KEY_PLAIN).sequence_length);
	else if sfk_function_key_sequence = HOME
	then sfk_function_key_sequence = substr (function_key_seqs,
	     function_key_data.cursor_motion_keys.home (KEY_PLAIN).sequence_index,
	     function_key_data.cursor_motion_keys.home (KEY_PLAIN).sequence_length);
	else do;
	     sfk_no_match = ON;
	     do sfk_loop = 0 to hbound (function_key_data.function_keys, 1)
		while (sfk_no_match);
		if sfk_function_key_sequence
		= "f" || ltrim (convert (sfk_char_10, sfk_loop))
		then do;
		     sfk_function_key_sequence = substr (function_key_seqs,
			function_key_data.function_keys (sfk_loop, KEY_PLAIN).sequence_index,
			function_key_data.function_keys (sfk_loop, KEY_PLAIN).sequence_length);
		     sfk_no_match = OFF;
		end;
	     end;
	end;
%skip(1);
	do sfk_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER;
	     if sfk_function_name_parm = FUNCTION_NAMES_AS_A_TABLE (sfk_loop)
	     then do;
		keys_as_a_table (sfk_loop) = sfk_function_key_sequence;
		mnemonic_key_sequences_as_a_table (sfk_loop)
		     = sfk_function_key_sequence_parm;
		return;
	     end;
	end;
%skip(1);
	sfk_code_parm = rw_error_$bad_fkey_name;
%skip(1);
	return;
%page;
translate_mnemonics: proc (

	tm_string_in_parm,	/* input: string to be translated */
	tm_mnemonic_parm,   /* input: the mnemonic to be translated */
	tm_string_out_parm, /* output: the translated string */
	tm_code_parm	/* output: success or failure */
		      );
%skip(1);
dcl tm_code_parm fixed bin (35) parm;
dcl tm_current_position fixed bin;
dcl tm_escape_is_replacement_char bit (1) aligned;
dcl tm_mnemonic_length fixed bin;
dcl tm_mnemonic char (32) varying;
dcl tm_mnemonic_parm char (*) parm;
dcl tm_still_translating bit (1) aligned;
dcl tm_string_in_parm char (*) parm;
dcl tm_string_index fixed bin;
dcl tm_string_length fixed bin;
dcl tm_string_out_parm char (*) parm;
dcl tm_string_varying char (32) varying;
dcl tm_target_character_index fixed bin;
dcl tm_translation_index fixed bin;
%skip(3);
/*
	Translate "escape-", "esc-", "control-X", and "ctl-X" into the
	sequence the terminal generates. The "control-" or "ctl-"
	mnemonic has to be followed by another character, as a terminal
	can't generate control without pressing some other key.
*/
%skip(1);
	tm_code_parm = 0;
	tm_mnemonic = rtrim (tm_mnemonic_parm);
%skip(1);
	if index (tm_string_in_parm, tm_mnemonic) = 0
	then do;
	     tm_string_out_parm = tm_string_in_parm;
	     return;
	end;
%skip(1);
	tm_mnemonic_length = length (tm_mnemonic);
	tm_escape_is_replacement_char = (tm_mnemonic = ESCAPE_HYPHEN | tm_mnemonic = ESC_HYPHEN);
	tm_string_varying = "";
	tm_still_translating = ON;
	tm_string_length = length (rtrim (tm_string_in_parm));
	tm_current_position = 1;
%page;
	do while (tm_still_translating);
	     tm_string_index = index (substr (tm_string_in_parm, tm_current_position), tm_mnemonic);
	     if tm_string_index ^= 0
	     then do;
		if tm_current_position < tm_string_index
		then tm_string_varying = tm_string_varying || substr (tm_string_in_parm,
		     tm_current_position, tm_string_index - tm_current_position);
		if tm_escape_is_replacement_char
		then do;
		     tm_string_varying = tm_string_varying || ESCAPE;
		     tm_current_position = tm_current_position + tm_string_index + tm_mnemonic_length - 1;
		end;
		else do;
		     tm_target_character_index = tm_current_position + tm_string_index + tm_mnemonic_length - 1;
		     if tm_target_character_index > tm_string_length
		     then do;
			tm_code_parm = rw_error_$bad_fkey_sequence;
			return;
		     end;
		     tm_translation_index = index (TRANSLATION_TABLE,
			substr (tm_string_in_parm, tm_target_character_index, 1));
		     if tm_translation_index = 0
		     then do;
			tm_code_parm = rw_error_$bad_fkey_sequence;
			return;
		     end;
		     if tm_translation_index > 32
		     then tm_translation_index = tm_translation_index - 32;
		     tm_string_varying = tm_string_varying || byte (tm_translation_index - 1);
		     tm_current_position = tm_target_character_index + 1;
		end;
		if tm_current_position > tm_string_length
		then tm_still_translating = OFF;
	     end;
	     else do;
		if tm_string_length >= tm_current_position
		then tm_string_varying = tm_string_varying
		     || substr (tm_string_in_parm, tm_current_position);
		tm_still_translating = OFF;
	     end;
	end;
%skip(1);
	tm_string_out_parm = tm_string_varying;
%skip(1);
	return;
%skip(1);
     end translate_mnemonics;
%skip(1);
     end set_function_key;
%page;
setup_for_next_chunk: proc;
%skip(1);
dcl sfnc_function_key_procs (HIGHEST_DISPLAY_FUNCTION_NUMBER) entry init (
	fkp_forward,
	fkp_backward,
	fkp_left,
	fkp_right,
	fkp_help,
	fkp_set_key,
	fkp_set_scroll_increment,
	fkp_quit,
	fkp_redisplay,
	fkp_start_of_report,
	fkp_end_of_report,
	fkp_multics_mode,
	fkp_goto);
dcl sfnc_function_number fixed bin;
dcl sfnc_loop fixed bin;
dcl sfnc_still_looking_for_a_valid_response bit (1) aligned;
dcl sfnc_users_response char (32);
%skip(1);
	/* Get a valid user response for a scroll function. Perform the function. */
%skip(1);
	sfnc_still_looking_for_a_valid_response = ON;
%skip(1);
	do while (sfnc_still_looking_for_a_valid_response);
	     call get_users_response (sfnc_users_response);
%skip(1);
	     do sfnc_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER
		while (sfnc_still_looking_for_a_valid_response);
		if sfnc_users_response = keys_as_a_table (sfnc_loop)
		then do;
		     sfnc_function_number = sfnc_loop;
		     sfnc_still_looking_for_a_valid_response = OFF;
		end;
	     end;
%skip(1);
	     if ^sfnc_still_looking_for_a_valid_response
	     then call sfnc_function_key_procs (sfnc_function_number);
	     if sfnc_still_looking_for_a_valid_response
	     then do;
		call window_$bell (window_iocb_ptr, code);
		call check_code;
	     end;
%skip(1);
	end;
%skip(1);
	return;
%page;
fkp_backward: proc;
%skip(1);
dcl fb_beginning_line_number fixed bin;
%skip(3);
/*
	Make sure we don't try to go backward if we're at the beginning
	of the report. If we're at the first line of a page then set the
	page number back one and return to rw_display, and set the line
	number very large so display_chunk_of_page can determine what the
	last line of the previous page is once that information is available
	(when we are called again). If we're not on the first line of a page
	then decrement the current line number and return.
*/
%skip(1);
	if scroll_info.target_line_number = 1
	then if scroll_info.target_page_number = 1
	     then do;
		sfnc_still_looking_for_a_valid_response = ON;
		return;
	     end;
	     else if report_control_info.flags.report_is_paginated
		then do;
		     scroll_info.target_page_number = scroll_info.target_page_number - 1;
		     scroll_info.target_line_number = 99999;
		     still_in_the_scrolling_business = OFF;
		     return;
		end;
		else;
	else if report_control_info.flags.report_is_paginated
	     then do;
		scroll_info.target_line_number
		     = scroll_info.target_line_number - scroll_info.vertical_scroll_distance;
		return;
	     end;
%skip(1);
/*
	We only make it this far if it's an unpaginated report. If the
	beginning line number is less than 1 then return to rw_display
	so it can get us the previous buffer.
*/
%skip(1);
	fb_beginning_line_number
	     = scroll_info.target_line_number - scroll_info.vertical_scroll_distance;
	if fb_beginning_line_number < 1
	then if scroll_info.target_page_number = 1
	     then do;
		scroll_info.target_line_number = 1;
		return;
	     end;
	     else do;
		scroll_info.target_line_number
		     = scroll_info.last_line_number_in_previous_buffer
		     + scroll_info.target_line_number - scroll_info.vertical_scroll_distance;
		still_in_the_scrolling_business = OFF;
		scroll_info.target_page_number = scroll_info.target_page_number - 1;
		return;
	     end;
	else;
%skip(1);
/*
	Return to rw_display to get us the previous buffer if we
	used two buffers for the previous display.
*/
%skip(1);
	scroll_info.target_line_number = fb_beginning_line_number;
	if scroll_info.flags.buffer_boundary_just_crossed
	then do;
	     scroll_info.flags.buffer_boundary_just_crossed = OFF;
	     still_in_the_scrolling_business = OFF;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_backward;
%page;
fkp_end_of_report: proc;
%skip(3);
/*
	If the report is paginated then set the page number very large. If
	the report is unpaginated then set the goto_line_number_pending
	flag and set the line number very large. Return to rw_display.
*/
%skip(1);
	still_in_the_scrolling_business = OFF;
%skip(1);
	if report_control_info.flags.report_is_paginated
	then do;
	     scroll_info.target_page_number = LARGEST_PAGE_NUMBER;
	     scroll_info.target_line_number = 1;
	end;
	else do;
	     scroll_info.flags.goto_line_number_pending = ON;
	     scroll_info.target_line_number = LARGEST_LINE_NUMBER;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_end_of_report;
%page;
fkp_forward: proc;
%skip(1);
dcl ff_beginning_line_number fixed bin;
dcl ff_number_of_left_over_lines fixed bin;
%skip(1);
/*
	Handle unpaginated reports first. If we just crossed a buffer
	boundary and the first line to be displayed is in the first
	buffer then return to rw_display so it can get it. Otherwise
	we have just moved to the buffer we currently have.
*/
%skip(1);
	if scroll_info.flags.buffer_boundary_just_crossed
	then do;
	     scroll_info.flags.buffer_boundary_just_crossed = OFF;
	     ff_number_of_left_over_lines
		= scroll_info.last_line_number_in_previous_buffer - scroll_info.target_line_number + 1;
	     if ff_number_of_left_over_lines > scroll_info.vertical_scroll_distance
	     then do;
		scroll_info.target_line_number = scroll_info.target_line_number
		     + scroll_info.vertical_scroll_distance;
		still_in_the_scrolling_business = OFF;
		return;
	     end;
	     scroll_info.target_line_number = scroll_info.vertical_scroll_distance - ff_number_of_left_over_lines + 1;
	     scroll_info.target_page_number = scroll_info.target_page_number + 1;
	     return;
	end;
%skip(1);
/*
	This code does paginated reports. Advance line number. Make sure
	we don't move off the end of the report. Return to rw_display
	if we move off the current page.
*/
%skip(1);
	ff_beginning_line_number = scroll_info.target_line_number
	     + scroll_info.vertical_scroll_distance - scroll_info.top_margin_offset;
	if ff_beginning_line_number > page_info.length
	then if report_control_info.flags.report_is_formatted
	     & scroll_info.target_page_number = report_control_info.no_of_formatted_pages
	     then sfnc_still_looking_for_a_valid_response = ON;
	     else do;
		scroll_info.target_page_number = scroll_info.target_page_number + 1;
		scroll_info.target_line_number = 1;
		still_in_the_scrolling_business = OFF;
	     end;
	else scroll_info.target_line_number = ff_beginning_line_number;
%skip(1);
	return;
%skip(1);
     end fkp_forward;
%page;
fkp_goto: proc;
%skip(1);
dcl fg_prompt char (11);
dcl fg_line_or_page_number fixed bin (35);
dcl fg_still_looking_for_a_valid_response bit (1) aligned;
%skip(3);
/*
	Prompt for page or line number. Accept only a positive integer.
	Return to rw_display to get the page or buffer.
*/
%skip(1);
	if report_control_info.flags.report_is_paginated
	then fg_prompt = "Page number";
	else fg_prompt = "Line number";
%skip(1);
	fg_still_looking_for_a_valid_response = ON;
	do while (fg_still_looking_for_a_valid_response);
	     call prompt_user (fg_prompt, fg_line_or_page_number,
		users_response, NUMERIC_RESPONSE);
	     if fg_line_or_page_number ^= 0
	     then do;
		if report_control_info.flags.report_is_paginated
		then do;
		     scroll_info.target_page_number = fg_line_or_page_number;
		     scroll_info.target_line_number = 1;
		end;
		else do;
		     scroll_info.flags.goto_line_number_pending = ON;
		     scroll_info.target_line_number = fg_line_or_page_number;
		end;
		fg_still_looking_for_a_valid_response = OFF;
		still_in_the_scrolling_business = OFF;
	     end;
	     else do;
		call window_$bell (window_iocb_ptr, code);
		call check_code;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_goto;
%page;
fkp_help: proc;
%skip(3);
dcl fh_character_read char (1) varying;
dcl fh_help_string char (1024);
dcl fh_help_string_length fixed bin (21);
dcl fh_number_of_chars_read fixed bin (21);
dcl fh_still_looking_for_a_valid_response bit (1) aligned;
dcl fh_returned_help_list char (512);
dcl fh_still_helpful bit (1) aligned;
dcl fh_users_response char (256);
%skip(1);
/*
	Format and write the general help message. Format and write the
	mnemonic key sequences and function names list, or, the specific
	help string for one of the functions. Repeat if user wants more help.
*/
%skip(1);
	fh_still_helpful = ON;
%skip(1);
	do while (fh_still_helpful);
	     call format_document_$string (GENERAL_HELP_MESSAGE, fh_help_string,
		fh_help_string_length, format_document_options_ptr, code);
	     if code ^= 0
	     then call abort_line (code, "");
	     fh_still_looking_for_a_valid_response = ON;
%skip(1);
	     do while (fh_still_looking_for_a_valid_response);
		fh_still_looking_for_a_valid_response = OFF;
		call write_help_string (NO_PROMPT, fh_character_read);
		call iox_$get_line (window_iocb_ptr, addr (fh_users_response),
		     length (fh_users_response), fh_number_of_chars_read, code);
		if code ^= 0
		then call abort_line (code, "");
		if fh_number_of_chars_read ^> 1
		then fh_still_looking_for_a_valid_response = ON;
		else do;
		     fh_number_of_chars_read = fh_number_of_chars_read - 1;
		     if substr (fh_users_response, 1, fh_number_of_chars_read) = GENERAL_HELP_LIST
		     then do;
			call ioa_$rsnnl (GENERAL_HELP_LIST_MESSAGE, fh_help_string,
			     fh_help_string_length, mnemonic_key_sequences.forward, 
			     mnemonic_key_sequences.backward, mnemonic_key_sequences.left,
			     mnemonic_key_sequences.right, mnemonic_key_sequences.help,
			     mnemonic_key_sequences.set_key, mnemonic_key_sequences.set_scroll_increment,
			     mnemonic_key_sequences.quit, mnemonic_key_sequences.redisplay,
			     mnemonic_key_sequences.start_of_report, mnemonic_key_sequences.end_of_report,
			     mnemonic_key_sequences.multics_mode, mnemonic_key_sequences.goto);
			call write_help_string (PROMPT, fh_character_read);
		     end;
		     else call help_for_function (fh_still_looking_for_a_valid_response);
		end;
		if fh_still_looking_for_a_valid_response
		then do;
		     call window_$bell (window_iocb_ptr, code);
		     call check_code;
		end;
	     end;
%skip(1);
	     if fh_character_read ^= "h"
	     then fh_still_helpful = OFF;
%skip(1);
	end;
%skip(1);
	return;
%page;
help_for_function: proc (

	hff_invalid_function_parm	/* output: off if it was a valid function */
		    );
%skip(1);
dcl hff_function_number fixed bin;
dcl hff_invalid_function_parm bit (1) aligned parm;
dcl hff_loop fixed bin;
dcl hff_target_function char (32);
%skip(1);
/*
	Find the scroll function by name or mnemonic key sequence. Write
	the help string for it.
*/
%skip(1);
	hff_invalid_function_parm = ON;
	hff_target_function = substr (fh_users_response, 1, fh_number_of_chars_read);
%skip(1);
	do hff_loop = 1 to HIGHEST_DISPLAY_FUNCTION_NUMBER
	     while (hff_invalid_function_parm);
	     if hff_target_function = FUNCTION_NAMES_AS_A_TABLE (hff_loop)
	     | hff_target_function = mnemonic_key_sequences_as_a_table (hff_loop)
	     then do;
		hff_invalid_function_parm = OFF;
		hff_function_number = hff_loop;
	     end;
	end;
%skip(1);
	if hff_invalid_function_parm
	then return;
%skip(1);
	call ioa_$rsnnl (HELP_HEADER_CONTROL_STRING, fh_returned_help_list,
	     fh_number_of_chars_read, FUNCTION_NAMES_AS_A_TABLE (hff_function_number),
	     mnemonic_key_sequences_as_a_table (hff_function_number), HELP_MESSAGES (hff_function_number));
	call format_document_$string (fh_returned_help_list, fh_help_string,
	     fh_help_string_length, format_document_options_ptr, code);
	if code ^= 0
	then call abort_line (code, "");
	call write_help_string (PROMPT, fh_character_read);
%skip(1);
	return;
%skip(1);
     end help_for_function;
%page;
write_help_string: proc (

	whs_prompt_parm,	/* input: on means prompt to make sure user has seen it */
	whs_char_read_parm  /* output: the char read if above bit is on */
		    );
%skip(1);
dcl whs_char_read_parm char (1) varying parm;
dcl whs_current_position fixed bin;
dcl whs_current_line_on_screen fixed bin;
dcl whs_new_line_position fixed bin;
dcl whs_prompt_parm bit (1) aligned parm;
dcl whs_still_filling bit (1) aligned;
dcl whs_wants_more bit (1) aligned;
%skip(1);
	/* Fill and write the help string with optional prompt. */
%skip(1);
	whs_still_filling = ON;
	whs_current_position = 1;
	whs_current_line_on_screen = 1;
	if whs_prompt_parm
	then do;
	     substr (fh_help_string, fh_help_string_length + 1) = HOW_TO_END_DISPLAY_MESSAGE;
	     fh_help_string_length = fh_help_string_length + length (HOW_TO_END_DISPLAY_MESSAGE) + 1;
	end;
	else whs_char_read_parm = "";
	call window_$clear_window (window_iocb_ptr, code);
	call check_code;
%skip(1);
	do while (whs_still_filling);
	     whs_new_line_position = index (substr (fh_help_string, whs_current_position), NEWLINE);
	     if whs_new_line_position = 0
	     then whs_still_filling = OFF;
	     else do;
		if whs_current_line_on_screen = report_output_window_position_info.height
		then do;
		     call prompt_for_more (whs_current_line_on_screen, whs_wants_more);
		     if ^whs_wants_more
		     then do;
			call fkp_redisplay;
			return;
		     end;
		     else whs_current_line_on_screen = 1;
		end;
		call window_$position_cursor (window_iocb_ptr, whs_current_line_on_screen, 1, code);
		call check_code;
		call window_$clear_to_end_of_line (window_iocb_ptr, code);
		call check_code;
		call window_$overwrite_text (window_iocb_ptr,
		     substr (fh_help_string, whs_current_position, whs_new_line_position - 1), code);
		call check_code;
		whs_current_line_on_screen = whs_current_line_on_screen + 1;
		whs_current_position = whs_current_position + whs_new_line_position;
		if whs_current_position > fh_help_string_length
		then whs_still_filling = OFF;
	     end;
	end;
%skip(1);
	if whs_prompt_parm
	then do;
	     call window_$get_one_unechoed_char (window_iocb_ptr, whs_char_read_parm, ON, code);
	     call check_code;
	end;
%skip(1);
	return;
%skip(1);
     end write_help_string;
%skip(1);
     end fkp_help;
%page;
fkp_left: proc;
%skip(3);
/*
	Make sure we don't go left if we're at character position 1. Move
	left and adjust if we're too far left. If we've used two buffers
	in the previous display return to rw_display so it can get us
	back to the first.
*/
%skip(1);
	if scroll_info.left_vertical_position = 1
	then do;
	     sfnc_still_looking_for_a_valid_response = ON;
	     return;
	end;
%skip(1);
	scroll_info.left_vertical_position = max (
	     scroll_info.left_vertical_position - scroll_info.horizontal_scroll_distance, 1);
%skip(1);
	if scroll_info.flags.buffer_boundary_just_crossed
	then do;
	     still_in_the_scrolling_business = OFF;
	     scroll_info.flags.buffer_boundary_just_crossed = OFF;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_left;
%page;
fkp_multics_mode: proc;
%skip(3);
/*
	If window is user_i/o then clear it. Write message telling user how
	to get back to display. Get to Multics level. Do a redisplay.
*/
%skip(1);
	if window_iocb_ptr = iox_$user_io | window_iocb_ptr = iox_$user_output
	then call window_$clear_window (window_iocb_ptr, code);
	call check_code;
	call window_$position_cursor (window_iocb_ptr, 1, 1, code);
	call check_code;
	call window_$clear_to_end_of_line (window_iocb_ptr, code);
	call check_code;
	call window_$overwrite_text (window_iocb_ptr, HOW_TO_GET_BACK_MESSAGE, code);
	call check_code;
	if window_iocb_ptr = iox_$user_io | window_iocb_ptr = iox_$user_output
	then do;
	     call window_$position_cursor (window_iocb_ptr, 2, 1, code);
	     call check_code;
	end;
%skip(1);
	unspec (command_level_flags) = OFF;
	call cu_$cl (command_level_flags);
	call fkp_redisplay;
%skip(1);
	return;
%skip(1);
     end fkp_multics_mode;
%page;
fkp_quit: proc;
%skip(3);
	/* Thank you for using this product. Come back y'all. */
%skip(1);
	code = error_table_$end_of_info;
	still_in_the_scrolling_business = OFF;
%skip(1);
	return;
%skip(1);
     end fkp_quit;
%page;
fkp_redisplay: proc;
%skip(3);
	/* This is all it takes to get a redisplay. Pretty simple huh? */
%skip(1);
	still_in_the_scrolling_business = OFF;
%skip(1);
	return;
%skip(1);
     end fkp_redisplay;
%page;
fkp_right: proc;
%skip(3);
/*
	Make sure we son't go too far right. If we used two buffers during 
	the last display then return to rw_display so it can get us
	back the first one.
*/
%skip(1);
	if scroll_info.left_vertical_position + report_output_window_position_info.width >= page_info.width
	then do;
	     sfnc_still_looking_for_a_valid_response = ON;
	     return;
	end;
%skip(1);
	scroll_info.left_vertical_position
	     = scroll_info.left_vertical_position + scroll_info.horizontal_scroll_distance;
%skip(1);
	if scroll_info.flags.buffer_boundary_just_crossed
	then do;
	     still_in_the_scrolling_business = OFF;
	     scroll_info.flags.buffer_boundary_just_crossed = OFF;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_right;
%page;
fkp_set_key: proc;
%skip(3);
dcl fkp_valid_response bit (1) aligned;
dcl fkp_prompt char (21);
%skip(1);
/*
	Prompt for function name and mnemonic key sequence. Assign the
	key sequence to the function.
*/
%skip(1);
	fkp_prompt = "Function name";
	fkp_valid_response = OFF;
%skip(1);
	do while (^fkp_valid_response);
	     call prompt_user (fkp_prompt, 0, users_response, NON_NUMERIC_RESPONSE);
	     function_name = users_response;
	     fkp_valid_response = valid_function_name (function_name);
	     if ^fkp_valid_response
	     then call window_$bell (window_iocb_ptr, code);
	     call check_code;
	end;
%skip(1);
	fkp_prompt = "Mnemonic key sequence";
	fkp_valid_response = OFF;
%skip(1);
	do while (^fkp_valid_response);
	     call prompt_user (fkp_prompt, 0,
		users_response, NON_NUMERIC_RESPONSE);
	     call set_function_key (function_name, users_response, code);
	     fkp_valid_response = (code = 0);
	     if ^fkp_valid_response
	     then call window_$bell (window_iocb_ptr, code);
	     call check_code;
	end;
%skip(1);
	return;
%skip(1);
     end fkp_set_key;
%page;
fkp_set_scroll_increment: proc;
%skip(3);
	call set_scroll_height_or_width;
%skip(1);
	return;
%skip(1);
     end fkp_set_scroll_increment;
%page;
fkp_start_of_report: proc;
%skip(3);
	/* Return to rw_display so it can get us page 1 or buffer 1. */
%skip(1);
	still_in_the_scrolling_business = OFF;
	scroll_info.target_page_number = 1;
	scroll_info.target_line_number = 1;
%skip(1);
	return;
%skip(1);
     end fkp_start_of_report;
%page;
set_scroll_height_or_width: proc;
%skip(1);
dcl sshow_height bit (1) aligned;
dcl sshow_prompt char (42);
dcl sshow_scroll_height_or_width fixed bin (35);
dcl sshow_still_looking_for_a_valid_response bit (1) aligned;
%skip(1);
	/* Set the scroll increment for height or width. */
%skip(1);
	sshow_prompt = """h"" for height, anything else for width";
	call prompt_user (sshow_prompt, sshow_scroll_height_or_width,
	     users_response, NON_NUMERIC_RESPONSE);
	sshow_height = (users_response = "h");
	if sshow_height
	then sshow_prompt = "New scroll height";
	else sshow_prompt = "New scroll width";
%skip(1);
	sshow_still_looking_for_a_valid_response = ON;
%skip(1);
	do while (sshow_still_looking_for_a_valid_response);
	     sshow_still_looking_for_a_valid_response = OFF;
	     call prompt_user (sshow_prompt, sshow_scroll_height_or_width,
		users_response, NUMERIC_RESPONSE);
	     if sshow_height
	     then if sshow_scroll_height_or_width > page_info.length
		| sshow_scroll_height_or_width < TOP_MARGIN_HEIGHT
		then sshow_still_looking_for_a_valid_response = ON;
	          else;
	     else if sshow_scroll_height_or_width > page_info.width
		then sshow_still_looking_for_a_valid_response = ON;
	          else;
	     if ^sshow_still_looking_for_a_valid_response
	     then if sshow_height
		then scroll_info.vertical_scroll_distance = sshow_scroll_height_or_width;
	          else scroll_info.horizontal_scroll_distance = sshow_scroll_height_or_width;
	     else;
	     if ^sshow_still_looking_for_a_valid_response
	     then call fkp_redisplay;
	     else do;
		call window_$bell (window_iocb_ptr, code);
		call check_code;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end set_scroll_height_or_width;
%skip(1);
     end setup_for_next_chunk;
%page;
setup_scroll: proc;
%skip(3);
	/* Set the pointers we will need. */
%skip(1);
	scroll_ip = display_results.scroll_info_ptr;
	scroll_info.display_arg_results_ptr = display_results_ptr;
	scroll_info.report_control_info_ptr = report_cip;
	scroll_info.area_ptr = work_area_ptr;
	scroll_info.ssu_info_ptr = sci_ptr;
%skip(1);
	/* Allocate the structures for the user_i/o and report windows, and the window_status_info. */
%skip(1);
	allocate user_io_window_position_info in (work_area)
	     set (user_io_window_position_ip);
	scroll_info.user_io_window_position_info_ptr
	     = user_io_window_position_ip;
	unspec (user_io_window_position_info) = OFF;
	user_io_window_position_info.version = window_position_info_version_1;
%skip(1);
	allocate report_output_window_position_info in (work_area)
	     set (report_output_window_position_ip);
	scroll_info.report_output_window_position_info_ptr
	     = report_output_window_position_ip;
	report_output_window_position_info = user_io_window_position_info;
%skip(1);
	allocate window_status_info in (work_area) set (window_status_info_ptr);
	window_status_info.version = window_status_version_1;
	scroll_info.window_status_info_pointer = window_status_info_ptr;
%skip(1);
	/* Turn on the video system if it's not already on. */
%skip(1);
	if video_data_$terminal_iocb = null ()
	then do;
	     scroll_info.flags.video_was_already_on = OFF;
	     call video_utils_$turn_on_login_channel (code, reason);
	     if code ^= 0
	     then call abort_line (code, reason);
	end;
	else scroll_info.flags.video_was_already_on = ON;
%page;
/*
	If -window was specified by the user make sure it meets the 
	requirements. If it wasn't setup a shriek named window and
	shrink user_i/o.
*/
%skip(1);
	if display_results.window_flag
	then do;
	     call iox_$look_iocb (display_results.window_name, window_iocb_ptr, code);
	     if code ^= 0
	     then call abort_line (code, "The window " || rtrim (display_results.window_name) || " doesn't exist.");
	     if window_iocb_ptr -> iocb.attach_descrip_ptr ^= null ()
	     then if window_iocb_ptr -> iocb.open_descrip_ptr = null ()
		then call abort_line (0, "The output switch "
		     || rtrim (display_results.window_name) || " is attached but not open.");
	          else;
	     else call abort_line (0, "The output switch "
		|| rtrim (display_results.window_name) || " is not attached.");
	     scroll_info.flags.user_io_was_shrunk = OFF;
	     call iox_$control (window_iocb_ptr, "get_window_info", 
		report_output_window_position_ip, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to get the window information.");
	     if report_output_window_position_info.height < MINIMUM_WINDOW_SIZE
	     then call abort_line (0, MINIMUM_WINDOW_SIZE_ERROR_MESSAGE);
	end;
	else do;
	     scroll_info.flags.user_io_was_shrunk = ON;
	     call iox_$control (iox_$user_io, "get_window_info", 
		user_io_window_position_ip, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to get the window information.");
	     if user_io_window_position_info.height < MINIMUM_LINES_NEEDED
	     then call abort_line (video_et_$insuff_room_for_window,
		MINIMUM_LINES_NEEDED_ERROR_MESSAGE);
	     call window_$clear_window (iox_$user_io, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to clear the user_i/o window.");
	     report_output_window_position_info = user_io_window_position_info;
	     user_io_window_position_info.line = user_io_window_position_info.line
		+ user_io_window_position_info.height - USER_IO_WINDOW_HEIGHT;
	     user_io_window_position_info.height = USER_IO_WINDOW_HEIGHT;
	     call iox_$control (iox_$user_io, "set_window_info",
		user_io_window_position_ip, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to set the window info for user_i/o.");
	     switch_name =  unique_chars_ ("0"b) || ".rw_display";
	     call iox_$find_iocb (switch_name, window_iocb_ptr, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to find the io control block for "
		|| rtrim (switch_name) || ".");
	     report_output_window_position_info.height
		= report_output_window_position_info.height - USER_IO_WINDOW_HEIGHT;
	     call window_$create (video_data_$terminal_iocb,
		report_output_window_position_ip, window_iocb_ptr, code);
	     if code ^= 0
	     then call abort_line (code, "Unable to create the window for the report.");
	end;
%skip(1);
	/* Fill in the scroll_info and format_document_options structures. */
%skip(1);
	report_control_info.display_iocb_ptr = window_iocb_ptr;
%skip(1);
	scroll_info.number_of_lines_for_report_display = report_output_window_position_info.height;
	scroll_info.vertical_scroll_distance = report_output_window_position_info.height - 1;
	scroll_info.horizontal_scroll_distance = report_output_window_position_info.width - 10;
	scroll_info.target_page_number = 1;
	scroll_info.target_line_number = 1;
	scroll_info.left_vertical_position = 1;
%skip(1);
	allocate format_document_options in (work_area) set (format_document_options_ptr);
	unspec (format_document_options) = OFF;
	format_document_options.version_number = format_document_version_2;
	format_document_options.switches.galley_sw = ON;
	format_document_options.switches.break_word_sw = ON;
	format_document_options.switches.max_line_length_sw = ON;
	format_document_options.switches.sub_err_sw = ON;
	format_document_options.switches.literal_sw = ON;
	format_document_options.switches.dont_compress_sw = ON;
	format_document_options.line_length = report_output_window_position_info.width;
	format_document_options.switches.adj_sw = OFF;
	scroll_info.format_document_op = format_document_options_ptr;
%skip(1);
	return;
%skip(1);
     end setup_scroll;
%page;
terminate_scroll: proc;
%skip(3);
/*
	Clear the window. Destroy the window and restore user_i/o back to
	it's original size if -window wasn't given by the user. Turn off
	the video system if we turned it on.
*/
%skip(1);
	call window_$clear_window (window_iocb_ptr, code);
	if code ^= 0
	then call ssu_$print_message (sci_ptr, code);
%skip(1);
	if ^display_results.window_flag
	then do;
	     call window_$destroy (window_iocb_ptr, code);
	     if code ^= 0
	     then call ssu_$print_message (sci_ptr, code);
	     user_io_window_position_info.line
		= report_output_window_position_info.line;
	     user_io_window_position_info.height 
		= report_output_window_position_info.height
		+ user_io_window_position_info.height;
	     call iox_$control (iox_$user_io, "set_window_info",
		user_io_window_position_info_ptr, code);
	     if code ^= 0
	     then call ssu_$print_message (sci_ptr, code);
	     call iox_$destroy_iocb (window_iocb_ptr, code);
	     if code ^= 0
	     then call ssu_$print_message (sci_ptr, code);
	end;
%skip(1);
	if ^scroll_info.flags.video_was_already_on
	then do;
	     call video_utils_$turn_off_login_channel (code);
	     if code ^= 0
	     then call ssu_$print_message (sci_ptr, code);
	end;
%skip(1);
	if user_io_window_position_ip ^= null
	then free user_io_window_position_info;
	if report_output_window_position_ip ^= null
	then free report_output_window_position_info;
	if window_status_info_ptr ^= null
	then free window_status_info;
	if format_document_options_ptr ^= null
	then free format_document_options;
%skip(1);
	return;
%skip(1);
     end terminate_scroll;
%page;
valid_function_name: proc (

	vfn_function_name_parm)	/* input: function name */

	returns (bit (1) aligned);
%skip(3);
dcl vfn_function_name_parm char (*) parm;
%skip(1);
	/* Return true if it's a valid function name. */
%skip(3);
	return ((vfn_function_name_parm = FUNCTION_NAMES.FORWARD)
	     | (vfn_function_name_parm = FUNCTION_NAMES.BACKWARD)
	     | (vfn_function_name_parm = FUNCTION_NAMES.LEFT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.RIGHT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.HELP)
	     | (vfn_function_name_parm = FUNCTION_NAMES.SET_KEY)
	     | (vfn_function_name_parm = FUNCTION_NAMES.SET_SCROLL_INCREMENT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.QUIT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.REDISPLAY)
	     | (vfn_function_name_parm = FUNCTION_NAMES.START_OF_REPORT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.END_OF_REPORT)
	     | (vfn_function_name_parm = FUNCTION_NAMES.MULTICS_MODE)
	     | (vfn_function_name_parm = FUNCTION_NAMES.GOTO));
%skip(1);
     end valid_function_name;
%page;
dcl BLANK char (1) static internal options (constant) init (" ");
%skip(1);
dcl CARRIAGE_RETURN char (1) static internal options (constant) init ("");
dcl CONTROL_HYPHEN char (8) static internal options (constant) init ("control-");
dcl CTL_HYPHEN char (4) static internal options (constant) init ("ctl-");
%skip(1);
dcl DEL char (1) static internal options (constant) init ("");
dcl DIGITS char (10) static int options (constant) init ("0123456789");
%skip(1);
dcl ESCAPE char (1) static internal options (constant) init ("");
dcl ESC_HYPHEN char (4) static internal options (constant) init ("esc-");
dcl ESCAPE_HYPHEN char (7) static internal options (constant) init ("escape-");
%skip(1);
dcl GENERAL_HELP_MESSAGE char (128) static internal options (constant) init (
"Type the function name or mnemonic key sequence, or type ?? for a list of function names and key sequences. (end with RETURN) ->");
dcl GENERAL_HELP_LIST char (2) static internal options (constant) init ("??");
dcl GENERAL_HELP_LIST_MESSAGE char (203) static internal options (constant) init (
"forward (^a)^/backward (^a)^/left (^a)^/right (^a)^/help (^a)^/set_key (^a)^/set_scroll_increment (^a)^/quit (^a)^/redisplay (^a)^/start_of_report (^a)^/end_of_report (^a)^/multics_mode (^a)^/goto (^a)^/");
%skip(1);
dcl HOME char (4) static internal options (constant) init ("home");
dcl HELP_HEADER_CONTROL_STRING char (15) internal static options (constant) init ("^a^x(^a)^2/^a^/");
dcl HELP_MESSAGES (13) char (254) internal static options (constant) init (

"The forward function moves the window forward into the report. The scroll height controls how many lines forward the window moves. The set_scroll_increment function can be used to change the scroll height.",

"The backward function moves the window backward into the report. The scroll height controls how many lines backward the window moves. The set_scroll_increment function can be used to change the scroll height.",

"The left function moves the window left in the report. The scroll width controls how many characters left the window moves. The set_scroll_increment function can be used to change the scroll width.",

"The right function moves the window right in the report. The scroll width controls how many characters right the window moves. The set_scroll_increment function can be used to change the scroll width.",

"The help function provides general information on the display function names and key sequences used to invoke the functions, or, more detailed help on any specific display function.",

"The set_key function provides a way to associate key sequences with display functions. The function name and mnemonic key sequences are prompted for.",

"The set_scroll_increment function provides a way to change the scroll height and width. Height is the number of lines forward or backward that the window will move; width is the number of characters left or right that the window will move.",

"The quit function terminates the current invocation of the display request.",

"The redisplay function redisplays the contents of the window. This is useful after the window contents have become invalid due to line noise, interactive messages, etc.",

"The start_of_report function provides a way to get back to the start of the report from any arbitrary place in the report.",

"The end_of_report function provides a way to get to the end of the report from any arbitrary place in the report.",

"The multics_mode function provides a way to suspend the current invocation of display and use other Multics facilities. Typing ""start"" resumes the suspended invocation of display.",

"The goto function provides a means to go directly to any page within a paginated report, or, directly to any line number within an unpaginated report."
);
dcl HOW_TO_END_DISPLAY_MESSAGE char (62) static internal options (constant) init ("Type any single character for redisplay or h for more help ->
");
dcl HOW_TO_GET_BACK_MESSAGE char (38) static internal options (constant) init (
"Type ""start"" to get back to display.");
%skip(1);
dcl LARGEST_LINE_NUMBER fixed bin (35) static internal options (constant) init (34359738365);
dcl LARGEST_PAGE_NUMBER fixed bin (21) static internal options (constant) init (2097151);
%skip(1);
dcl MINIMUM_LINES_NEEDED fixed bin static internal options (constant) init (9);
dcl MINIMUM_LINES_NEEDED_ERROR_MESSAGE char (45) static internal options (constant) init ("The user_i/o window must be at least 9 lines.");
dcl MINIMUM_WINDOW_SIZE fixed bin static internal options (constant) init (5);
dcl MINIMUM_WINDOW_SIZE_ERROR_MESSAGE char (45) static internal options (constant) init (
"The provided window must be at least 5 lines.");
dcl MORE_PROMPT char (47) static internal options (constant) init (
"More? (RETURN for more; DEL to discard output.)");
%skip(1);
dcl NEWLINE char (1) static internal options (constant) init ("
");
dcl NO_PROMPT bit (1) aligned internal static options (constant) init ("0"b);
dcl NON_NUMERIC_RESPONSE bit (1) aligned static int options (constant) init ("0"b);
dcl NUMERIC_RESPONSE bit (1) aligned static int options (constant) init ("1"b);
%skip(1);
dcl OFF bit (1) aligned static internal options (constant) init ("0"b);
dcl ON bit (1) aligned static internal options (constant) init ("1"b);
%skip(1);
dcl PROMPT bit (1) aligned internal static options (constant) init ("1"b);
%skip(1);
dcl TRANSLATION_TABLE char (63) internal static options (constant) init (
"@ABCDEFGHIJKLMNOPQRSTUVWXYZ1\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
dcl TOP_MARGIN_HEIGHT fixed bin static int options (constant) init (4);
%skip(1);
dcl USER_IO_WINDOW_HEIGHT fixed bin static int options (constant) init (4);
%page;
dcl addr builtin;
%skip(1);
dcl byte builtin;
%skip(1);
dcl code fixed bin (35);
dcl 1 command_level_flags aligned,
      2 reset_sw bit (1) unaligned,
      2 mbx bit (35) unaligned;
dcl convert builtin;
dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned);
dcl cu_$cl entry (1 aligned, 2 bit(1) unal, 2 bit(35) unal);
%skip(1);
dcl 1 display_results like display_arg_results based (display_results_ptr);
dcl display_results_ptr ptr;
%skip(1);
dcl error_message char (256) varying;
dcl error_table_$end_of_info fixed bin(35) ext static;
dcl error_table_$long_record fixed bin(35) ext static;
%skip(1);
dcl format_document_$string entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35));
dcl function_name char (32);
dcl function_key_sequence char (32);
%skip(1);
dcl hbound builtin;
%skip(1);
dcl index builtin;
dcl ioa_$rsnnl entry() options(variable);
%skip(1);
dcl length builtin;
dcl long_message char (100) aligned;
dcl ltrim builtin;
%skip(1);
dcl max builtin;
dcl min builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl reason char (64);
dcl 1 report_output_window_position_info like window_position_info based (report_output_window_position_ip);
dcl report_output_window_position_ip ptr;
dcl rtrim builtin;
dcl rw_error_$bad_fkey_name fixed bin(35) ext static;
dcl rw_error_$bad_fkey_sequence fixed bin(35) ext static;
dcl rw_error_$bad_report_display fixed bin(35) ext static;
%skip(1);
dcl sci_ptr ptr;
dcl short_message char (8) aligned;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$print_message entry() options(variable);
dcl still_in_the_scrolling_business bit (1) aligned;
dcl substr builtin;
dcl switch_name char (42);
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl unique_chars_ entry (bit(*)) returns(char(15));
dcl unspec builtin;
dcl 1 user_io_window_position_info like window_position_info based (user_io_window_position_ip);
dcl user_io_window_position_ip ptr;
dcl users_response char (32);
%skip(1);
dcl verify builtin;
dcl video_data_$terminal_iocb ptr static external;
dcl video_et_$insuff_room_for_window fixed bin(35) ext static;
dcl video_et_$window_status_pending fixed bin(35) ext static;
dcl video_utils_$turn_on_login_channel entry (fixed bin(35), char(*));
dcl video_utils_$turn_off_login_channel entry (fixed bin(35));
%skip(1);
dcl window_iocb_ptr ptr;
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include format_document_options;
%page;
%include function_key_data;
%page;
%include iocb;
%page;
%include iox_dcls;
%page;
%include rw_display_arg_list;
%page;
%include rw_options_extents;
%page;
%include rw_page_info;
%page;
%include rw_report_info;
%page;
%include rw_scroll_info;
%page;
%include window_control_info;
%page;
%include window_dcls;
%skip(1);
     end rw_display_scroll;




		    rw_error_.alm                   11/05/86  1302.0r w 11/04/86  1038.1       14067



"  ***********************************************************
"  *                                                         *
"  *                                                         *
"  * Copyright, (C) Honeywell Information Systems Inc., 1984 *
"  *                                                         *
"  *                                                         *
"  ***********************************************************

" report_writer_ Error Table
" Written - Al Dupuis - October 1984

	include	et_macros
	et	rw_error_

ec bad_fkey_name,badfname,
	(An unacceptable scroll function name has been used.)
ec bad_fkey_sequence,badfseq,
	(An unacceptable function key sequence has been used.)
ec bad_option_identifier,badoi,
	(An unacceptable option identifier has been used.)
ec bad_option_name,badon,
	(An unacceptable option name has been used.)
ec bad_option_value,badov,
	(An unacceptable option value has been used.)
ec bad_report_display,badrpdi,
	(An error has occured while displaying the report.)
ec bad_report_format,badrpfmt,
	(An error has occurred while formatting the report.)
ec bad_report_setup,badrpstp,
	(An error has occurred while setting up the report.)
ec logic_error,logicerr,
	(A logic error has occurred during execution of a program.)
ec no_columns_defined,nocols,
	(No columns have been selected yet.)
ec no_data,nodata,
	(No data was found that satisfied the search.)
ec no_report,norpt,
	(There is no report currently in progress.)
ec no_ssu_ptr_match,nossupm,
	(No match with the supplied ssu_ info pointer.)
	end




		    rw_fr_build_page.pl1            11/16/84  1355.8rew 11/16/84  1354.3     1037988



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module is the report_writer_ page building subroutine called by
     rw_display. Description and usage follows.

     Description:

     This module is called to build a single page and return to its caller.
     In the case of unpaginated reports it builds a buffer (a portion of the
     single page an unpaginated report is made up of). In the case of multiple
     pass reports this module formats the report the number of passes minus
     one, then formats the first page or buffer of the last pass and returns
     to its caller.

     Usage:

     See the parameter list for usage.

     Known Bugs:
 
     Other Problems:

     History:

     Written - Al Dupuis - August 1983

     Modified: Al Dupuis - October 26, 1983. Added lines in internal procedure
     check_for_outlining to make sure that the column being outlined isn't
     excluded from the page.

     Changed - Al Dupuis - October 1984 - Became report_writer_.
*/
%page;
/*

	   Formatted Page		Mainline Processing Overview

     ________________________________
     |         PAGE HEADER          |	1. Format the page header.
     |______________________________|
     |         TITLE BLOCK          |	2. Format the title block.
     |______________________________|
     |        DETAIL BLOCK          |	3. Format N detail blocks (see below).
     |______________________________|
     |         PAGE FOOTER          |	4. Format the page footer.
     |______________________________|



	   Detail Block		Detail Block Processing Overview

     --------------------------------
     |      GROUP HEADER	      |   1. Format the group header.
     |______________________________|
     |        ROW HEADER            |	2. Format the row header.
     |______________________________|
     |        ROW VALUE             |	3. Format the row value.
     |______________________________|
     |      SUBTOTAL BLOCK          |	4. Format the subtotal block.
     |______________________________|
     |      SUBCOUNT BLOCK          |   5. Format the subcount block.
     |______________________________|
     |       TOTAL BLOCK            |	6. Format the total block.
     |______________________________|
     |       COUNT BLOCK	      |   7. Format the count block.
     |______________________________|
     |        ROW FOOTER            |	8. Format the row footer.
     |______________________________|
     |      GROUP FOOTER            |   9. Format the group footer.
     |______________________________|


     The above mainline is done once per page for every page of the report.
     A return is done to the caller after every page is built. If the
     multi-pass feature is being used, no output is produced until the last
     pass. This means that the entire report is done "n" times without
     returning to the caller, where "n" is one less than the requested
     number of passes. On the final pass it returns to the caller after each
     page is built.

*/
%page;
rw_fr_build_page: proc (

	report_cip_parm,	/* input: points to report_control_info */
	page_info_ptr_parm,	/* output: description of the page */
	code_parm		/* output: success or failure */
		      );
%skip(1);
dcl code_parm fixed bin (35) parm;
dcl page_info_ptr_parm ptr parm;
dcl report_cip_parm ptr parm;
%skip(3);
	report_cip = report_cip_parm;
	call housekeeping;
	call setup_for_a_page;
	call make_rows_available;
	on sub_error_ call sub_error_handler;
%skip(1);
	if ^report_control_info.flags.multi_pass_mode
	then do;
	     call build_page;
	     return;
	end;
%skip(1);
	status.flags.last_pass = OFF;
	do status.current_pass_number = 1 to report_control_info.number_of_passes - 1;
	     do while (^report_control_info.flags.report_has_just_been_completed);
		call build_page;
		if ^report_control_info.flags.report_has_just_been_completed
		then call setup_for_a_page;
	     end;
	     call adjust_multi_pass_execution_control_info;
	     call setup_for_a_page;
	end;
%skip(1);
	report_control_info.flags.multi_pass_mode = OFF;
	status.flags.last_pass = ON;
	call build_page;
%skip(1);
	return;
%page;
adjust_multi_pass_execution_control_info: proc;
%skip(3);
     /* Just completed one pass of the report, set up for the next pass.  */
%skip(1);
	status.current_row_ptr = null ();
	status.previous_row_ptr = null ();
	status.next_row_ptr = make_ptr (1);
%skip(1);
	status.last_page_number = status.current_page_number;
	status.last_row_number = report_control_info.no_of_rows_retrieved;
	status.highest_row_formatted = 0;
%skip(1);
	if format_report_info.flags.subtotal_is_defined
	then do;
	     subtotal_info.columns.subtotal (*) = 0;
	     subtotal_generation_info.current_generation_block = -1;
	end;
	if format_report_info.flags.total_is_defined
	then total_info.columns.total (*) = 0;
%skip(1);
	if format_report_info.flags.subcount_is_defined
	then do;
	     subcount_info.columns.subtotal (*) = 0;
	     subcount_generation_info.current_generation_block = -1;
	end;
	if format_report_info.flags.count_is_defined
	then count_info.columns.total (*) = 0;
%skip(1);
	report_control_info.flags.report_is_formatted = OFF;
	report_control_info.flags.report_has_just_been_completed = OFF;
	report_control_info.no_of_formatted_pages = 0;
%skip(1);
	format_report_info.number_of_formatted_rows = 0;
%skip(1);
	return;
%skip(1);
     end adjust_multi_pass_execution_control_info;
%page;
backout_detail_block: proc (

	bdb_object_doing_the_back_out_parm /* input: the caller */
		       );
%skip(1);
dcl bdb_object_doing_the_back_out_parm char (*) varying parm;
%skip(1);
     /* Remove one detail block from the page, make sure it isn't the first. */
%skip(1);
	if status.total_number_of_rows_used ^> 0
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_format,
	     "^/There isn't enough room to place the ^a on page number ^d."
	     || "^/The current row number is ^d.",
	     bdb_object_doing_the_back_out_parm,
	     status.current_page_number, status.current_row_number);
%skip(1);
	status.flags.page_overflow = ON;
	status.flags.last_row_of_report = OFF;
	status.current_line_on_page = formatted_page_info.detail_blocks
	     (formatted_page_info.number_of_detail_blocks).beginning_line_number;
	status.remaining_lines_on_page = template_map_number_of_bits - status.current_line_on_page + 1;
	status.flags.still_formatting_detail_blocks = OFF;
	if page_info.page_overstrike_info_ptr ^= null ()
	then substr (page_overstrike_info_redefined.bit_map, ((status.current_line_on_page - 1) * page_info.width) + 1) = OFF;
%skip(1);
	status.next_row_ptr = status.current_row_ptr;
	status.current_row_ptr = status.previous_row_ptr;
	if status.current_row_number < 3
	then status.previous_row_ptr = null ();
	else status.previous_row_ptr = make_ptr (status.current_row_number - 2);
%skip(1);
	if format_report_info.flags.subtotal_is_defined
	then call backout_subtotal_block;
	status.flags.totals_ejection_in_progress = OFF;
	status.flags.subtotals_ejection_in_progress = OFF;
%skip(1);
	if format_report_info.flags.subcount_is_defined
	then call backout_subcount_block;
	status.flags.counts_ejection_in_progress = OFF;
	status.flags.subcounts_ejection_in_progress = OFF;
%skip(1);
	substr (template_map_defined_as_a_string, status.current_line_on_page) = OFF;
	formatted_page_info.number_of_detail_blocks = formatted_page_info.number_of_detail_blocks - 1;
%skip(1);
	return;
%skip(1);
     end backout_detail_block;
%page;
backout_subcount_block: proc;
%skip(1);
dcl bsb_loop fixed bin;
%skip(1);
     /* Back out the subtotal block if we've generated it or are in the process of generating it.  */
%skip(1);
	if formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).subcount_length ^= 0
	| status.flags.subcounts_ejection_in_progress
	then do;
	     subcount_generation_info.current_generation_block
		= mod (subcount_generation_info.current_generation_block,
		subcount_generation_info.maximum_number_of_generation_blocks);
	     do bsb_loop = 1 to subcount_generation_info.number_of_subtotals;
		subcount_info.columns (bsb_loop).subtotal
		     = subcount_generation_info.generations
		     (subcount_generation_info.current_generation_block).subtotals (bsb_loop);
	     end;
	end;
%skip(1);
	do bsb_loop = 1 to subcount_info.number_of_columns_to_subtotal;
	     subcount_info.columns (bsb_loop).subtotal
		= subcount_info.columns (bsb_loop).subtotal - 1;
	end;
%skip(1);
	return;
%skip(1);
     end backout_subcount_block;
%page;
backout_subtotal_block: proc;
%skip(1);
dcl bsb_loop fixed bin;
%skip(1);
     /* Back out the subcount block if we've generated it or are in the process of generating it.  */
%skip(1);
	if formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).subtotal_length ^= 0
	| status.flags.subtotals_ejection_in_progress
	then do;
	     subtotal_generation_info.current_generation_block
		= mod (subtotal_generation_info.current_generation_block,
		subtotal_generation_info.maximum_number_of_generation_blocks);
	     do bsb_loop = 1 to subtotal_generation_info.number_of_subtotals;
		subtotal_info.columns (bsb_loop).subtotal
		     = subtotal_generation_info.generations
		     (subtotal_generation_info.current_generation_block).subtotals (bsb_loop);
	     end;
	end;
%skip(1);
	do bsb_loop = 1 to subtotal_info.number_of_columns_to_subtotal;
	     subtotal_info.columns (bsb_loop).subtotal
		= subtotal_info.columns (bsb_loop).subtotal
		- float (substr (next_row_value,
		table_info.columns.column_index (subtotal_info.columns (bsb_loop).input_column),
		table_info.columns.column_length (subtotal_info.columns (bsb_loop).input_column)));
	end;
%skip(1);
	return;
%skip(1);
     end backout_subtotal_block;
%page;
build_page: proc;
%skip(1);
/*
     Make the pointers to the rows. Do the page header, the title block,
     as many detail blocks as will fit, and the page footer. Use
     the alogorithm as described back in the picture at the beginning of this
     module. Close the page. Optionally save a copy of it.
*/
%skip(1);
	call make_row_ptrs;
	if format_report_info.flags.page_header_is_defined
	then call format_page_header;
	if format_report_info.flags.title_block_is_defined
	then call format_title_block;
	first_time_through_the_detail_block_loop = ON;
	status.still_formatting_detail_blocks = ON;
%skip(1);
	do while (status.still_formatting_detail_blocks);
	     if ^first_time_through_the_detail_block_loop
	     then call make_row_ptrs;
	     call format_detail_block;
	     first_time_through_the_detail_block_loop = OFF;
	     call make_rows_available;
	end;
%skip(1);
	if format_report_info.flags.page_footer_is_defined
	then call format_page_footer;
	call close_page;
	if report_control_info.flags.permanent_report & ^report_control_info.flags.multi_pass_mode
	then call save_copy_of_page;
%skip(1);
	page_info_ptr_parm = page_ip;
	code_parm = code;
%skip(1);
	return;
%skip(1);
     end build_page;
%page;
check_for_group_break: proc (

	cfgb_group_info_ptr_parm,	  /* input: ptr to group_info structure */
	cfgb_look_ahead_flag_parm,	  /* input: on if current should be compared to next */
	cfgb_column_changed_flag_parm	  /* output: on if a column changed */
			      );
%skip(1);
dcl cfgb_column_changed_flag_parm bit (1) aligned parm;
dcl cfgb_column_number fixed bin;
dcl 1 cfgb_group_info like group_info based (cfgb_group_info_ptr_parm);
dcl cfgb_group_info_ptr_parm ptr parm;
dcl cfgb_look_ahead_flag_parm bit (1) aligned parm;
dcl cfgb_loop fixed bin;
%skip(1);
     /* Check the value of the named columns against the previous or next row and set the parm accordingly. */
%skip(1);
	cfgb_column_changed_flag_parm = ON;
	if (status.flags.last_row_of_report & cfgb_look_ahead_flag_parm)
	| (status.flags.first_row_of_report & ^cfgb_look_ahead_flag_parm)
	then return;
%skip(1);
	do cfgb_loop = 1 to cfgb_group_info.number_of_columns_to_group;
	     cfgb_column_number = cfgb_group_info.column_number (cfgb_loop);
	     if cfgb_look_ahead_flag_parm
	     then if substr (current_row_value,
		table_info.columns.column_index (cfgb_column_number),
		table_info.columns.column_length (cfgb_column_number))
		^=  substr (next_row_value,
		table_info.columns.column_index (cfgb_column_number),
		table_info.columns.column_length (cfgb_column_number))
		then return;
	          else;
	     else if substr (current_row_value,
		table_info.columns.column_index (cfgb_column_number),
		table_info.columns.column_length (cfgb_column_number))
		^=  substr (previous_row_value,
		table_info.columns.column_index (cfgb_column_number),
		table_info.columns.column_length (cfgb_column_number))
		then return;
	          else;
	end;
%skip(1);
	cfgb_column_changed_flag_parm = OFF;
%skip(1);
	return;
%skip(1);
     end check_for_group_break;
%page;
check_for_outlining: proc;
%skip(1);
dcl cfo_inner_loop fixed bin;
dcl cfo_loop fixed bin;
dcl cfo_most_major_column_changed bit (1) aligned;
dcl cfo_still_within_the_group bit (1) aligned;
%skip(3);
/*
     Never do outlining on the first row of the report or the first row on a
     page. Do the single columns first (columns who are not a member of the
     "group" of rows). Grab the column number and use it as an index into the
     input_columns_info array, which gives us the number of the output column.
*/
%skip(1);
	if status.flags.first_row_of_report | status.flags.first_row_on_page
	then do;
	     output_columns_info.columns (*).flags.outline = OFF;
	     return;
	end;
%skip(1);
	if outline_info.number_of_single_columns ^= 0
	then do cfo_loop = 1 to outline_info.number_of_single_columns;
	     if input_columns_info.columns.output_column (outline_info.single_columns (cfo_loop)) ^= 0
	     then do;
		column_ip = addr (output_columns_info.columns (input_columns_info.columns.output_column (
		     outline_info.single_columns (cfo_loop))));
		if substr (current_row_value,
		table_info.columns.column_index (outline_info.single_columns (cfo_loop)),
		table_info.columns.column_length (outline_info.single_columns (cfo_loop)))
		= substr (previous_row_value,
		table_info.columns.column_index (outline_info.single_columns (cfo_loop)),
		table_info.columns.column_length (outline_info.single_columns (cfo_loop)))
		then column_info.flags.outline = ON;
		else column_info.flags.outline = OFF;
	     end;
	end;
%page;
/*
     Do the grouping columns next. A change in any member of the group who is
     more major than our target column causes a change in all columns down to
     our target column. Repeat the following sequence for each of our target
     columns. Use the group column number as an index into the
     input_columns_info array, which gives us the number of the output column.
     If it has changed, or a more major member has changed, then it isn't
     outlined.
*/
%skip(1);
	if outline_info.number_of_grouping_columns ^= 0
	then do cfo_loop = 1 to outline_info.number_of_grouping_columns;
%skip(1);
	     cfo_most_major_column_changed = OFF;
	     cfo_still_within_the_group = ON;
%skip(1);
	     do cfo_inner_loop = 1 to group_info.number_of_columns_to_group
		while (cfo_still_within_the_group);
%skip(1);
		if input_columns_info.columns.output_column (group_info.column_number (cfo_inner_loop)) ^= 0
		then do;
		     column_ip = addr (output_columns_info.columns (input_columns_info.columns.output_column (
			group_info.column_number (cfo_inner_loop))));
		     if cfo_most_major_column_changed
		     then column_info.flags.outline = OFF;
		     else do;
			if substr (current_row_value,
			table_info.columns.column_index (group_info.column_number (cfo_inner_loop)),
			table_info.columns.column_length (group_info.column_number (cfo_inner_loop)))
			= substr (previous_row_value,
			table_info.columns.column_index (group_info.column_number (cfo_inner_loop)),
			table_info.columns.column_length (group_info.column_number (cfo_inner_loop)))
			then column_info.flags.outline = ON;
			else do;
			     cfo_most_major_column_changed = ON;
			     column_info.flags.outline = OFF;
			end;
		     end;
		end;
%skip(1);
		if group_info.column_number (cfo_inner_loop) = outline_info.grouping_columns (cfo_loop)
		then cfo_still_within_the_group = OFF;
%skip(1);
	     end;
%skip(1);
	end;
%skip(1);
	return;
%skip(1);
     end check_for_outlining;
%page;
check_for_page_break: proc;
%skip(1);
dcl cfpb_loop fixed bin;
%skip(3);
/*
     If we're on the last row then don't check for a page break. If the value
     of any column being watched is about to change with the next row then
     generate a page break.
*/
%skip(1);
	if ^status.flags.still_formatting_detail_blocks
	then return;
%skip(1);
	status.still_formatting_detail_blocks = OFF;
%skip(1);
	do cfpb_loop = 1 to input_columns_info.number_of_columns;
	     if page_break_info.columns (cfpb_loop)
	     then do;
		if substr (current_row_value,
		table_info.columns.column_index (cfpb_loop),
		table_info.columns.column_length (cfpb_loop))
		^= substr (next_row_value,
		table_info.columns.column_index (cfpb_loop),
		table_info.columns.column_length (cfpb_loop))
		then return;
	     end;
	end;
%skip(1);
	status.still_formatting_detail_blocks = ON;
%skip(1);
	return;
%skip(1);
     end check_for_page_break;
%page;
check_for_subtotal_break: proc (

	cfsb_subtotal_info_ptr_parm,	       /* input: ptr to subtotal_info structure */
	cfsb_subtotal_columns_info_ptr_parm, /* input: ptr to subtotal_columns_info structure */
	cfsb_level_number_parm,	       /* input: which level of subtotals we're on */
	cfsb_column_changed_flag_parm	       /* output: on means it's time for a subtotal break */
			 );
%skip(1);
dcl cfsb_column_changed_flag_parm bit (1) aligned parm;
dcl cfsb_column_number fixed bin;
dcl cfsb_inner_loop fixed bin;
dcl cfsb_level_number fixed bin;
dcl cfsb_level_number_parm fixed bin parm;
dcl cfsb_loop fixed bin;
dcl cfsb_most_major_column_changed bit (1) aligned;
dcl cfsb_still_within_the_group bit (1) aligned;
dcl 1 cfsb_subtotal_columns_info like subtotal_columns_info based (cfsb_subtotal_columns_info_ptr_parm);
dcl cfsb_subtotal_columns_info_ptr_parm ptr parm;
dcl 1 cfsb_subtotal_info like subtotal_info based (cfsb_subtotal_info_ptr_parm);
dcl cfsb_subtotal_info_ptr_parm ptr parm;
%skip(3);
/*
     This subroutine walks through one level of subtotals looking at the watch
     column to see if it has changed. A change means it is time to generate
     the subtotal. If the watch column is a member of the "group" list of
     columns, then it and any more major in the group are also watched. A 
     change in any member of the group causes all members lower to change also
     (down to the watch column).

     Start off by outlining every column. Walk through all of the subtotal
     columns processing only those that are at the current level. Grab the
     number of the watch column. Use the subtotal_info array to index into
     the input_columns_info array, which gives us the number of the
     subtotal_columns_info output column. If it is the last row of the report,
     or the watch column has changed, or the watch column is a group member
     and a more major column has changed, then generate a subtotal break. The
     column that changed can be excluded from the page; if it isn't then set
     the outline bit off for it (and possibly more minor columns). Set the
     outline bit off for the subtotal output column if we got a hit, and if
     the parent column has an editing request associated with it then set
     the pointer and length to the result of the editing request.
*/
%skip(1);
	cfsb_column_changed_flag_parm = OFF;
	cfsb_level_number = cfsb_level_number_parm;
	cfsb_subtotal_columns_info.columns (*).flags.outline = ON;
%page;
	do cfsb_loop = 1 to cfsb_subtotal_info.number_of_columns_to_subtotal;
	     if cfsb_subtotal_info.columns (cfsb_loop).level = cfsb_level_number
	     then do;
		cfsb_column_number = cfsb_subtotal_info.columns (cfsb_loop).watch_column;
		column_ip = addr (cfsb_subtotal_columns_info.columns (input_columns_info.columns (
		     cfsb_subtotal_info.columns (cfsb_loop).input_column).output_column));
		if ^cfsb_subtotal_info.columns (cfsb_loop).flags.group_column
		then do;
		     if status.flags.last_row_of_report
		     then call subtotal_break (input_columns_info.columns (cfsb_column_number).output_column);
		     else if substr (current_row_value,
			table_info.columns.column_index (cfsb_column_number),
			table_info.columns.column_length (cfsb_column_number))
			^= substr (next_row_value,
			table_info.columns.column_index (cfsb_column_number),
			table_info.columns.column_length (cfsb_column_number))
			then call subtotal_break (input_columns_info.columns (cfsb_column_number).output_column);
		          else;
		end;
		else do;
		     if status.flags.last_row_of_report
		     then cfsb_most_major_column_changed = ON;
		     else cfsb_most_major_column_changed = OFF;
		     cfsb_still_within_the_group = ON;
		     do cfsb_inner_loop = 1 to group_info.number_of_columns_to_group
			while (cfsb_still_within_the_group);
			if cfsb_most_major_column_changed
			then call subtotal_break (input_columns_info.columns (
			     group_info.column_number (cfsb_inner_loop)).output_column);
			else if substr (current_row_value,
			     table_info.columns.column_index (group_info.column_number (cfsb_inner_loop)),
			     table_info.columns.column_length (group_info.column_number (cfsb_inner_loop)))
			     ^= substr (next_row_value,
			     table_info.columns.column_index (group_info.column_number (cfsb_inner_loop)),
			     table_info.columns.column_length (group_info.column_number (cfsb_inner_loop)))
			     then call subtotal_break (input_columns_info.columns
			          (group_info.column_number (cfsb_inner_loop)).output_column);
			     else;
			if group_info.column_number (cfsb_inner_loop) = cfsb_column_number
			then cfsb_still_within_the_group = OFF;
		     end;
		end;
	     end;
	end;
%skip(1);
	return;
%page;
subtotal_break: proc (

	sb_output_column_number_parm	/* input: number of column that changed */
		 );
%skip(1);
dcl sb_output_column_number_parm fixed bin parm;
%skip(3);
/*
     This subroutine is called when a watch column has changed and it is time 
     to generate a subtotal break. Set the parm to indicate a column has 
     changed. Set the subtotal/subcount output column's editing flag off. If
     the column that changed isn't being excluded from the page, then set it's
     editing bit off and if it has an editing request associated with it, set
     the pointer and length so that the edited result is displayed in that
     column.
*/
%skip(1);
	cfsb_column_changed_flag_parm = ON;
	column_info.flags.outline = OFF;
	if sb_output_column_number_parm = 0
	then return;
%skip(1);
	cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).flags.outline = OFF;
	if cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).flags.editing
	then do;
	     cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).editing_string_result_ptr
		= output_columns_info.columns (sb_output_column_number_parm).editing_string_result_ptr;
	     cfsb_subtotal_columns_info.columns (sb_output_column_number_parm).editing_string_result_length
		= output_columns_info.columns (sb_output_column_number_parm).editing_string_result_length;
	end;
%skip(1);
	return;
%skip(1);
     end subtotal_break;
%skip(1);
     end check_for_subtotal_break;
%page;
close_page: proc;
%skip(3);
/*
     This subroutine closes a page. Increment the number of rows and pages 
     we've already formatted. Check for end of report and set flags 
     accordingly. If the whole page wasn't used then set page_info to reflect
     the space used. Check for a zero length page, and set the last character
     to a form feed if it's a paginated report or the last buffer of an
     unpaginated report.
*/
%skip(1);
	format_report_info.number_of_formatted_rows
	     = format_report_info.number_of_formatted_rows + status.total_number_of_rows_used;
%skip(1);
	report_control_info.no_of_formatted_pages = report_control_info.no_of_formatted_pages + 1;
%skip(1);
	if format_report_info.number_of_formatted_rows >= report_control_info.no_of_rows_retrieved
	then do;
	     report_control_info.flags.report_is_formatted = ON;
	     report_control_info.flags.report_has_just_been_completed = ON;
	end;
%skip(1);
	if status.remaining_lines_on_page ^= 0
	then do;
	     page_info.length = index (template_map_defined_as_a_string, OFF) - 1;
	     page_info.total_characters = page_info.length * page_info.width;
	end;
%skip(1);
	if page_info.total_characters = 0
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_format,
	     "The report description resulted in a zero length page.");
%skip(1);
	if paginated_report
	then substr (page_defined_as_lines (page_info.length), page_info.width, 1) = FORM_FEED;
%skip(1);
	return;
%skip(1);
     end close_page;
%page;
evaluate_active_string: proc (

	eas_active_string_parm,	  /* input: the active string */
	eas_result_string_parm	  /* output: resultant string */
		      );
%skip(1);
dcl eas_active_string_parm char (*) varying parm;
dcl eas_active_string_parm_length fixed bin (21);
dcl eas_active_string_type fixed bin;
dcl eas_code fixed bin (35);
dcl eas_current_position fixed bin (21);
dcl eas_current_inner_position fixed bin (21);
dcl eas_left_bracket_count fixed bin;
dcl eas_left_bracket_position fixed bin (21);
dcl eas_looking_for_matching_right_bracket bit (1) aligned;
dcl eas_next_bracket fixed bin (21);
dcl eas_result_string_parm char (*) varying parm;
dcl eas_right_bracket_count fixed bin;
dcl eas_right_bracket_position fixed bin (21);
dcl eas_still_evaluating bit (1) aligned;
dcl eas_string char (eas_string_length) based (eas_string_ptr);
dcl eas_string_length fixed bin (21);
dcl eas_string_ptr ptr;
dcl eas_string_start fixed bin (21);
%skip(3);
/*
     If there are no active requests return to caller.  Find the left bracket.
     Check for "|[" and "||[" constructs and set flag accordingly.  Move any
     user text before the left bracket into the result string.  Find the
     matching right bracket.  Have ssu_$evaluate_active_string evaluate
     everything between the left and matching right bracket.  Move the result
     into the result string.  Repeat these operations until no more active
     requests are left. Move any remaining user text into the result string.
*/
%skip(1);
	eas_next_bracket = search (eas_active_string_parm, LEFT_OR_RIGHT_BRACKET);
	if eas_next_bracket = 0
	then do;
	     eas_result_string_parm = eas_active_string_parm;
	     return;
	end;
%skip(1);
	eas_result_string_parm = "";
	eas_current_position = 1;
	eas_active_string_parm_length = length (eas_active_string_parm);
	eas_still_evaluating = ON;
%page;
	do while (eas_still_evaluating);
%skip(1);
	     eas_left_bracket_count = 0;
	     eas_right_bracket_count = 0;
	     eas_left_bracket_position = index (substr (eas_active_string_parm, eas_current_position), LEFT_BRACKET);
	     if eas_left_bracket_position = 0
	     then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets,
		"^a", eas_active_string_parm);
	     eas_left_bracket_count = eas_left_bracket_count + 1;
%skip(1);
	     if eas_left_bracket_position >= 3
	     then if substr (eas_active_string_parm,
		eas_current_position + eas_left_bracket_position - 3, 2) = BAR_BAR
		then eas_active_string_type = ATOMIC_ACTIVE_STRING;
	          else if substr (eas_active_string_parm,
		     eas_current_position + eas_left_bracket_position - 2, 1) = BAR
		     then eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING;
		     else eas_active_string_type = NORMAL_ACTIVE_STRING;
	     else if eas_left_bracket_position >= 2
		then if substr (eas_active_string_parm,
		     eas_current_position + eas_left_bracket_position - 2, 1) = BAR
		     then eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING;
	               else eas_active_string_type = NORMAL_ACTIVE_STRING;
		else eas_active_string_type = NORMAL_ACTIVE_STRING;
%skip(1);
	     if eas_active_string_type = NORMAL_ACTIVE_STRING
	     then eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm,
		eas_current_position, eas_left_bracket_position - 1);
	     else if eas_active_string_type = TOKENS_ONLY_ACTIVE_STRING
		then eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm,
		     eas_current_position, eas_left_bracket_position - 2);
		else eas_result_string_parm = eas_result_string_parm || substr (eas_active_string_parm,
		     eas_current_position, eas_left_bracket_position - 3);
%skip(1);
	     eas_current_inner_position = eas_current_position + eas_left_bracket_position;
	     eas_string_start = eas_current_inner_position;
	     eas_looking_for_matching_right_bracket = ON;
%skip(1);
	     do while (eas_looking_for_matching_right_bracket);
		if eas_current_inner_position > eas_active_string_parm_length
		then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets,
		     "^a", eas_active_string_parm);
		eas_next_bracket = search (substr (eas_active_string_parm,
		     eas_current_inner_position), LEFT_OR_RIGHT_BRACKET);
		if eas_next_bracket = 0
		then call ssu_$abort_line (sci_ptr, error_table_$unbalanced_brackets,
		     "^a", eas_active_string_parm);
		if substr (eas_active_string_parm, eas_current_inner_position + eas_next_bracket - 1, 1) = LEFT_BRACKET
		then eas_left_bracket_count = eas_left_bracket_count + 1;
		else eas_right_bracket_count = eas_right_bracket_count + 1;
		if eas_left_bracket_count = eas_right_bracket_count
		then eas_looking_for_matching_right_bracket = OFF;
		else eas_current_inner_position = eas_current_inner_position + eas_next_bracket;
	     end;
%skip(1);
	     eas_right_bracket_position = eas_current_inner_position + eas_next_bracket - 1;
	     eas_string_length = eas_right_bracket_position - eas_string_start;
	     eas_string_ptr = addr (substr (eas_active_string_parm, eas_string_start, 1));
	     time1 = vclock;
	     call ssu_$evaluate_active_string (sci_ptr, null (), eas_string,
		eas_active_string_type, eas_spare_string, eas_code);
	     time2 = vclock;
	     report_control_info.ssu_evaluate_active_string_time
		= report_control_info.ssu_evaluate_active_string_time + time2 - time1;
	     if eas_code ^= 0
	     then call ssu_$abort_line (sci_ptr, eas_code);
%skip(1);
	     eas_result_string_parm = eas_result_string_parm || eas_spare_string;
	     eas_current_position = eas_right_bracket_position + 1;
%skip(1);
	     if eas_current_position > eas_active_string_parm_length
	     then eas_still_evaluating = OFF;
	     else if search (substr (eas_active_string_parm, eas_current_position), LEFT_OR_RIGHT_BRACKET) = 0
		then do;
		     eas_result_string_parm = eas_result_string_parm
			|| substr (eas_active_string_parm, eas_current_position);
		     eas_still_evaluating = OFF;
		end;
		else;
%skip(1);
	end;
%skip(1);
	return;
%skip(1);
     end evaluate_active_string;
%page;
execute_editing_strings: proc;
%skip(1);
dcl ees_loop fixed bin;
%skip(3);
/*
     Walk through the list of input columns in the column order specified
     by the user. If the column has an editing request associated with it,
     pick up the pointer and length to the original editing request from the
     input_columns_info array. Have it evaluated. If the column isn't being
     excluded from the page, then set the editing string ptr and length for
     it's output column to the result string; if it is then set the same
     information for the input column. Stash the result string in the temp
     segment and advance the next available byte index.
*/
%skip(1);
	editing_strings_next_byte = format_report_info.editing_strings_next_available_byte;
%skip(1);
	do ees_loop = 1 to input_columns_info.number_of_columns;
	     column_ip = addr (input_columns_info.columns (input_columns_order (ees_loop)));
	     if column_info.editing
	     then do;
		editing_string_rl = column_info.editing_string_length;
		editing_string_rp = column_info.editing_string_ptr;
		input_string = editing_string_result;
		call evaluate_active_string (input_string, output_string);
		if column_info.output_column ^= 0
		then column_ip = addr (output_columns_info.columns (column_info.output_column));
		column_info.editing_string_result_length = length (output_string);
		column_info.editing_string_result_ptr
		     = addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte));
		substr (editing_strings_temp_seg, editing_strings_next_byte, 
		     column_info.editing_string_result_length) = output_string;
		editing_strings_next_byte
		     = editing_strings_next_byte + column_info.editing_string_result_length;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end execute_editing_strings;
%page;
fit_column: proc (

	fc_column_value_parm,     /* input: actual column value */
	fc_output_width_parm,     /* input: width to place it into */
	fc_output_position_parm,  /* input: starting position in template */
	fc_alignment_mode_parm,   /* input: left, right, center, or both */
	fc_decimal_position_parm, /* input: decimal position within width */
	fc_template_parm,	      /* input: template to lay down */
	fc_fill_parm,	      /* input: fill or truncate */
	fc_line_number_parm,      /* input: beginning line number on page */
	fc_code_parm	      /* output: success or failure */
	);
%skip(1);
dcl fc_additional_alignment bit (1) aligned;
dcl fc_alignment_mode_parm fixed bin parm;
dcl fc_code fixed bin (35);
dcl fc_code_parm fixed bin (35) parm;
dcl fc_column_value_parm char (*) varying parm;
dcl fc_current_line_on_page fixed bin;
dcl fc_current_position fixed bin;
dcl fc_decimal_position_parm fixed bin;
dcl fc_fill_parm bit (1) unaligned parm;
dcl fc_line_number_parm fixed bin parm;
dcl fc_new_line_position fixed bin;
dcl fc_output_column char (fc_output_width_parm) based (fc_output_column_ptr);
dcl fc_output_column_ptr ptr;
dcl fc_output_width_parm fixed bin parm;
dcl fc_output_position_parm fixed bin parm;
dcl fc_returned_string_length fixed bin (21);
dcl fc_spare_string_length fixed bin;
dcl fc_still_filling bit (1) aligned;
dcl fc_string_end fixed bin;
dcl fc_template_parm char (*) parm;
%skip(3);
/*
     Make sure we're not starting past the end of the page. Set our current
     line on the page to where the parm says we're supposed to start. If a
     template hasn't been laid down yet on that line then lay one down and
     mark it as laid down. If the value contains hardcopy mechanical device
     motion control codes, or it is overlength, or the alignment is set to
     both, then have the value filled; else have the value placed.
*/
%skip(1);
	fc_code_parm = 0;
	if fc_line_number_parm > template_map_number_of_bits
	then do;
	     fc_code_parm = PAGE_OVERFLOW_ERROR_CODE;
	     return;
	end;
	else fc_current_line_on_page = fc_line_number_parm;
%skip(1);
	if ^template_map (fc_current_line_on_page)
	then do;
	     page_defined_as_lines (fc_current_line_on_page) = fc_template_parm;
	     template_map (fc_current_line_on_page) = ON;
	end;
%skip(1);
	if (search (fc_column_value_parm, BACKSPACE_OR_VERTICAL_TAB_OR_HORIZONTAL_TAB_OR_NL) ^= 0)
	| (length (fc_column_value_parm) > fc_output_width_parm)
	| (fc_alignment_mode_parm = BOTH_ALIGNMENT)
	then call fill_the_column;
	else call place_column (fc_column_value_parm);
%skip(1);
	return;
%page;
fill_the_column: proc;
%skip(3);
/*
     The variable output_string is based on a segment, and the variable
     input_string is artificially constructed to look like a char (N) where
     N is the length of the meaninful portion of our parm. We do this because
     format_document_ doesn't want a varying char string, and because
     format_document_ will start out by doing a 
     "length (rtrim (input_string))" of input_string, which could be an entire
     segment. Set the adj_sw and call format_document_. Artifically set the
     length of output_string based on how long format_document_ says it is.
     Strings filled by format_document_ may still have to be additionally
     aligned to center or right as they are being placed on the page. If the
     alignment mode is truncate then call the subroutine to do it, else do
     it here.
*/
%skip(1);
	input_string_non_varying_length = length (fc_column_value_parm);
	input_string_non_varying_ptr = addrel (addr (fc_column_value_parm), 1);
	format_document_options.line_length = fc_output_width_parm;
	if fc_alignment_mode_parm = BOTH_ALIGNMENT
	then format_document_options.switches.adj_sw = ON;
	else format_document_options.switches.adj_sw = OFF;
%skip(1);
	call format_document_$string (input_string_non_varying, output_string_non_varying,
	     fc_returned_string_length, format_document_options_ptr, fc_code);
	if fc_code ^= 0
	then if fc_code ^= error_table_$recoverable_error
	     then call ssu_$abort_line (sci_ptr, fc_code);
	if fc_returned_string_length = 0
	then return;
%skip(1);
	output_string_redefined.length_word = fc_returned_string_length;
%skip(1);
	if fc_alignment_mode_parm = CENTER_ALIGNMENT | fc_alignment_mode_parm = RIGHT_ALIGNMENT
	then fc_additional_alignment = ON;
	else fc_additional_alignment = OFF;
%skip(1);
	if ^fc_fill_parm
	then do;
	     call truncate_the_column;
	     return;
	end;
%page;
/*
     Walk through the filled string. Find the newline. If the found portion
     contains any backspaces then send it off to the hardcopy terminal
     alignment routine. If it doesn't and there is additional alignment then
     have it done. If it doesn't and there isn't additional alignment then just
     place it on the page. If we're still filling then advance our current
     line on the page, check for template already laid down, lay it down and
     mark it if it hasn't been laid down.
*/
%skip(1);
	fc_still_filling = ON;
	fc_current_position = 1;
%skip(1);
	do while (fc_still_filling);
	     fc_new_line_position = index (substr (output_string, fc_current_position), NEWLINE);
	     if index (substr (output_string, fc_current_position, fc_new_line_position - 1), BACKSPACE) ^= 0
	     then do;
		fc_spare_string = substr (output_string, fc_current_position, fc_new_line_position - 1);
		call align_hardcopy_dependent_string (fc_spare_string);
	     end;
	     else if fc_additional_alignment
		then do;
		     fc_spare_string = substr (output_string, fc_current_position, fc_new_line_position - 1);
		     call place_column (fc_spare_string);
		end;
		else substr (page_defined_as_lines (fc_current_line_on_page),
		     fc_output_position_parm, fc_new_line_position - 1)
		     = substr (output_string, fc_current_position, fc_new_line_position - 1);
	     fc_current_position = fc_current_position + fc_new_line_position;
	     if fc_current_position > output_string_redefined.length_word
	     then fc_still_filling = OFF;
	     else do;
		fc_current_line_on_page = fc_current_line_on_page + 1;
		if fc_current_line_on_page > template_map_number_of_bits
		then do;
		     fc_code_parm = PAGE_OVERFLOW_ERROR_CODE;
		     return;
		end;
		if ^template_map (fc_current_line_on_page)
		then do;
		     page_defined_as_lines (fc_current_line_on_page) = fc_template_parm;
		     template_map (fc_current_line_on_page) = ON;
		end;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end fill_the_column;
%page;
place_column: proc (

	pc_column_value_parm     /* input: actual column value */
	         );
%skip(1);
dcl pc_column_value_parm char (*) varying parm;
dcl pc_column_width fixed bin;
dcl pc_decimal_position fixed bin;
dcl pc_no_of_digits_to_the_left fixed bin;
dcl pc_no_of_digits_to_the_right fixed bin;
dcl pc_remaining_digits fixed bin;
dcl pc_starting_position fixed bin;
dcl pc_the_actual_decimal fixed bin;
%skip(3);
/*
     Set the pointer to the output column to the desired spot on the page.
     Have the value aligned within the output column based on what the
     parm says.
*/
%skip(1);
	fc_output_column_ptr = addr (page_defined_as_chars (
	     ((fc_current_line_on_page - 1) * page_info.width + fc_output_position_parm)));
%skip(1);
          if fc_alignment_mode_parm = DECIMAL_ALIGNMENT
	then call align_decimal_value;
	else if fc_alignment_mode_parm = LEFT_ALIGNMENT
	     then call align_left_value;
	     else if fc_alignment_mode_parm = RIGHT_ALIGNMENT
		then call align_right_value;
	          else if fc_alignment_mode_parm = CENTER_ALIGNMENT
		     then call align_center_value;
		     else call ssu_$abort_line (sci_ptr, error_table_$badcall,
			"Unknown alignment mode ^d.", fc_alignment_mode_parm);
%skip(1);
          return;
%page;
align_center_value: proc;
%skip(3);
/*
     Center the value in the output column. (Centre it for the Canadian users.
     This subroutine speaks American and Canadian.) Figure out where it should
     start and substring it into place.
*/
%skip(1);
	pc_column_width = length (pc_column_value_parm);
%skip(1);
	if (pc_column_width = fc_output_width_parm) | (fc_output_width_parm - pc_column_width) = 1
	then pc_starting_position = 1;
	else if fc_output_width_parm - pc_column_width = 2
	     then pc_starting_position = 2;
	     else do;
		pc_starting_position = fc_output_width_parm - pc_column_width;
		pc_starting_position = divide (pc_starting_position, 2, 17) + 1;
	     end;
%skip(1);
	substr (fc_output_column, pc_starting_position, pc_column_width) = pc_column_value_parm;
%skip(1);
          return;
%skip(1);
     end align_center_value;
%page;
align_decimal_value: proc;
%skip(1);
/* Decimal align it within the output column width, adding the decimal if necessary. */
%skip(1);
          pc_column_value = pc_column_value_parm;
	pc_column_width = length (pc_column_value);
	if fc_decimal_position_parm > fc_output_width_parm
	then pc_decimal_position = fc_output_width_parm;
	else pc_decimal_position = fc_decimal_position_parm;
	pc_no_of_digits_to_the_left = pc_decimal_position - 1;
	pc_no_of_digits_to_the_right = fc_output_width_parm - pc_decimal_position;
%skip(1);
	substr (fc_output_column, pc_decimal_position, 1) = ".";
	pc_the_actual_decimal = index (pc_column_value, ".");
	if pc_the_actual_decimal = 0
	then do;
	     if pc_column_width = pc_decimal_position
	     then pc_column_value = substr (pc_column_value, 2) || ".";
	     else pc_column_value = pc_column_value || ".";
	     pc_column_width = length (pc_column_value);
	     pc_the_actual_decimal = pc_column_width;
	end;
%skip(1);
	if pc_the_actual_decimal = pc_decimal_position
	then substr (fc_output_column, 1, pc_no_of_digits_to_the_left)
	     = substr (pc_column_value, 1, pc_no_of_digits_to_the_left);
	else if pc_the_actual_decimal - 1 > pc_no_of_digits_to_the_left
	     then substr (fc_output_column, 1, pc_no_of_digits_to_the_left)
		= substr (pc_column_value, pc_the_actual_decimal
	          - pc_no_of_digits_to_the_left, pc_no_of_digits_to_the_left);
	     else substr (fc_output_column, pc_no_of_digits_to_the_left
		- pc_the_actual_decimal + 2, pc_the_actual_decimal - 1)
		= substr (pc_column_value, 1, pc_the_actual_decimal - 1);
%skip(1);
	if pc_no_of_digits_to_the_right = 0 | pc_the_actual_decimal = pc_column_width
	then return;
%skip(1);
	pc_remaining_digits = pc_column_width - pc_the_actual_decimal;
	if pc_no_of_digits_to_the_right = pc_remaining_digits
	then substr (fc_output_column, pc_decimal_position + 1)
	     = substr (pc_column_value, pc_the_actual_decimal + 1);
	else if pc_no_of_digits_to_the_right > pc_remaining_digits
	     then substr (fc_output_column, pc_decimal_position + 1)
	          = substr (pc_column_value, pc_the_actual_decimal + 1);
	     else substr (fc_output_column, pc_decimal_position + 1)
		= substr (pc_column_value, pc_the_actual_decimal + 1, pc_no_of_digits_to_the_right);
%skip(1);
          return;
%skip(1);
     end align_decimal_value;
%page;
align_left_value: proc;
%skip(3);
/*
     An easy alignment task, but probably the most often used. Note that only
     the exact number of characters in the parm are what's moved. The template
     that was laid down already blanked the rest of the output column.
*/
%skip(1);
          substr (fc_output_column, 1, length (pc_column_value_parm)) = pc_column_value_parm;
%skip(1);
          return;
%skip(1);
     end align_left_value;
%page;
align_right_value: proc;
%skip(3);
/*
     Once again, only the characters in the parm are moved.
*/
%skip(1);
          substr (fc_output_column, fc_output_width_parm - length (pc_column_value_parm) + 1)
	     = pc_column_value_parm;
%skip(1);
          return;
%skip(1);
     end align_right_value;
%skip(3);
     end place_column;
%page;
align_hardcopy_dependent_string: proc (

	ahds_column_value_parm	/* input: actual column value */
		     );
%skip(1);
dcl ahds_column_value_parm char (*) varying parm;
dcl ahds_current_input_position fixed bin;
dcl ahds_current_output_position fixed bin;
dcl ahds_loop fixed bin;
dcl ahds_number_of_chars_to_move fixed bin;
dcl ahds_overstrike_index fixed bin;
dcl ahds_still_overstriking bit (1) aligned;
dcl ahds_string_length fixed bin;
dcl ahds_truncate_the_column bit (1) aligned;
dcl ahds_virtual_length fixed bin;
%skip(3);
/*
     Hopefully all of the hardcopy device support will one day be moved out
     of the operating system and applications forever. In the meantime we
     continue to bake it into everything written on Multics because that's
     the way it was done back in 1965 when Multics was first started.
     Fortunately the video system has said "I don't support ugly backspaces,
     and if you give me any to write I will refuse and hand you back an error
     code." This subroutine pre-processes the data so that the video system
     will not give us any error codes, and we can do things more rationally
     than they were done back in 1965 and are still being done today many
     places in Multics. This is also the key to why this formatter runs *so*
     fast when compared with others like compose. It never has to try to
     figure out where it really is on a page, because it doesn't have 
     imbedded hardcopy device motion control characters stuck in the formatted
     page. Instead they are moved off to a separate overstrike array, and the
     formatter only runs slower for the people who continue to bake hardcopy
     device motion control characters in their formatted data. When the page is
     being displayed through the video system the page is displayed without
     any of the overstruck sequences; when it is being displayed in hardcopy
     dependent fashion the overstruck characters are put back in at display
     time.
*/
%skip(1);
	ahds_string_length = length (ahds_column_value_parm);
	if ahds_string_length = 0
	then return;
%skip(1);
	ahds_overstrike_index = ((fc_current_line_on_page - 1) * page_info.width)
	     + fc_output_position_parm;
	fc_output_column_ptr = addr (page_defined_as_chars (ahds_overstrike_index));
%skip(1);
	ahds_virtual_length = 0;
	do ahds_loop = 1 to ahds_string_length;
	     if substr (ahds_column_value_parm, ahds_loop, 1) ^= BACKSPACE
	     then ahds_virtual_length = ahds_virtual_length + 1;
	     else ahds_virtual_length = ahds_virtual_length - 1;
	end;
%skip(1);
	if ^fc_fill_parm
	then do;
	     if ahds_virtual_length > fc_output_width_parm
	     then do;
		ahds_number_of_chars_to_move = fc_output_width_parm - truncation_indicator_length;
		ahds_truncate_the_column = ON;
	     end;
	     else do;
		ahds_number_of_chars_to_move = ahds_virtual_length;
		ahds_truncate_the_column = OFF;
	     end;
	     if ahds_truncate_the_column
	     then if fc_output_width_parm <= truncation_indicator_length
		then do;
		     if fc_output_width_parm < truncation_indicator_length
		     then fc_output_column = substr (format_report_info.truncation_indicator, 1, fc_output_width_parm);
		     else fc_output_column = format_report_info.truncation_indicator;
		     return;
		end;
		else;
	     else;
	end;
	else ahds_number_of_chars_to_move = ahds_virtual_length;
%skip(1);
	if page_info.page_overstrike_info_ptr = null ()
	then do;
	     page_info.page_overstrike_info_ptr = page_overstrike_ip;
	     unspec (page_overstrike_info.bit_map) = OFF;
	end;
%skip(1);
	if ^fc_additional_alignment
	then ahds_current_output_position = 1;
	else do;
	     if fc_alignment_mode_parm = RIGHT_ALIGNMENT
	     then ahds_current_output_position = fc_output_width_parm - ahds_virtual_length + 1;
	     else do;
		if fc_output_width_parm = ahds_virtual_length | fc_output_width_parm - ahds_virtual_length = 1
		then ahds_current_output_position = 1;
		else if fc_output_width_parm - ahds_virtual_length = 2
		     then ahds_current_output_position = 2;
		     else do;
			ahds_current_output_position = fc_output_width_parm - ahds_virtual_length;
			ahds_current_output_position = divide (ahds_current_output_position, 2, 17) + 1;
		     end;
	     end;
	end;
	ahds_current_input_position = 1;
%page;
	do ahds_loop = 1 to ahds_number_of_chars_to_move;
	     substr (fc_output_column, ahds_current_output_position, 1)
		= substr (ahds_column_value_parm, ahds_current_input_position, 1);
	     ahds_current_input_position = ahds_current_input_position + 1;
	     ahds_still_overstriking = ON;
	     do while (ahds_still_overstriking);
		if ahds_current_input_position < ahds_string_length
		then if substr (ahds_column_value_parm, ahds_current_input_position, 1) ^= BACKSPACE
		     then ahds_still_overstriking = OFF;
		     else do;
			ahds_current_input_position = ahds_current_input_position + 1;
			page_overstrike_info.bit_map (ahds_overstrike_index + ahds_current_output_position - 1) = ON;
			page_overstrike_info.chars (ahds_overstrike_index + ahds_current_output_position - 1)
			     =  substr (ahds_column_value_parm, ahds_current_input_position, 1);
			ahds_current_input_position = ahds_current_input_position + 1;
		     end;
		else ahds_still_overstriking = OFF;
	     end;
	     ahds_current_output_position = ahds_current_output_position + 1;
	end;
%skip(1);
	if ^fc_fill_parm
	then if ahds_truncate_the_column
	     then substr (fc_output_column, fc_output_width_parm - truncation_indicator_length + 1)
	          = format_report_info.truncation_indicator;
	     else;
	else;
%skip(1);
	return;
%skip(1);
     end align_hardcopy_dependent_string;
%page;
truncate_the_column: proc;
%skip(3);
/*
     Find out if the character string or the output width is smallest.
     Translate any newlines format_document_ may have put in into blanks.
     If it contains overstruck characters then have the subroutine which
     specializes in that type of stuff do it; else just place the portion
     of the character string that fits into the output position. If this
     results in truncation then place the truncation indicator to show the
     user this has happened.
*/
%skip(1);
	fc_string_end = min (output_string_redefined.length_word, fc_output_width_parm);
	if fc_string_end = 0
	then return;
%skip(1);
	fc_spare_string = substr (output_string, 1, fc_string_end);
	fc_spare_string = translate (fc_spare_string, BLANK, NEWLINE);
	if search (fc_spare_string, BACKSPACE) ^= 0
	then do;
	     call align_hardcopy_dependent_string (fc_spare_string);
	     return;
	end;
%skip(1);
	fc_spare_string_length = length (fc_spare_string);
	substr (page_defined_as_lines (fc_line_number_parm), fc_output_position_parm,
	     fc_spare_string_length) = fc_spare_string;
	if output_string_redefined.length_word ^> fc_output_width_parm
	then return;
%skip(1);
	if fc_output_width_parm > truncation_indicator_length
	then substr (page_defined_as_lines (fc_line_number_parm),
	     fc_output_position_parm + fc_output_width_parm - truncation_indicator_length, truncation_indicator_length)
	     = format_report_info.truncation_indicator;
	else substr (page_defined_as_lines (fc_line_number_parm),
	     fc_output_position_parm, fc_output_width_parm)
	     = substr (format_report_info.truncation_indicator, 1, fc_output_width_parm);
%skip(1);
	return;
%skip(1);
     end truncate_the_column;
%skip(3);
     end fit_column;
%page;
format_detail_block: proc;
%skip(1);
dcl fdb_code fixed bin (35);
dcl fdb_column_changed_flag bit (1) aligned;
%skip(1);
/*
     If the detail block won't fit on the page then we are done. Check to make
     sure that at least one detail block has been placed on the page.
*/
%skip(1);
	if (status.number_of_lines_needed_for_detail_block > status.remaining_lines_on_page)
	| (format_report_info.flags.page_footer_is_defined & status.remaining_lines_on_page
	< status.number_of_lines_needed_for_page_footer + status.number_of_lines_needed_for_detail_block)
	then do;
	     if status.total_number_of_rows_used ^> 0
	     then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_format,
		"^/There isn't enough room to place the first row on the page."
		|| "^/It was row number ^d on page number ^d.",
		status.current_row_number, status.current_page_number);
	     else do;
		still_formatting_detail_blocks = OFF;
		return;
	     end;
	end;
%skip(1);
/*
     Check to see if this row has been processed before and backed off the 
     page. Flag appropriately. If the previous detail block used some lines
     then setup the detail_block information so this one can be backed out
     properly.
*/
%skip(1);
	if status.current_row_number > status.highest_row_formatted
	then do;
	     status.highest_row_formatted = status.current_row_number;
	     status.flags.row_has_been_processed_before = OFF;
	end;
	else status.flags.row_has_been_processed_before = ON;
%skip(1);
	if status.flags.detail_block_used_some_lines
	then do;
	     formatted_page_info.number_of_detail_blocks = formatted_page_info.number_of_detail_blocks + 1;
	     formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks) = 0;
	     formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).row_number
		= status.current_row_number;
	     formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).beginning_line_number
		= status.current_line_on_page;
	end;
%page;
/*
     Mark this block initially as using no lines. Execute the editing requests,
     and gather the subtotals, subcounts, totals and counts before formatting
     anything.
*/
%skip(1);
	status.flags.detail_block_used_some_lines = OFF;
%skip(1);
	if format_report_info.flags.editing_is_defined
	then call execute_editing_strings;
%skip(1);
	if format_report_info.flags.subtotal_is_defined
	then call gather_subtotals;
%skip(1);
	if format_report_info.flags.subcount_is_defined
	then call gather_subcounts;
%skip(1);
	if format_report_info.flags.total_is_defined
	then call gather_totals;
%skip(1);
	if format_report_info.flags.count_is_defined
	then call gather_counts;
%skip(1);
/*
     If a group header and trigger are defined then check to see if it is time
     to process it. If one of the trigger columns changed then format the
     header, backing it out if necessary.
*/
%skip(1);
	if format_report_info.flags.group_header_is_defined
	& format_report_info.flags.group_header_trigger_is_defined
	then do;
	     call check_for_group_break (format_report_info.group_header_trigger_info_ptr, 
		LOOK_BEHIND, fdb_column_changed_flag);
	     if fdb_column_changed_flag
	     then do;
		call format_header (format_report_info.group_header_info_ptr, GROUP_HEADER,
		     status.current_line_on_page, status.remaining_lines_on_page,
		     formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks)
		     .group_header_length, fdb_code);
		if fdb_code ^= 0
		then do;
		     call backout_detail_block (GROUP_HEADER);
		     return;
		end;
		else status.flags.detail_block_used_some_lines = ON;
	     end;
	end;
%page;
/*
     Next the row header. If it's defined then format it, backing it out if
     necessary.
*/
%skip(1);
	if format_report_info.flags.row_header_is_defined
	then do;
	     call format_header (format_report_info.row_header_info_ptr, ROW_HEADER,
		status.current_line_on_page, status.remaining_lines_on_page,
		formatted_page_info.detail_blocks (formatted_page_info
		.number_of_detail_blocks).row_header_length, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_HEADER);
		return;
	     end;
	     else status.flags.detail_block_used_some_lines = ON;
	end;
%skip(1);
/*
     If outlining is defined then outline the columns as appropriate.
*/
%skip(1);
	if format_report_info.flags.outline_is_defined
	then call check_for_outlining;
%skip(1);
/*
     If all columns haven't been excluded then format the row, backing it out
     if necessary.
*/
%skip(1);
	if format_report_info.flags.row_value_is_defined
	then do;
	     call format_row (ROW_VALUE, output_columns_ip, 
		row_value_template_ip, GENERATE_ZERO_BLANK_LINES_TRAILER,
		status.current_line_on_page, status.remaining_lines_on_page,
		formatted_page_info.detail_blocks (formatted_page_info
		.number_of_detail_blocks).row_length, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_VALUE);
		return;
	     end;
	     else status.flags.detail_block_used_some_lines = ON;
	end;
%page;
/*
     If subtotals are defined then format them if it's time for any of them
     to be generated, backing out the block if necessary.
*/
%skip(1);
	if format_report_info.flags.subtotal_is_defined
	then do;
	     call format_subtotals (subtotal_ip, subtotal_columns_ip, subtotal_generation_ip, ROW_SUBTOTAL,
		formatted_page_info.detail_blocks.subtotal_length
		(formatted_page_info.number_of_detail_blocks), 
		status.flags.subtotals_ejection_in_progress, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_SUBTOTAL);
		return;
	     end;
	end;
%skip(1);
/*
     If subcounts are defined then format them if it's time for any of them
     to be generated, backing out the block if necessary.
*/
%skip(1);
	if format_report_info.flags.subcount_is_defined
	then do;
	     call format_subtotals (subcount_ip, subcount_columns_ip, subcount_generation_ip, ROW_SUBCOUNT,
		formatted_page_info.detail_blocks.subcount_length
		(formatted_page_info.number_of_detail_blocks), 
		status.flags.subcounts_ejection_in_progress, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_SUBCOUNT);
		return;
	     end;
	end;
%skip(1);
/*
     If totals are defined and this is the last row of the report then format 
     them, backing them out if necessary.
*/
%skip(1);
	if format_report_info.flags.total_is_defined & status.flags.last_row_of_report
	then do;
	     call format_totals (total_ip, total_columns_ip, ROW_TOTAL,
		formatted_page_info.detail_blocks.total_length
		(formatted_page_info.number_of_detail_blocks),
		status.flags.totals_ejection_in_progress, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_TOTAL);
		return;
	     end;
	end;
%page;
/*
     If counts are defined and this is the last row of the report then format 
     them, backing them out if necessary.
*/
%skip(1);
	if format_report_info.flags.count_is_defined & status.flags.last_row_of_report
	then do;
	     call format_totals (count_ip, count_columns_ip, ROW_COUNT,
		formatted_page_info.detail_blocks.count_length
		(formatted_page_info.number_of_detail_blocks),
		status.flags.counts_ejection_in_progress, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_COUNT);
		return;
	     end;
	end;
%skip(1);
/*
     If the row footer is defined then format it, backing it out if necessary.
*/
%skip(1);
	if format_report_info.flags.row_footer_is_defined
	then do;
	     call format_header (format_report_info.row_footer_info_ptr, ROW_FOOTER,
		status.current_line_on_page, status.remaining_lines_on_page,
		formatted_page_info.detail_blocks (formatted_page_info
		.number_of_detail_blocks).row_footer_length, fdb_code);
	     if fdb_code ^= 0
	     then do;
		call backout_detail_block (ROW_FOOTER);
		return;
	     end;
	     else status.flags.detail_block_used_some_lines = ON;
	end;
%page;
/*
     If a group footer and trigger are defined then check to see if it is time
     to process it. If one of the trigger columns changed then format the
     footer, backing it out if necessary.
*/
%skip(1);
	if format_report_info.flags.group_footer_is_defined
	& format_report_info.flags.group_footer_trigger_is_defined
	then do;
	     call check_for_group_break (format_report_info.group_footer_trigger_info_ptr,
		LOOK_AHEAD, fdb_column_changed_flag);
	     if fdb_column_changed_flag
	     then do;
		call format_header (format_report_info.group_footer_info_ptr, GROUP_FOOTER,
		     status.current_line_on_page, status.remaining_lines_on_page,
		     formatted_page_info.detail_blocks (formatted_page_info.number_of_detail_blocks).group_footer_length, fdb_code);
		if fdb_code ^= 0
		then do;
		     call backout_detail_block (GROUP_FOOTER);
		     return;
		end;
		else status.flags.detail_block_used_some_lines = ON;
	     end;
	end;
%skip(1);
/*
     If we've just formatted the last row, or there isn't enough space 
     remaining on the page to attempt the next row, then quit formatting
     detail blocks.
     
*/
%skip(1);
	status.total_number_of_rows_used = status.total_number_of_rows_used + 1;
	status.current_row_number = status.current_row_number + 1;
%skip(1);
	if (status.current_row_number	> report_control_info.no_of_rows_retrieved)
	| (status.number_of_lines_needed_for_detail_block	> status.remaining_lines_on_page)
	| (format_report_info.flags.page_footer_is_defined & status.remaining_lines_on_page
	< status.number_of_lines_needed_for_page_footer + status.number_of_lines_needed_for_detail_block)
	then status.still_formatting_detail_blocks = OFF;
%page;
/*
     Adjust status flags and check to see if it's time for a page break.
*/
%skip(1);
	if report_control_info.table_is_full & status.current_row_number = report_control_info.no_of_rows_retrieved
	then status.flags.last_row_of_report = ON;
%skip(1);
	status.flags.first_row_of_report = OFF;
	status.flags.first_row_on_page = OFF;
%skip(1);
	if format_report_info.flags.page_break_is_defined
	then call check_for_page_break;
%skip(1);
	return;
%skip(1);
     end format_detail_block;
%page;
format_header: proc (

	fh_header_info_ptr_parm,	   /* input: ptr to header info */
	fh_executing_object_parm,	   /* input: who's calling */
	fh_current_line_number_parm,	   /* input/output: current line on page */
 	fh_remaining_lines_on_page_parm, /* input/output: number left on page  */
	fh_number_of_lines_used_parm,    /* output: number of lines used */
	fh_code_parm		   /* output: success or failure */
		);
%skip(1);
dcl fh_current_line_number fixed bin;
dcl fh_current_line_number_parm fixed bin parm;
dcl fh_code_parm fixed bin (35) parm;
dcl fh_executing_object_parm char (*) varying parm;
dcl fh_header_info_ptr_parm ptr parm;
dcl fh_loop fixed bin;
dcl fh_next_line_number fixed bin;
dcl fh_number_of_lines_used fixed bin;
dcl fh_number_of_lines_used_parm fixed bin parm;
dcl fh_remaining_lines_on_page_parm fixed bin parm;
dcl fh_still_counting_lines bit (1) aligned;
%skip(3);
/*
     Check to make sure we aren't about to exceed the page length. Repeat the
     following sequence for each line of the header/footer. Lay down a template
     on the current line and mark it as laid down. For each portion of the
     header that's present, have any active requests evaluated and fit the
     header portion into it assigned slot on the page. If we've still got
     another header line to do then find out where on the page it will begin,
     and repeat the loop. When we've evaluated all lines then count how many
     we've used, fill in the parms, and return to caller.
*/
%skip(1);
	header_ip = fh_header_info_ptr_parm;
	fh_current_line_number = fh_current_line_number_parm;
	fh_number_of_lines_used_parm = 0;
	fh_code_parm = 0;
	status.flags.header_being_evaluated = ON;
	status.object_being_evaluated = fh_executing_object_parm;
%skip(1);
	if fh_current_line_number > template_map_number_of_bits
	then do;
	     fh_code_parm = PAGE_OVERFLOW_ERROR_CODE;
	     return;
	end;
%page;
	do status.current_header_line = 1 to header_info.number_of_lines;
%skip(1);
	     page_defined_as_lines (fh_current_line_number) = generic_template;
	     template_map (fh_current_line_number) = ON;
%skip(1);
	     do status.current_header_part = 1 to header_info.maximum_number_of_parts;
%skip(1);
		if header_info.lines (status.current_header_line).parts (status.current_header_part).flags.present
		then do;
		     if header_info.lines (status.current_header_line).parts (status.current_header_part).flags.active
		     then do;
			output_string = substr (headers_temp_seg,
			     header_info.lines (status.current_header_line).parts (status.current_header_part).index,
			     header_info.lines (status.current_header_line).parts (status.current_header_part).length);
			call evaluate_active_string (output_string, input_string);
		     end;
		     else input_string = substr (headers_temp_seg,
			header_info.lines (status.current_header_line).parts (status.current_header_part).index,
			header_info.lines (status.current_header_line).parts (status.current_header_part).length);
		     call fit_column (input_string, 
			header_info.lines (status.current_header_line).parts (status.current_header_part).width,
			header_info.lines (status.current_header_line).parts (status.current_header_part).starting_position,
			header_info.lines (status.current_header_line).parts (status.current_header_part).alignment,
			0, generic_template, FILL, fh_current_line_number, fh_code_parm);
		     if fh_code_parm ^= 0
		     then return;
		end;
%skip(1);
	     end;
%skip(1);
	     if status.current_header_line < header_info.number_of_lines
	     then do;
		if fh_current_line_number < template_map_number_of_bits
		then fh_next_line_number = index (substr (template_map_defined_as_a_string, 
		     fh_current_line_number + 1), OFF);
		else fh_next_line_number = 0;
		if fh_next_line_number = 0
		then do;
		     fh_code_parm = PAGE_OVERFLOW_ERROR_CODE;
		     return;
		end;
		else fh_current_line_number = fh_current_line_number + fh_next_line_number;
	     end;
%skip(1);
	end;
%page;
	fh_still_counting_lines = ON;
	fh_number_of_lines_used = 0;
%skip(1);
	do fh_loop = fh_current_line_number_parm to template_map_number_of_bits
	     while (fh_still_counting_lines);
	     if template_map (fh_loop)
	     then fh_number_of_lines_used = fh_number_of_lines_used + 1;
	     else fh_still_counting_lines = OFF;
	end;
%skip(1);
	fh_number_of_lines_used_parm = fh_number_of_lines_used;
	fh_current_line_number_parm = fh_current_line_number_parm + fh_number_of_lines_used;
	fh_remaining_lines_on_page_parm = template_map_number_of_bits - fh_current_line_number_parm + 1;
	status.flags.header_being_evaluated = OFF;
%skip(1);
	return;
%skip(1);
     end format_header;
%page;
format_page_footer: proc;
%skip(1);
dcl fpf_beginning_line_number fixed bin;
dcl fpf_code fixed bin (35);
dcl fpf_loop fixed bin;
dcl fpf_overstrike_index_1 fixed bin;
dcl fpf_overstrike_index_2 fixed bin;
dcl fpf_overstruck_page bit (1) aligned;
dcl fpf_page_footer_doesnt_fit bit (1) aligned;
%skip(1);
/*
     Unpaginated reports only have a page footer placed after the last row
     of the report. Repeat the following sequence while the footer doesn't
     fit. Decrement the current row number so the last row on the page is
     available for the footer. Format the footer. If it doesn't fit then
     decrement the number of rows used on this page, back out the last
     detail block, and repeat the loop. If it does fit then kick out of the
     loop. (The proc that does the backing out never allows the first row
     of a page to be removed, so it is the governing mechanism in this loop.)
*/
%skip(1);
	if ^paginated_report & ^status.flags.last_row_of_report
	then return;
%skip(1);
	fpf_page_footer_doesnt_fit = ON;
%skip(1);
	do while (fpf_page_footer_doesnt_fit);
	     status.current_row_number = status.current_row_number - 1;
	     fpf_beginning_line_number = status.current_line_on_page;
	     call format_header (format_report_info.page_footer_info_ptr, PAGE_FOOTER,
		status.current_line_on_page, status.remaining_lines_on_page,
		formatted_page_info.page_footer_length, fpf_code);
	     if fpf_code ^= 0
	     then do;
		status.total_number_of_rows_used = status.total_number_of_rows_used - 1;
		call backout_detail_block (PAGE_FOOTER);
	     end;
	     else fpf_page_footer_doesnt_fit = OFF;
	end;
%skip(1);
/*
     Adjust the current row number to compensate for when we decremented
     it. If there are remaining lines on the page and it's a paginated
     report do the following steps. Work the loop from the last line of the
     page back up to where we placed the last line of the footer. If we've
     just moved up to the point where we originally placed the footer lines
     then lay down a generic template to blank out the footer line, mark
     the template map, and if it's an overstruck page then show the line
     as having no overstrikes. If we haven't arrived at this point yet, then
     move the footer line down the page to where it belongs, mark the template
     map, and move any overstrike info if it's an overstruck page.
*/
%page;
	status.current_row_number = status.current_row_number + 1;
%skip(1);
	if status.remaining_lines_on_page > 0
	then if paginated_report
	     then do;
		fpf_overstruck_page = (page_info.page_overstrike_info_ptr ^= null ());
		do fpf_loop = template_map_number_of_bits to fpf_beginning_line_number by -1;
		     if fpf_loop < template_map_number_of_bits - formatted_page_info.page_footer_length + 1
		     then do;
			page_defined_as_lines (fpf_loop) = generic_template;
			template_map (fpf_loop) = ON;
			if fpf_overstruck_page
			then substr (page_overstrike_info_redefined.bit_map,
			     ((fpf_loop - 1) * page_info.width) + 1, page_info.width) = OFF;
			else;
		     end;
		     else do;
			page_defined_as_lines (fpf_loop)
			     = page_defined_as_lines (fpf_loop - status.remaining_lines_on_page);
			template_map (fpf_loop) = ON;
			if fpf_overstruck_page
			then do;
			     fpf_overstrike_index_1 = ((fpf_loop - 1) * page_info.width) + 1;
			     fpf_overstrike_index_2 = ((fpf_loop - status.remaining_lines_on_page - 1) * page_info.width) + 1;
			     substr (page_overstrike_info_redefined.bit_map,
				fpf_overstrike_index_1, page_info.width)
				= substr (page_overstrike_info_redefined.bit_map, 
				fpf_overstrike_index_2, page_info.width);
			     substr (page_overstrike_info_redefined.chars, 
				fpf_overstrike_index_1, page_info.width)
				= substr (page_overstrike_info_redefined.chars, 
				fpf_overstrike_index_2, page_info.width);
			end;
		     end;
		end;
		status.current_line_on_page = template_map_number_of_bits;
		status.remaining_lines_on_page = 0;
	     end;
	     else;
	else;
%skip(1);
	return;
%skip(1);
     end format_page_footer;
%page;
format_page_header: proc;
%skip(1);
dcl fph_code fixed bin (35);
%skip(3);
/*
     Unpaginated reports only have the header placed before the first row.
     Format the header and if it doesn't fit shut things down.
*/
%skip(1);
	if ^paginated_report & ^status.flags.first_row_of_report
	then return;
%skip(1);
	call format_header (format_report_info.page_header_info_ptr, PAGE_HEADER,
	     status.current_line_on_page, status.remaining_lines_on_page,
	     formatted_page_info.page_header_length, fph_code);
	if fph_code ^= 0
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_format,
	     "^/There isn't enough room to place the page header on page number ^d.",
	     status.current_page_number);
%skip(1);
	return;
%skip(1);
     end format_page_header;
%page;
format_row: proc (

	fr_executing_object_parm,	    /* input: who's calling */
	fr_output_columns_info_ptr_parm,  /* input: ptr to output_columns_info */
	fr_row_template_info_ptr_parm,    /* input: ptr to template_info */
	fr_number_of_blank_lines_parm,    /* input: # of blank lines after row */
	fr_current_line_number_parm,	    /* input/output: current line on page */
	fr_remaining_lines_on_page_parm,  /* input/output: number left on page  */
	fr_number_of_lines_used_parm,     /* output: number of lines used */
	fr_code_parm		    /* output: success or failure */
		);
%skip(1);
dcl fr_current_line_number_parm fixed bin parm;
dcl fr_code_parm fixed bin (35) parm;
dcl fr_current_detail_line fixed bin;
dcl fr_current_line_number fixed bin;
dcl fr_executing_object_parm char (*) varying parm;
dcl fr_loop fixed bin;
dcl fr_next_line_number fixed bin;
dcl fr_number_of_blank_lines_parm fixed bin;
dcl fr_number_of_lines_used fixed bin;
dcl fr_number_of_lines_used_by_prefix fixed bin;
dcl fr_number_of_lines_used_parm fixed bin parm;
dcl 1 fr_output_columns_info like output_columns_info based (fr_output_columns_info_ptr);
dcl fr_output_columns_info_ptr ptr;
dcl fr_output_columns_info_ptr_parm ptr parm;
dcl fr_remaining_lines_on_page_parm fixed bin parm;
dcl 1 fr_row_template_info like template_info based (fr_row_template_info_ptr);
dcl fr_row_template_info_ptr ptr;
dcl fr_row_template_info_ptr_parm ptr parm;
dcl fr_still_counting_lines bit (1) aligned;
%skip(1);
/*
     Move parms into automatic variables, check to make sure we aren't
     about to run off the page, lay down a template on the first line and
     mark it.
*/
%skip(1);
	status.object_being_evaluated = fr_executing_object_parm;
	fr_output_columns_info_ptr = fr_output_columns_info_ptr_parm;
	fr_row_template_info_ptr = fr_row_template_info_ptr_parm;
	fr_current_line_number = fr_current_line_number_parm;
	fr_number_of_lines_used_parm = 0;
	fr_code_parm = 0;
%skip(1);
	fr_current_detail_line = 1;
	template_ptr = addr (fr_row_template_info.templates (fr_current_detail_line));
	if fr_current_line_number > template_map_number_of_bits
	then do;
	     fr_code_parm = PAGE_OVERFLOW_ERROR_CODE;
	     return;
	end;
	page_defined_as_lines (fr_current_line_number) = template;
	template_map (fr_current_line_number) = ON;
%page;
/*
     Repeat the following sequence for each column that isn't being outlined.
     If it has a prefix character then expand it to full column width and
     have it fit into the output column. If it has an editing request then use
     it; else rtrim character column values and rtrim and ltrim all other 
     column values. Fit the column into the output column. If we're not on
     the last column and the next column goes onto a different output line,
     then find out where the next output line is and lay down a template also
     marking it (making sure it doesn't place us past the end of the page).
*/
%skip(1);
	do status.current_column_number = 1 to fr_output_columns_info.number_of_columns;
	     column_ip = addr (fr_output_columns_info.columns (status.current_column_number));
	     if ^column_info.flags.outline
	     then do;
		if length (column_info.prefix_character) > 0
		then do;
		     fr_spare_string = copy (column_info.prefix_character, column_info.width);
		     call fit_column (fr_spare_string, column_info.width,
			column_info.starting_position, LEFT_ALIGNMENT,
			0, template, FILL, fr_current_line_number, fr_code_parm);
		     if fr_code_parm ^= 0
		     then return;
		     else fr_number_of_lines_used_by_prefix = 1;
		end;
		else fr_number_of_lines_used_by_prefix = 0;
		if column_info.flags.editing
		then do;
		     editing_string_rl = column_info.editing_string_result_length;
		     editing_string_rp = column_info.editing_string_result_ptr;
		     input_string = editing_string_result;
		end;
		else do;
		     if column_info.subsystem_data_type ^= CHAR_DATA_TYPE
		     then input_string = ltrim (rtrim (substr (current_row_value,
			table_info.columns.column_index (column_info.input_column),
			table_info.columns.column_length (column_info.input_column))));
		     else input_string = rtrim (substr (current_row_value,
			table_info.columns.column_index (column_info.input_column),
			table_info.columns.column_length (column_info.input_column)));
		end;
		call fit_column (input_string, column_info.width,
		     column_info.starting_position, column_info.alignment,
		     column_info.decimal_position, template, column_info.folding_is_fill, 
		     fr_current_line_number + fr_number_of_lines_used_by_prefix, fr_code_parm);
		if fr_code_parm ^= 0
		then return;
	     end;
	     else;
	     if status.current_column_number ^= fr_output_columns_info.number_of_columns
	     then if fr_output_columns_info.columns (status.current_column_number).output_line
		^= fr_output_columns_info.columns (status.current_column_number + 1).output_line
		then do;
		     if fr_current_line_number < template_map_number_of_bits
		     then fr_next_line_number = index (substr (template_map_defined_as_a_string,
			fr_current_line_number + 1), OFF);
		     else fr_next_line_number = 0;
		     if fr_next_line_number = 0
		     then do;
			fr_code_parm = PAGE_OVERFLOW_ERROR_CODE;
			return;
		     end;
		     fr_current_line_number = fr_current_line_number + fr_next_line_number;
		     fr_current_detail_line = fr_current_detail_line + 1;
		     template_ptr = addr (fr_row_template_info.templates (fr_current_detail_line));
		     page_defined_as_lines (fr_current_line_number) = template;
		     template_map (fr_current_line_number) = ON;
		end;
	end;
%skip(1);
/*
     Find out how many lines we've used. Add any blank trailer lines requested
     by the caller. Set the parms and return to caller.
*/
%skip(1);
	fr_still_counting_lines = ON;
	fr_number_of_lines_used = 0;
%skip(1);
	do fr_loop = fr_current_line_number_parm to template_map_number_of_bits
	     while (fr_still_counting_lines);
	     if template_map (fr_loop)
	     then fr_number_of_lines_used = fr_number_of_lines_used + 1;
	     else fr_still_counting_lines = OFF;
	end;
%skip(1);
	if fr_number_of_blank_lines_parm ^= 0
	then do;
	     fr_current_line_number = fr_current_line_number_parm + fr_number_of_lines_used;
	     do fr_loop = 1 to fr_number_of_blank_lines_parm;
		if fr_current_line_number ^> template_map_number_of_bits
		then do;
		     page_defined_as_lines (fr_current_line_number) = generic_template;
		     template_map (fr_current_line_number) = ON;
		     fr_current_line_number = fr_current_line_number + 1;
		     fr_number_of_lines_used = fr_number_of_lines_used + 1;
		end;
		else do;
		     fr_code_parm = PAGE_OVERFLOW_ERROR_CODE;
		     return;
		end;
	     end;
	end;
%skip(1);
	fr_number_of_lines_used_parm = fr_number_of_lines_used;
	fr_current_line_number_parm = fr_current_line_number_parm + fr_number_of_lines_used;
	fr_remaining_lines_on_page_parm = template_map_number_of_bits - fr_current_line_number_parm + 1;
%skip(1);
	return;
%skip(1);
     end format_row;
%page;
format_title_block: proc;
%skip(1);
dcl ftb_code fixed bin (35);
dcl ftb_current_line_number fixed bin;
dcl ftb_loop fixed bin;
%skip(3);
/*
     Unpaginated reports only have the title block placed before the first
     row of the report. Create the title block if it's our first time and
     save it away for future use if it's a paginated report. If it isn't our
     first time then just place the title block we've already created. If the
     title block contains overstruck characters then they loose this 
     optimization (the title block is formatted every time it's needed). If
     the title block doesn't fit then shut things down.
*/
%skip(1);
	if (^paginated_report & ^status.flags.first_row_of_report)
	then  return;
%skip(1);
	if format_report_info.title_block_info_ptr = null ()
	then call create_title_block (ftb_code);
	else call place_title_block (ftb_code);
%skip(1);
	if ftb_code ^= 0
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_format,
	     "^/There isn't enough room to place the titles on page number ^d.",
	     status.current_page_number);
%skip(1);
	return;
%page;
create_title_block: proc (ctb_code_parm);
%skip(1);
dcl ctb_code_parm fixed bin (35) parm;
%skip(3);
/*
     Format the title block onto the page. If it's not a paginated report or
     it contains overstruck characters then return to caller. Allocate the
     title_block_info structure and save away our formatted lines for future
     placement on the coming pages.
*/
%skip(1);
	title_block_columns_ip = format_report_info.title_block_columns_info_ptr;
	ftb_current_line_number = status.current_line_on_page;
	call format_row (ROW_TITLES, title_block_columns_ip,
	     row_value_template_ip, GENERATE_ONE_BLANK_LINE_TRAILER,
	     status.current_line_on_page, status.remaining_lines_on_page,
	     formatted_page_info.title_block_length, ctb_code_parm);
	if ctb_code_parm ^= 0
	then return;
%skip(1);
	if ^paginated_report
	then return;
	else if page_info.page_overstrike_info_ptr ^= null ()
	     then if index (substr (page_overstrike_info_redefined.bit_map,
	          ((ftb_current_line_number - 1) * page_info.width) + 1,
	          page_info.width * formatted_page_info.title_block_length), ON) ^= 0
	          then return;
%skip(1);
	tbi_init_line_length = page_info.width;
	tbi_init_number_of_lines = formatted_page_info.title_block_length;
	allocate title_block_info in (work_area) set (title_block_ip);
%skip(1);
	do ftb_loop = 1 to formatted_page_info.title_block_length;
	     title_block_info.lines (ftb_loop) = page_defined_as_lines (ftb_current_line_number);
	     ftb_current_line_number = ftb_current_line_number + 1;
	end;
%skip(1);
	format_report_info.title_block_info_ptr = title_block_ip;
%skip(1);
	return;
%skip(1);
     end create_title_block;
%page;
place_title_block: proc (ptb_code_parm);
%skip(1);
dcl ptb_code_parm fixed bin (35) parm;
%skip(3);
/*
     Place the saved away title lines onto the page. Lay down a title line
     and mark the template map. Repeat while we have more title lines. Set
     the title block length, current line on page, and remaining lines on
     page.
*/
%skip(1);
	ptb_code_parm = 0;
	title_block_ip = format_report_info.title_block_info_ptr;
	ftb_current_line_number = status.current_line_on_page;
%skip(1);
	do ftb_loop = 1 to title_block_info.number_of_lines;
	     if ftb_current_line_number > template_map_number_of_bits
	     then do;
		ptb_code_parm = PAGE_OVERFLOW_ERROR_CODE;
		return;
	     end;
	     page_defined_as_lines (ftb_current_line_number) = title_block_info.lines (ftb_loop);
	     template_map (ftb_current_line_number) = ON;
	     ftb_current_line_number = ftb_current_line_number + 1;
	end;
%skip(1);
	formatted_page_info.title_block_length = title_block_info.number_of_lines;
	status.current_line_on_page = status.current_line_on_page + title_block_info.number_of_lines;
	status.remaining_lines_on_page = template_map_number_of_bits - status.current_line_on_page + 1;
%skip(1);
	return;
%skip(1);
     end place_title_block;
%skip(3);
     end format_title_block;
%page;
format_subtotals: proc (

	fst_subtotal_info_ptr_parm,		 /* input: ptr to subtotal_info structure */
	fst_subtotal_columns_info_ptr_parm,	 /* input: ptr to subtotal_columns_info structure */
	fst_subtotal_generation_info_ptr_parm,	 /* input: ptr to subtotal_generation_info structure */
	fst_caller_parm,			 /* input: "row subtotal" or "row subcount" */
	fst_number_of_lines_used_parm,	 /* output: how many lines the block used */
	fst_subtotals_ejection_in_progress_parm, /* output: on when ejection starts, off after ejection complete */
	fst_code_parm			 /* output: success or failure */
		   );
%skip(1);
dcl fst_caller_parm char (*) varying;
dcl fst_code_parm fixed bin (35) parm;
dcl fst_number_of_lines_used fixed bin;
dcl fst_number_of_lines_used_parm fixed bin;
dcl fst_some_column_changed bit (1) aligned;
dcl 1 fst_subtotal_columns_info like subtotal_columns_info based (fst_subtotal_columns_info_ptr_parm);
dcl fst_subtotal_columns_info_ptr_parm ptr parm;
dcl 1 fst_subtotal_generation_info like subtotal_generation_info based (fst_subtotal_generation_info_ptr_parm);
dcl fst_subtotal_generation_info_ptr_parm ptr parm;
dcl 1 fst_subtotal_info like subtotal_info based (fst_subtotal_info_ptr_parm);
dcl fst_subtotal_info_ptr_parm ptr parm;
dcl fst_subtotals_ejection_in_progress_parm bit (1) aligned parm;
dcl fst_subtotals_have_been_backed_up bit (1) aligned;
dcl fst_total_lines_used fixed bin;
%skip(1);
/*
     Walk through the subtotals level by level. Check the watch columns to see
     if any at the current level have changed. If any have, then back up the
     subtotals if they haven't been backed up already. Generate subtotals 
     whose watch columns have changed, returning to caller if they don't fit.
     Set our number of lines used parm and return to caller.
*/
%skip(1);
	fst_code_parm = 0;
	fst_number_of_lines_used_parm = 0;
	fst_total_lines_used = 0;
	fst_subtotals_have_been_backed_up = OFF;
%skip(1);
	do fst_subtotal_info.current_level = 1 to fst_subtotal_info.highest_level;
	     call check_for_subtotal_break (fst_subtotal_info_ptr_parm, fst_subtotal_columns_info_ptr_parm,
		fst_subtotal_info.current_level, fst_some_column_changed);
	     if fst_some_column_changed
	     then do;
		if ^fst_subtotals_have_been_backed_up
		then call make_backup_of_subtotals;
		fst_subtotals_have_been_backed_up = ON;
		call generate_subtotals (fst_subtotal_info.current_level,
		     fst_number_of_lines_used, fst_code_parm);
		if fst_code_parm ^= 0
		then return;
		fst_total_lines_used = fst_total_lines_used + fst_number_of_lines_used;
	     end;
	end;
%skip(1);
	fst_number_of_lines_used_parm = fst_total_lines_used;
	fst_subtotals_ejection_in_progress_parm = OFF;
%skip(1);
	return;
%page;
generate_subtotals: proc (

	gs_level_number_parm,	/* input: current subtotal level number */
	gs_number_of_lines_used_parm,	/* output: number of lines used */
	gs_code_parm		/* output: success or failure */
		     );
%skip(1);
dcl gs_code_parm fixed bin (35) parm;
dcl gs_level_number_parm fixed bin;
dcl gs_loop fixed bin;
dcl gs_number_of_lines_used_parm fixed bin parm;
%skip(3);
/*
     Use the headers temp seg for temporary storage. Walk through all of the
     subtotals. For each one at the current level number that isn't being
     outlined, format the float dec (59) into character format. Then format
     the row. Walk through all of the subtotals again, and for each one at
     the current level, restore it's editing flag to what it used to be and
     zero any reset subtotals.
*/
%skip(1);
	headers_next_byte = format_report_info.headers_next_available_byte;
	fst_subtotals_ejection_in_progress_parm = ON;
%skip(1);
	do gs_loop = 1 to fst_subtotal_info.number_of_columns_to_subtotal;
	     if gs_level_number_parm = fst_subtotal_info.columns (gs_loop).level
	     then do;
		column_ip = addr (fst_subtotal_columns_info.columns
		     (input_columns_info.columns (fst_subtotal_info.columns (gs_loop).input_column).output_column));
		if ^column_info.flags.outline
		then call format_total_or_subtotal_into_character_format (
		     fst_subtotal_info.columns.subtotal (gs_loop), fst_subtotal_info.columns.ioa_string (gs_loop));
	     end;
	end;
%skip(1);
	call format_row (fst_caller_parm, fst_subtotal_columns_info_ptr_parm,
	     row_value_template_ip, GENERATE_ONE_BLANK_LINE_TRAILER,
	     status.current_line_on_page, status.remaining_lines_on_page,
	     gs_number_of_lines_used_parm, gs_code_parm);
%skip(1);
	if gs_code_parm = 0
	then status.flags.detail_block_used_some_lines = ON;
%page;
	do gs_loop = 1 to fst_subtotal_info.number_of_columns_to_subtotal;
	     if gs_level_number_parm = fst_subtotal_info.columns (gs_loop).level
	     then do;
		column_ip = addr (fst_subtotal_columns_info.columns (input_columns_info.columns (
		     fst_subtotal_info.columns (gs_loop).input_column).output_column));
		column_info.flags.editing = column_info.flags.restore_editing;
		if ^column_info.flags.outline & fst_subtotal_info.columns (gs_loop).flags.reset
		then fst_subtotal_info.columns (gs_loop).subtotal = 0;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end generate_subtotals;
%page;
make_backup_of_subtotals: proc;
%skip(1);
dcl mbos_loop fixed bin;
%skip(3);
/*
     Advance the current generation block in our circular table. Backup each subtotal.
*/
%skip(1);
	fst_subtotal_generation_info.current_generation_block
	     = mod (fst_subtotal_generation_info.current_generation_block + 1, 
	     fst_subtotal_generation_info.maximum_number_of_generation_blocks);
%skip(1);
	do mbos_loop = 1 to fst_subtotal_generation_info.number_of_subtotals;
	     fst_subtotal_generation_info.generations
		(fst_subtotal_generation_info.current_generation_block).subtotals (mbos_loop)
		= fst_subtotal_info.columns (mbos_loop).subtotal;
	end;
%skip(1);
	return;
%skip(1);
     end make_backup_of_subtotals;
%skip(1);
     end format_subtotals;
%page;
format_total_or_subtotal_into_character_format: proc (

	ftosicf_subtotal_or_total_parm, /* input: the total or subtotal */
	ftosicf_ioa_string_parm	  /* input: ioa_ string for editing */
					   );
%skip(1);
dcl ftosicf_ioa_string_parm char (*) varying parm;
dcl ftosicf_length_doesnt_matter fixed bin (21);
dcl ftosicf_subtotal_or_total_parm float dec (59) parm;
%skip(3);
/*
     If the subtotal has an editing request then it's already been edited
     through it's parent column's editing request be the column_value request.
     Pick it up, or in the case of ones that don't have an editing request,
     edit them through ioa_ with the supplied string. Set the pointer and
     length to this result string, and stash the result string into the headers
     temp seg. Advance the next byte index, save the editing bit value, and 
     turn on the editing bit for this column.
*/
%skip(1);
	if column_info.flags.editing
	then do;
	     editing_string_rl = column_info.editing_string_length;
	     editing_string_rp = column_info.editing_string_ptr;
	     input_string = editing_string_result;
	     call evaluate_active_string (input_string, output_string);
	end;
	else call ioa_$rsnnl (ftosicf_ioa_string_parm, output_string,
	     ftosicf_length_doesnt_matter, ftosicf_subtotal_or_total_parm);
%skip(1);
	column_info.editing_string_result_length = length (output_string);
	column_info.editing_string_result_ptr
	     = addr (headers_temp_seg_as_an_array (headers_next_byte));
	substr (headers_temp_seg, headers_next_byte,
	     column_info.editing_string_result_length) = output_string;
	headers_next_byte = headers_next_byte + column_info.editing_string_result_length;
	column_info.flags.restore_editing = column_info.flags.editing;
	column_info.flags.editing = ON;
%skip(1);
	return;
%skip(1);
     end format_total_or_subtotal_into_character_format;
%page;
format_totals: proc (

	ft_total_info_ptr_parm,	       /* input: ptr to total_info structure */
	ft_total_columns_info_ptr_parm,      /* input: ptr to total_columns_info structure */
	ft_caller_parm,		       /* input: "row total" or "row count" */
	ft_number_of_lines_used_parm,	       /* output: number of lines used */
	ft_totals_ejection_in_progress_parm, /* output: on when ejection starts, off after ejection complete */
	ft_code_parm		       /* output: success or failure */
		);
%skip(1);
dcl ft_caller_parm char (*) varying parm;
dcl ft_code_parm fixed bin (35) parm;
dcl ft_loop fixed bin;
dcl ft_number_of_lines_used_parm fixed bin parm;
dcl 1 ft_total_columns_info like total_columns_info based (ft_total_columns_info_ptr_parm);
dcl ft_total_columns_info_ptr_parm ptr parm;
dcl 1 ft_total_info like total_info based (ft_total_info_ptr_parm);
dcl ft_total_info_ptr_parm ptr parm;
dcl ft_totals_ejection_in_progress_parm bit (1) aligned parm;
%skip(3);
/*
     Use the headers temp segment for temporary storage. For each total reach
     into the total_info array picking up the index to it's input column,
     which gives us the index into the input_columns_info array to pick up
     the index for the total_columns_info output column. Set the prefix to
     "=", turn off the outline bit, and format the total into character format.
     Then format the row and restore the editing bit for the columns.
*/
%skip(1);
	ft_code_parm = 0;
	ft_number_of_lines_used_parm = 0;
	ft_totals_ejection_in_progress_parm = ON;
%skip(1);
	headers_next_byte = format_report_info.headers_next_available_byte;
%skip(1);
	do ft_loop = 1 to ft_total_info.number_of_columns_to_total;
	     column_ip = addr (ft_total_columns_info.columns (input_columns_info.columns.output_column
		(ft_total_info.columns.input_column (ft_loop))));
	     column_info.prefix_character = "=";
	     column_info.flags.outline = OFF;
	     call format_total_or_subtotal_into_character_format (
		ft_total_info.columns.total (ft_loop), ft_total_info.columns.ioa_string (ft_loop));
	end;
%skip(1);
	call format_row (ft_caller_parm, ft_total_columns_info_ptr_parm,
	     row_value_template_ip, GENERATE_ZERO_BLANK_LINES_TRAILER,
	     status.current_line_on_page, status.remaining_lines_on_page,
	     ft_number_of_lines_used_parm, ft_code_parm);
%page;
	if ft_code_parm = 0
	then status.flags.detail_block_used_some_lines = ON;
%skip(1);
	do ft_loop = 1 to ft_total_columns_info.number_of_columns;
	     ft_total_columns_info.columns (ft_loop).flags.editing
		= ft_total_columns_info.columns (ft_loop).flags.restore_editing;
	end;
%skip(1);
	ft_totals_ejection_in_progress_parm = OFF;
%skip(1);
	return;
%skip(1);
     end format_totals;
%page;
gather_counts: proc;
%skip(1);
dcl gc_loop fixed bin;
%skip(3);
/*
     If the row hasn't been processed before then add one to the count.
*/
%skip(1);
	if status.flags.row_has_been_processed_before
	then return;
%skip(1);
	do gc_loop = 1 to count_info.number_of_columns_to_total;
	     count_info.columns (gc_loop).total
		= count_info.columns (gc_loop).total + 1;
	end;
%skip(1);
	return;
%skip(1);
     end gather_counts;
%page;
gather_subcounts: proc;
%skip(1);
dcl gs_loop fixed bin;
%skip(3);
/*
     Add one to the subcount.
*/
%skip(1);
	do gs_loop = 1 to subcount_info.number_of_columns_to_subtotal;
	     subcount_info.columns.subtotal (gs_loop)
		= subcount_info.columns.subtotal (gs_loop) + 1;
	end;
%skip(1);
	return;
%skip(1);
     end gather_subcounts;
%page;
gather_subtotals: proc;
%skip(1);
dcl gs_loop fixed bin;
%skip(3);
/*
     Add in the value of the current column to the subtotal.
*/
%skip(1);
	do gs_loop = 1 to subtotal_info.number_of_columns_to_subtotal;
	     subtotal_info.columns (gs_loop).subtotal
		= subtotal_info.columns (gs_loop).subtotal
		+ float (substr (current_row_value,
		table_info.columns.column_index (subtotal_info.columns.input_column (gs_loop)),
		table_info.columns.column_length (subtotal_info.columns.input_column (gs_loop))));
	end;
%skip(1);
	return;
%skip(1);
     end gather_subtotals;
%page;
gather_totals: proc;
%skip(1);
dcl gt_loop fixed bin;
%skip(3);
/*
     If the row hasn't been processed before then add the current column's
     value into the total.
*/
%skip(1);
	if status.flags.row_has_been_processed_before
	then return;
%skip(1);
	do gt_loop = 1 to total_info.number_of_columns_to_total;
	     total_info.columns (gt_loop).total
		= total_info.columns (gt_loop).total
		+ float (substr (current_row_value,
		table_info.columns.column_index (total_info.columns.input_column (gt_loop)),
		table_info.columns.column_length (total_info.columns.input_column (gt_loop))));
	end;
%skip(1);
	return;
%skip(1);
     end gather_totals;
%page;
housekeeping: proc;
%skip(3);
/*
     Move everything we need into automatic variables.
*/
%skip(1);
          sci_ptr = report_control_info.subsystem_control_info_ptr;
	maximum_segment_size = sys_info$max_seg_size * 4;
%skip(1);
	work_area_ptr = report_control_info.report_work_area_ptr;
	temp_seg_ptr = report_control_info.report_temp_seg_ptr;
%skip(1);
	format_report_ip = report_control_info.format_report_info_ptr;
	table_ip = format_report_info.table_info_ptr;
	table_control_ip = report_control_info.table_control_info_ptr;
	table_segments_ip = table_control_info.table_segments_info_ptr;
%skip(1);
	input_columns_ip = format_report_info.input_columns_info_ptr;
	input_columns_op = format_report_info.input_columns_order_ptr;
	output_columns_ip = format_report_info.output_columns_info_ptr;
%skip(1);
	input_string_ptr = report_control_info.input_string_temp_seg_ptr;
	input_string_length = maximum_segment_size - 4;
	input_string = "";
	input_string_non_varying_ptr = addrel (input_string_ptr, 1);
	input_string_non_varying_length = 0;
%skip(1);
	output_string_ptr = report_control_info.output_string_temp_seg_ptr;
	output_string_length = maximum_segment_size - 4;
	output_string = "";
	output_string_non_varying_ptr = addrel (output_string_ptr, 1);
	output_string_non_varying_length = output_string_length;
%skip(1);
	editing_strings_tsp = report_control_info.editing_strings_temp_seg_ptr;
	headers_tsp = report_control_info.headers_temp_seg_ptr;
%skip(1);
	group_ip = format_report_info.group_info_ptr;
	outline_ip = format_report_info.outline_info_ptr;
	page_break_ip = format_report_info.page_break_info_ptr;
%skip(1);
	if format_report_info.flags.subtotal_is_defined
	then do;
	     subtotal_ip = format_report_info.subtotal_info_ptr;
	     subtotal_columns_ip = subtotal_info.columns_info_ptr;
	     subtotal_generation_ip = subtotal_info.subtotal_generation_info_ptr;
	end;
%page;
	if format_report_info.flags.subcount_is_defined
	then do;
	     subcount_ip = format_report_info.subcount_info_ptr;
	     subcount_columns_ip = subcount_info.columns_info_ptr;
	     subcount_generation_ip = subcount_info.subtotal_generation_info_ptr;
	end;
%skip(1);
	if format_report_info.flags.total_is_defined
	then do;
	     total_ip = format_report_info.total_info_ptr;
	     total_columns_ip = total_info.columns_info_ptr;
	end;
%skip(1);
	if format_report_info.flags.count_is_defined
	then do;
	     count_ip = format_report_info.count_info_ptr;
	     count_columns_ip = count_info.columns_info_ptr;
	end;
%skip(1);
	format_document_options_ptr = format_report_info.format_document_op;
%skip(1);
	paginated_report = report_control_info.report_is_paginated;
	page_ip = format_report_info.copy_of_page_info_ptr;
	page_info = format_report_info.page_info_ptr -> page_info;
	page_info.page_overstrike_info_ptr = null ();
	page_overstrike_ip = format_report_info.overstrike_info_ptr;
%skip(1);
	formatted_page_ip = format_report_info.formatted_page_info_ptr;
	row_value_template_ip = format_report_info.row_value_template_info_ptr;
	template_length = page_info.width;
	generic_template_length = template_length;
	generic_tp = format_report_info.generic_template_ptr;
%skip(1);
	template_map_number_of_bits = page_info.length;
	template_mp = format_report_info.template_map_ptr;
%skip(1);
	truncation_indicator_length = length (format_report_info.truncation_indicator);
	status_pointer = format_report_info.status_ptr;
%skip(1);
          code = 0;
%skip(1);
          return;
%skip(1);
     end housekeeping;
%page;
make_ptr: proc (mp_row_number_parm) returns (ptr);
%skip(1);
dcl mp_row_number_parm fixed bin (35) parm;
dcl mp_segment_ptr_index fixed bin (21);
dcl mp_row_ptr_index fixed bin (21);
%skip(3);
/*
     Make an index for the segment that the row pointer lives in. Make an
     index for the row pointer within the segment. Make a pointer to the
     segment. Return the pointer for the row.
*/
%skip(1);
	mp_segment_ptr_index = divide (mp_row_number_parm,
	     table_segments_info.maximum_number_of_ptrs_per_segment, 21);
	if mod (mp_row_number_parm, table_segments_info.maximum_number_of_ptrs_per_segment) ^= 0
	then mp_segment_ptr_index = mp_segment_ptr_index + 1;
%skip(1);
	mp_row_ptr_index = mod (mp_row_number_parm, table_segments_info.maximum_number_of_ptrs_per_segment);
	if mp_row_ptr_index = 0
	then mp_row_ptr_index = table_segments_info.maximum_number_of_ptrs_per_segment;
%skip(1);
	row_ptrs_ptr = table_segments_info.segment_ptrs (mp_segment_ptr_index);
%skip(1);
	return (row_ptrs.row_value_ptr (mp_row_ptr_index));
%skip(1);
     end make_ptr;
%page;
make_rows_available: proc;
%skip(3);
dcl mra_code fixed bin (35);
dcl mra_number_of_rows_needed fixed bin (35);
dcl mra_number_of_rows_retrieved fixed bin (35);
%skip(1);
/*
     If the table is full, or we have enough rows to do this page then return.
     Have the rows loaded and time the operation, removing this time from our
     formatting time so the timers are accurate. Bump the number of rows 
     retrieved and check for end of file on the data base setting appropriate
     flags. Shut things down if anything went wrong.
*/
%skip(1);
	if report_control_info.flags.table_is_full
	then return;
%skip(1);
	mra_number_of_rows_needed = page_info.length + 1;
	if report_control_info.no_of_rows_retrieved - status.current_row_number > mra_number_of_rows_needed
	then return;
%skip(1);
	time1 = vclock;
	call rw_table_manager$load_rows (report_cip,
	     mra_number_of_rows_needed, mra_number_of_rows_retrieved, mra_code);
	time2 = vclock;
	report_control_info.table_loading_time
	     = report_control_info.table_loading_time + (time2 - time1);
	report_control_info.report_formatting_time
	     = report_control_info.report_formatting_time - (time2 - time1);
%skip(1);
	if mra_number_of_rows_retrieved ^= 0
	then report_control_info.no_of_rows_retrieved
	     = report_control_info.no_of_rows_retrieved + mra_number_of_rows_retrieved;
	if mra_code ^= 0
	then if mra_code = error_table_$end_of_info
	     then do;
		report_control_info.flags.table_is_full = ON;
		report_control_info.flags.table_has_just_been_loaded = ON;
		if status.current_row_number = report_control_info.no_of_rows_retrieved
		then status.flags.last_row_of_report = ON;
	     end;
	     else call ssu_$abort_line (sci_ptr, mra_code,
		"While trying to retrieve ^d rows.", mra_number_of_rows_needed);
	else;
%skip(1);
	return;
%skip(1);
     end make_rows_available;
%page;
make_row_ptrs: proc;
%skip(3);
/*
     Make pointers to the previous, current and next rows.
*/
%skip(1);
	status.previous_row_ptr = status.current_row_ptr;
%skip(1);
	status.current_row_ptr = status.next_row_ptr;
	if status.current_row_ptr = null ()
	then status.current_row_ptr = make_ptr (status.current_row_number);
%skip(1);
	if status.flags.last_row_of_report
	then status.next_row_ptr = null ();
	else status.next_row_ptr = make_ptr (status.current_row_number + 1);
%skip(1);
	return;
%skip(1);
     end make_row_ptrs;
%page;
save_copy_of_page: proc;
%skip(3);
dcl scop_code fixed bin (35);
dcl scop_record_key char (256) varying;
dcl scop_record_length fixed bin (21);
dcl scop_record_number fixed bin (21);
%skip(1);
/*
     Use the page or buffer number as the key for the record. Save a copy
     of the formatted page. Append ".page_info" to the page number and save the
     page_info structure under that key. Append ".formatted_page_info" to
     the page number and save the formatted_page_info structure under that
     key. If the page contains overstrikes then append ".page_overstrike_info"
     to the page number and save the page_overstrike_info structure under
     that key.
*/
%skip(1);
	scop_record_number = report_control_info.no_of_formatted_pages;
	scop_record_key = ltrim (convert (scop_record_key, scop_record_number));
	call iox_$seek_key (format_report_info.report_iocb_ptr,
	     scop_record_key, scop_record_length, scop_code);
	if scop_code ^= error_table_$no_record
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Logic error while trying to save a copy of page ^a.", scop_record_key);
%skip(1);
	call iox_$write_record (format_report_info.report_iocb_ptr,
	     page_info.page_ptr, page_info.total_characters, scop_code);
	if scop_code ^= 0
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Unable to save a copy of page ^d.", scop_record_key);
%skip(1);
	scop_record_key = scop_record_key || ".page_info";
	call iox_$seek_key (format_report_info.report_iocb_ptr,
	     scop_record_key, scop_record_length, scop_code);
	if scop_code ^= error_table_$no_record
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Logic error while trying to save a copy of page ^a.", scop_record_key);
%skip(1);
	call iox_$write_record (format_report_info.report_iocb_ptr,
	     page_ip, page_info.page_info_size * 4, scop_code);
	if scop_code ^= 0
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Unable to save a copy of page ^d.", scop_record_key);
%page;
	scop_record_key = before (scop_record_key, ".") || ".formatted_page_info";
	call iox_$seek_key (format_report_info.report_iocb_ptr,
	     scop_record_key, scop_record_length, scop_code);
	if scop_code ^= error_table_$no_record
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Logic error while trying to save a copy of page ^a.", scop_record_key);
%skip(1);
	call iox_$write_record (format_report_info.report_iocb_ptr,
	     formatted_page_ip, currentsize (formatted_page_info) * 4, scop_code);
	if scop_code ^= 0
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Unable to save a copy of page ^d.", scop_record_key);
%skip(1);
	if page_info.page_overstrike_info_ptr = null ()
	then return;
%skip(1);
	scop_record_key = before (scop_record_key, ".") || ".page_overstrike_info";
	call iox_$seek_key (format_report_info.report_iocb_ptr,
	     scop_record_key, scop_record_length, scop_code);
	if scop_code ^= error_table_$no_record
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Logic error while trying to save a copy of page ^a.", scop_record_key);
%skip(1);
	call iox_$write_record (format_report_info.report_iocb_ptr,
	     page_overstrike_ip, currentsize (page_overstrike_info) * 4, scop_code);
	if scop_code ^= 0
	then call ssu_$abort_line (sci_ptr, scop_code,
	     "Unable to save a copy of page ^d.", scop_record_key);
%skip(1);
	return;
%skip(1);
     end save_copy_of_page;
%page;
setup_for_a_page: proc;	
%skip(3);
/*
     Set all of the info needed to begin a new page.
*/
%skip(1);
	page_ip = format_report_info.copy_of_page_info_ptr;
	page_info = format_report_info.page_info_ptr -> page_info;
	page_info.page_overstrike_info_ptr = null ();
	page_overstrike_ip = format_report_info.overstrike_info_ptr;
%skip(1);
	formatted_page_info.page_header_length = 0;
	formatted_page_info.title_block_length = 0;
	formatted_page_info.page_footer_length = 0;
	formatted_page_info.number_of_detail_blocks = 0;
	unspec (formatted_page_info.detail_blocks) = OFF;
%skip(1);
	template_map (*) = OFF;
%skip(1);
	if format_report_info.number_of_formatted_rows = 0
	then status.flags.first_row_of_report = ON;
	else status.flags.first_row_of_report = OFF;
	status.current_row_number = format_report_info.number_of_formatted_rows + 1;
	if report_control_info.flags.table_is_full
	& report_control_info.no_of_rows_retrieved = status.current_row_number
	then status.flags.last_row_of_report = ON;
	else status.flags.last_row_of_report = OFF;
	status.flags.first_row_on_page = ON;
	status.flags.page_overflow = OFF;
	status.flags.subtotals_ejection_in_progress = OFF;
	status.flags.totals_ejection_in_progress = OFF;
	status.flags.header_being_evaluated = OFF;
	status.flags.detail_block_used_some_lines = ON;
%skip(1);
	status.total_number_of_rows_used = 0;
	if paginated_report
	then status.current_page_number = report_control_info.no_of_formatted_pages + 1;
	else status.current_page_number = 1;
	status.current_line_on_page = 1;
	status.remaining_lines_on_page = page_info.length;
	if status.current_row_number ^> status.highest_row_formatted
	then status.flags.row_has_been_processed_before = ON;
	else status.flags.row_has_been_processed_before = OFF;
%skip(1);
	return;
%skip(1);
     end setup_for_a_page;
%page;
sub_error_handler: proc;
%skip(1);
dcl seh_code fixed bin (35);
%skip(3);
/*
     Find the sub_error_info structure and if it wasn't format_document_ that
     signalled it then continue to signal. Set the ptr to the 
     format_document_error structure and print the error message with added
     information to identify where in the report the error occured.
*/
%skip(1);
	condition_info_ptr = addr (local_condition_info);
	condition_info.version = condition_info_version_1;
	call find_condition_info_ (null (), condition_info_ptr, seh_code);
	if seh_code ^= 0
	then call ssu_$abort_line (sci_ptr, seh_code);
	sub_error_info_ptr = condition_info.info_ptr;
	if sub_error_info.name ^= "format_document_"
	then do;
	     call continue_to_signal_ (seh_code);
	     return;
	end;
%skip(1);
	format_document_error_ptr = sub_error_info.info_ptr;
	if status.flags.header_being_evaluated
	then call ssu_$print_message (sci_ptr, rw_error_$bad_report_format,
	     "^/Page ^d, ^a (line ^d, ^a).^/^a^x""^a""",
	     status.current_page_number, status.object_being_evaluated,
	     status.current_header_line, HEADER_PARTS_LABELS (status.current_header_part),
	     sub_error_info.header.info_string, format_document_error.text_line);
	else call ssu_$print_message (sci_ptr, rw_error_$bad_report_format,
	     "^/Page ^d, ^a (row ^d, ^a column).^/^a^x""^a""",
	     status.current_page_number, status.object_being_evaluated, status.current_row_number,
	     table_info.columns.column_name (output_columns_info.columns.input_column (status.current_column_number)),
	     sub_error_info.header.info_string, format_document_error.text_line);
%skip(1);
	return;
%skip(1);
     end sub_error_handler;
%page;
dcl BACKSPACE char (1) static int options (constant) init ("");
dcl BACKSPACE_OR_VERTICAL_TAB_OR_HORIZONTAL_TAB_OR_NL char (4) static int options (constant) init ("	
");
dcl BAR char (1) static int options (constant) init ("|");
dcl BAR_BAR char (2) static int options (constant) init ("||");
dcl BLANK char (1) static int options (constant) init (" ");
dcl FILL bit (1) unaligned static int options (constant) init ("1"b);
dcl FORM_FEED char (1) static int options (constant) init ("");
dcl GENERATE_ONE_BLANK_LINE_TRAILER fixed bin static int options (constant) init (1);
dcl GENERATE_ZERO_BLANK_LINES_TRAILER fixed bin static int options (constant) init (0);
dcl GROUP_FOOTER char (16) varying static int options (constant) init ("group footer");
dcl GROUP_HEADER char (16) varying static int options (constant) init ("group header");
dcl HEADER_PARTS_LABELS (3) char (11) varying static int options (constant) init
("left part", "center part", "right part");
dcl LEFT_BRACKET char (1) static int options (constant) init ("[");
dcl LEFT_OR_RIGHT_BRACKET char (2) static int options (constant) init ("[]");
dcl LOOK_AHEAD bit (1) aligned static int options (constant) init ("1"b);
dcl LOOK_BEHIND bit (1) aligned static int options (constant) init ("0"b);
dcl NEWLINE char (1) static int options (constant) init ("
");
dcl OFF bit (1) aligned int static options (constant) init ("0"b);
dcl ON bit (1) aligned int static options (constant) init ("1"b);
dcl PAGE_FOOTER char (16) varying static int options (constant) init ("page footer");
dcl PAGE_HEADER char (16) varying static int options (constant) init ("page header");
dcl PAGE_OVERFLOW_ERROR_CODE fixed bin (35) static int options (constant) init (1);
dcl ROW_COUNT char (16) varying static int options (constant) init ("row count");
dcl ROW_FOOTER char (16) varying static int options (constant) init ("row footer");
dcl ROW_HEADER char (16) varying static int options (constant) init ("row header");
dcl ROW_SUBCOUNT char (16) varying static int options (constant) init ("row subcount");
dcl ROW_SUBTOTAL char (16) varying static int options (constant) init ("row subtotal");
dcl ROW_TITLES char (16) varying static int options (constant) init ("row titles");
dcl ROW_TOTAL char (16) varying static int options (constant) init ("row total");
dcl ROW_VALUE char (16) varying static int options (constant) init ("row value");
%page;
dcl addr builtin;
dcl addrel builtin;
%skip(1);
dcl before builtin;
%skip(1);
dcl code fixed bin (35);
dcl copy builtin;
dcl continue_to_signal_ entry (fixed bin(35));
dcl convert builtin;
dcl currentsize builtin;
%skip(1);
dcl divide builtin;
%skip(1);
dcl eas_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl error_table_$badcall fixed bin(35) ext static;
dcl error_table_$end_of_info fixed bin(35) ext static;
dcl error_table_$no_record fixed bin(35) ext static;
dcl error_table_$recoverable_error fixed bin(35) ext static;
dcl error_table_$unbalanced_brackets fixed bin(35) ext static;
%skip(1);
dcl fc_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl find_condition_info_ entry (ptr, ptr, fixed bin(35));
dcl first_time_through_the_detail_block_loop bit (1) aligned;
dcl float builtin;
dcl format_document_$string entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35));
dcl fr_spare_string char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl index builtin;
dcl input_string char (input_string_length) varying based (input_string_ptr);
dcl input_string_length fixed bin (21);
dcl input_string_ptr ptr;
dcl input_string_non_varying char (input_string_non_varying_length) based (input_string_non_varying_ptr);
dcl input_string_non_varying_length fixed bin (21);
dcl input_string_non_varying_ptr ptr;
dcl ioa_$rsnnl entry() options(variable);
dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl iox_$seek_key entry (ptr, char(256) var, fixed bin(21), fixed bin(35));
%skip(1);
dcl length builtin;
dcl 1 local_condition_info like condition_info;
dcl ltrim builtin;
%skip(1);
dcl min builtin;
dcl mod builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl output_string char (output_string_length) varying based (output_string_ptr);
dcl output_string_length fixed bin (21);
dcl output_string_ptr ptr;
dcl output_string_non_varying char (output_string_non_varying_length) based (output_string_non_varying_ptr);
dcl output_string_non_varying_length fixed bin (21);
dcl output_string_non_varying_ptr ptr;
dcl 1 output_string_redefined based (output_string_ptr),
      2 length_word fixed bin (35) aligned,
      2 frobus char (output_string_non_varying_length) unaligned;
%skip(1);
dcl paginated_report bit (1) aligned;
dcl pc_column_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl rtrim builtin;
dcl rw_error_$bad_report_format fixed bin(35) ext static;
dcl rw_table_manager$load_rows entry (ptr, fixed bin (35), fixed bin (35), fixed bin (35));
%skip(1);
dcl search builtin;
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$evaluate_active_string entry (ptr, ptr, char(*), fixed bin, char(*) var, fixed bin(35));
dcl ssu_$print_message entry() options(variable);
dcl sub_error_ condition;
dcl substr builtin;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl temp_seg_ptr ptr;
dcl time1 float bin (63);
dcl time2 float bin (63);
dcl translate builtin;
dcl truncation_indicator_length fixed bin;
%skip(1);
dcl unspec builtin;
%skip(1);
dcl vclock builtin;
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include condition_info;
%page;
%include condition_info_header;
%page;
%include cp_active_string_types;
%page;
%include format_document_error;
%page;
%include format_document_options;
%page;
%include rw_options_extents;
%page;
%include rw_page_info;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%page;
%include rw_table_info;
%page;
%include rw_table_control_info;
%page;
%include sub_error_info;
%skip(3);
     end rw_fr_build_page;




		    rw_fr_delete_report.pl1         11/16/84  1355.9rew 11/16/84  1354.3       29142



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module is called by the the rw_display module to delete
     the environment set up by rw_fr_new_report.

 
     Known Bugs:
 
     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 - Became report_writer_.

*/
%page;
rw_fr_delete_report: proc (

	report_cip_parm,	/* input: point to report_control_info */
	code_parm		/* output: success or failure */
		         );
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl report_cip_parm ptr parm;
%skip(3);
	report_cip = report_cip_parm;
	code_parm = 0;
	sci_ptr = report_control_info.subsystem_control_info_ptr;
%skip(1);
	/* If we kept a copy of the original report while we were making it then delete it. */
%skip(1);
	if report_control_info.flags.permanent_report
	then do;
	     format_report_ip = report_control_info.format_report_info_ptr;
	     iocb_ptr = format_report_info.report_iocb_ptr;
	     if iocb_ptr ^= null ()
	     then do;
		call iox_$close (iocb_ptr, code);
		if code ^= 0
		then call ssu_$print_message (sci_ptr, code,
		     "While trying to close ^p.", iocb_ptr);
		call iox_$detach_iocb (iocb_ptr, code);
		if code ^= 0
		then call ssu_$print_message (sci_ptr, code,
		     "While trying to detach ^p.", iocb_ptr);
		call iox_$destroy_iocb (iocb_ptr, code);
		if code ^= 0
		then call ssu_$print_message (sci_ptr, code,
		     "While trying to destroy ^p.", iocb_ptr);
		call delete_$path (format_report_info.report_directory_name,
		     
		     format_report_info.report_entry_name,
		     "100111"b, "display", code);
		if code ^= 0
		then call ssu_$print_message (sci_ptr, code,
		     "While trying to delete ^a in directory^/^a.",
		     format_report_info.report_entry_name,
		     format_report_info.report_directory_name);
		format_report_info.report_iocb_ptr = null ();
		report_control_info.flags.permanent_report = "0"b;
	     end;
	end;
%skip(1);
	/* Refresh our area instead of freeing everything. */
%skip(1);
	work_area_ptr = report_control_info.report_work_area_ptr;
	call ssu_$release_area (sci_ptr, work_area_ptr);
	call ssu_$get_area (sci_ptr, report_control_info.area_info_ptr,
	     "rw_.report_area", report_control_info.report_work_area_ptr);
%skip(1);
	return;
%page;
dcl code fixed bin (35);
%skip(1);
dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35));
%skip(1);
dcl iocb_ptr ptr;
dcl iox_$close entry (ptr, fixed bin(35));
dcl iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl iox_$detach_iocb entry (ptr, fixed bin(35));
%skip(1);
dcl null builtin;
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$get_area entry (ptr, ptr, char(*), ptr);
dcl ssu_$print_message entry() options(variable);
dcl ssu_$release_area entry (ptr, ptr);
%skip(1);
dcl work_area_ptr ptr;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%skip(3);
     end rw_fr_delete_report;




		    rw_fr_get_page.pl1              11/16/84  1355.9rew 11/16/84  1354.4       44028



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module is called to get a page.

 
     Known Bugs:
 
     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 - Became report_writer_.

*/
%page;
rw_fr_get_page: proc (

	report_cip_parm,	/* input: points to report_control_info */
	page_number_parm,	/* input: desired page */
	page_ip_parm,	/* output: ptr to page_info */
	code_parm		/* output: success or failure */
		    );
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl page_number_parm fixed bin (21) parm;
dcl page_ip_parm ptr parm;
dcl report_cip_parm ptr parm;
%skip(3);
	report_cip = report_cip_parm;
	code_parm = 0;
	page_ip_parm = null ();
%skip(1);
	/* Move the pointers for the structures we will need. */
%skip(1);
	format_report_ip = report_control_info.format_report_info_ptr;
	iocb_ptr = format_report_info.report_iocb_ptr;
%skip(1);
	/* Get set to read in the page. */
%skip(1);
	record_key = ltrim (convert (record_key, page_number_parm));
	call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm);
	if code_parm ^= 0
	then return;
%skip(1);
	/* It has it's own segment for it's exclusive use. */
%skip(1);
	buffer_ptr = report_control_info.report_temp_seg_ptr;
	buffer_length = sys_info$max_seg_size * 4;
	call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length,
	     record_length, code_parm);
	if code_parm ^= 0
	then return;
%skip(1);
	/* Get set to read in the page_info structure for the page. */
%skip(1);
	record_key = record_key || ".page_info";
	call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm);
	if code_parm ^= 0
	then return;
%skip(1);
	/* It will temporarily go into a report temp segment. */
%skip(1);
	buffer_ptr = report_control_info.input_string_temp_seg_ptr;
	call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length,
	     record_length, code_parm);
	if code_parm ^= 0
	then return;
%skip(1);
/*
	Set the automatic pointer the structure is based on and set
	the pointer to where the page is stored. Adjust the buffer
	pointer and length so the next structure can share the same segment.
*/
%skip(1);
	page_ip = buffer_ptr;
	page_info.page_ptr = report_control_info.report_temp_seg_ptr;
	buffer_word_displacement = divide (record_length, 4, 21) + 1;
	if mod (buffer_word_displacement, 2) ^= 0
	then buffer_word_displacement = buffer_word_displacement + 1;
	buffer_ptr = addrel (buffer_ptr, buffer_word_displacement);
	buffer_length = buffer_length - (buffer_word_displacement * 4);
%skip(1);
	/* Get set to read in the formatted_page_info structure. */
%skip(1);
	record_key = before (record_key, ".") || ".formatted_page_info";
	call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm);
	if code_parm ^= 0
	then return;
%skip(1);
	/* Set the pointer for the structure and re-adjust buffer length. */
%skip(1);
	call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length,
	     record_length, code_parm);
	if code_parm ^= 0
	then return;
	page_info.formatted_page_info_ptr = buffer_ptr;
	buffer_length = sys_info$max_seg_size * 4;
%skip(1);
/*
	If the page contains overstruck characters then read in that
	structure. Set the pointer to the structure.
*/
%skip(1);
	if page_info.page_overstrike_info_ptr ^= null ()
	then do;
	     buffer_ptr = report_control_info.output_string_temp_seg_ptr;
	     record_key = before (record_key, ".") || ".page_overstrike_info";
	     call iox_$seek_key (iocb_ptr, record_key, record_length, code_parm);
	     if code_parm ^= 0
	     then return;
	     call iox_$read_record (iocb_ptr, buffer_ptr, buffer_length,
		record_length, code_parm);
	     if code_parm ^= 0
	     then return;
	     page_info.page_overstrike_info_ptr = buffer_ptr;
	end;
%skip(1);
	page_ip_parm = page_ip;
%skip(1);
	return;
%page;
dcl addrel builtin;
%skip(1);
dcl before builtin;
dcl buffer_length fixed bin (21);
dcl buffer_ptr ptr;
dcl buffer_word_displacement fixed bin (21);
%skip(1);
dcl convert builtin;
%skip(1);
dcl divide builtin;
%skip(1);
dcl iocb_ptr ptr;
dcl iox_$seek_key entry (ptr, char(256) var, fixed bin(21), fixed bin(35));
dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
%skip(1);
dcl ltrim builtin;
%skip(1);
dcl mod builtin;
%skip(1);
dcl null builtin;
%skip(1);
dcl record_key char (256) varying;
dcl record_length fixed bin (21);
%skip(1);
dcl sys_info$max_seg_size fixed bin(35) ext static;
%page;
%include rw_options_extents;
%page;
%include rw_page_info;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%skip(3);
     end rw_fr_get_page;




		    rw_fr_new_report.pl1            11/16/84  1356.0rew 11/16/84  1354.4      689139



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module is called by the report_writer_ display request to set
     up the environment for a new report. Description and usage follows.

     Description:

     This module calls rw_options to get the values of the formatting
     options. It then uses the set of defined options to allocate all of
     the structures needed by rw_fr_build_page. The number of structures,
     their extents, etc. are all dictated by the definition of the format
     options. These structures which result from the translation provide
     a complete execution environment for rw_fr_build_page.

     Usage:

     Both parameters are passed to this program by it's caller, rw_display.
     It is called every time a new report is desired.
 
     Known Bugs:
 
     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_fr_new_report: proc (

	report_cip_parm,	/* input: points to report_control_info */
	code_parm		/* output: success or failure */
		      );
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl report_cip_parm ptr parm;
%skip(3);
/*
     Mainline Processing Overview.

     (1) Perform initialization.

     (2) Go through the process of getting format options from rw_options
         and allocating/filling in the execution structures based on what the
         options are defined as.  The order is roughly setting up the input
         columns, the output columns, the page information, the subtotals and
         subcounts, the totals and counts, the report info, the
         headers/footers info, and the status info.  Everything specific to
         one of these areas sometimes can't all be done in the specific
         subroutine because there are some things that are order dependent.

*/
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
	call housekeeping;
	call setup_input_column_info;
	call setup_output_column_info;
	call setup_page_info;
	call setup_subtotals_info;
	call setup_subcounts_info;
	call setup_totals_info;
	call setup_counts_info;
	call setup_report_info;
	call setup_header_info;
	call setup_status_info;
%skip(1);
	report_control_info.format_report_info_ptr = format_report_ip;
%skip(1);
	return;
%page;
get_option_value: proc (

	gov_option_name_parm,	/* input: name of option */
	gov_option_identifier_parm,	/* input: column identifier */
	gov_option_value_parm	/* output: option value */
		   );
%skip(1);
dcl gov_code fixed bin (35);
dcl gov_option_identifier_parm char (*) varying parm;
dcl gov_option_name_parm char (*) varying parm;
dcl gov_option_value_parm char (*) varying parm;
%skip(3);
          call rw_options$get (report_cip, gov_option_name_parm, 
	     gov_option_identifier_parm, normalized_option_name, 
	     gov_option_value_parm, gov_code);
%skip(1);
	if gov_code ^= 0
	then call ssu_$abort_line (sci_ptr, gov_code);
%skip(1);
          return;
%skip(1);
     end get_option_value;
%page;
housekeeping: proc;
%skip(3);
/*
     Make sure the table information is up to date. Set the pointers to
     our needed temp segments and areas. Allocate/initialize the
     format_report_info structure.
*/
%skip(1);
          sci_ptr = report_control_info.subsystem_control_info_ptr;
%skip(1);
	table_ip = report_control_info.table_information_ptr;
	if table_ip = null
	then call ssu_$abort_line (sci_ptr, rw_error_$no_columns_defined);
	number_of_defined_columns = table_info.column_count;
	maximum_segment_size = sys_info$max_seg_size * 4;
%skip(1);
	work_area_ptr = report_control_info.report_work_area_ptr;
	temp_seg_ptr = report_control_info.report_temp_seg_ptr;
	editing_strings_tsp 
	     = report_control_info.editing_strings_temp_seg_ptr;
	editing_strings_next_byte = 1;
	headers_tsp = report_control_info.headers_temp_seg_ptr;
	headers_next_byte = 1;
%skip(1);
	allocate format_report_info in (work_area) set (format_report_ip);
	unspec (format_report_info) = OFF;
	format_report_info.table_info_ptr = table_ip;
	format_report_info.report_iocb_ptr = null;
	format_report_info.report_directory_name = "";
	format_report_info.report_entry_name = "";
%skip(1);
          code = 0;
%skip(1);
          return;
%skip(1);
     end housekeeping;
%page;
map_column_list: proc (

	mcl_type_of_map_parm,	/* input: two different types of map */
	mcl_option_value_parm,	/* input: the list of columns */
	mcl_no_of_columns_found_parm	/* output: how many were in the list */
		  );
%skip(1);
dcl mcl_character_string_length fixed bin;
dcl mcl_column_number fixed bin;
dcl mcl_column_position fixed bin;
dcl mcl_current_position fixed bin;
dcl mcl_next_blank fixed bin;
dcl mcl_no_of_columns_found fixed bin;
dcl mcl_no_of_columns_found_parm fixed bin parm;
dcl mcl_option_value_parm char (*) varying parm;
dcl mcl_still_processing_columns bit (1) aligned;
dcl mcl_type_of_map_parm bit (1) aligned parm;
%skip(3);
/*
     Parse the column list and fill in the column_map structure based on what
     we find.  Set the output parm to reflect how many columns we've found.
     The column map has been normalized by rw_options to change all column
     numbers to names, place a single blank between each, and trim all leading
     and trailing whitespace.  We supply two types of maps.  The parameter
     mcl_type_of_map_parm when set to OUTPUT_MAP results in us preserving the
     order in which we find them.  If it is set to INPUT_MAP the order of the
     selection expression is preserved.  For example, if the user selected a,
     b, c, d, e, f, g, h and the list contained "e c" the map would look like:

	OUTPUT_MAP 1 2 3 4 5 6 7 8
	           1 1 0 0 0 0 0 0 PRESENT
                     5 3 0 0 0 0 0 0 POSITION

	 INPUT_MAP 1 2 3 4 5 6 7 8
	           0 0 1 0 1 0 0 0 PRESENT
                     0 0 3 0 5 0 0 0 POSITION
*/
%skip(1);
          unspec (column_map) = OFF;
	mcl_option_value_parm = mcl_option_value_parm || BLANK;
	mcl_current_position = 1;
	mcl_character_string_length = length (mcl_option_value_parm);
	mcl_column_position = 1;
	mcl_no_of_columns_found = 0;
	mcl_still_processing_columns = ON;
%page;
	do while (mcl_still_processing_columns);
	     mcl_next_blank = index (substr (mcl_option_value_parm, mcl_current_position), BLANK);
	     mcl_column_number = lookup_column_number ();
	     if mcl_type_of_map_parm = OUTPUT_MAP
	     then do;
		column_map.present (mcl_column_position) = ON;
		column_map.position (mcl_column_position) = mcl_column_number;
		mcl_column_position = mcl_column_position + 1;
	     end;
	     else do;
		column_map.present (mcl_column_number) = ON;
		column_map.position (mcl_column_number) = mcl_column_number;
	     end;
	     mcl_current_position = mcl_current_position + mcl_next_blank;
	     mcl_no_of_columns_found = mcl_no_of_columns_found + 1;
	     if mcl_current_position > mcl_character_string_length
	     then mcl_still_processing_columns = OFF;
	end;
%skip(1);
	mcl_no_of_columns_found_parm = mcl_no_of_columns_found;
%skip(1);
          return;
%page;
lookup_column_number: proc () returns (fixed bin);
%skip(1);
dcl lcn_loop fixed bin;
%skip(1);
          lcn_column_name = substr (mcl_option_value_parm, 
	     mcl_current_position, mcl_next_blank - 1);
%skip(1);
	do lcn_loop = 1 to number_of_defined_columns;
	     if lcn_column_name = table_info.columns.column_name (lcn_loop)
	     then return (lcn_loop);
	end;
%skip(1);
          call ssu_$abort_line (sci_ptr, rw_error_$bad_option_value,
	     "^/Invalid column list ""^a"".", mcl_option_value_parm);
%skip(1);
	return (0);
%skip(1);
     end lookup_column_number;
%skip(1);
     end map_column_list;
%page;
set_grouping_info: proc (

	sgi_option_name_parm,	     /* input: name of group option */
	sgi_grouping_is_defined_flag_parm, /* output: on if group is defined */
	sgi_group_info_ptr_parm	     /* output: ptr to group_info structure if above is on */
		    );
%skip(1);
dcl 1 sgi_group_info like group_info based (sgi_group_info_ptr);
dcl sgi_group_info_ptr ptr;
dcl sgi_group_info_ptr_parm ptr parm;
dcl sgi_grouping_is_defined_flag_parm bit (1) parm;
dcl sgi_loop fixed bin;
dcl sgi_option_name_parm char (*) varying parm;
%skip(3);
/*

     Get the option value associated with the named option.  Set the flag to
     reflect whether or not it's defined.  Allocate/fill in the group_info
     structure if it's defined.

*/
%skip(1);
	sgi_group_info_ptr_parm = null ();
	call get_option_value (sgi_option_name_parm, "", option_value);
	if option_value = ""
	then do;
	     sgi_grouping_is_defined_flag_parm = OFF;
	     return;
	end;
%skip(1);
	sgi_grouping_is_defined_flag_parm = ON;
	call map_column_list (OUTPUT_MAP, option_value, gi_init_number_of_columns_to_group);
	allocate sgi_group_info in (work_area) set (sgi_group_info_ptr);
%skip(1);
	do sgi_loop = 1 to gi_init_number_of_columns_to_group;
	     sgi_group_info.column_number (sgi_loop) = column_map.position (sgi_loop);
	end;
	sgi_group_info_ptr_parm = sgi_group_info_ptr;
%skip(1);
	return;
%skip(1);
     end set_grouping_info;
%page;
set_ioa_string_for_total_or_subtotal: proc (

	sisfs_descriptor_ptr_parm,	/* input: ptr to the descriptor */
	sisfs_ioa_string_parm	/* output: the proper ioa_ string to edit it through */
			    );
%skip(1);
dcl sisfs_char_10 char (10) based;
dcl sisfs_descriptor_ptr_parm ptr parm;
dcl sisfs_ioa_string_parm char (*) varying parm;
dcl sisfs_scale fixed bin;
%skip(3);
/*
     If the scale is greater than zero then set the ioa_ string to reflect
     the number of digits (i.e. fixed dec (5,2) would be "^.2f"). If scale
     is zero then set the ioa_ string to "^f" for float numbers and "^d" for
     all others.
*/
%skip(1);
	arg_descriptor_ptr = sisfs_descriptor_ptr_parm;
	sisfs_scale = fixed_arg_descriptor.scale;
	if sisfs_scale > 0
	then sisfs_ioa_string_parm = "^." || ltrim (convert (sisfs_char_10, sisfs_scale)) || "f";
	else if arg_descriptor.type = 3 | arg_descriptor.type = 4 | arg_descriptor.type = 7
	     | arg_descriptor.type = 8 | arg_descriptor.type = 10 | arg_descriptor.type = 12
	     | arg_descriptor.type = 42 | arg_descriptor.type = 44 | arg_descriptor.type = 46
	     then sisfs_ioa_string_parm = "^f";
	     else sisfs_ioa_string_parm = "^d";
%skip(1);
	return;
%skip(1);
     end set_ioa_string_for_total_or_subtotal;
%page;
setup_counts_info: proc;
%skip(3);
/*
     Get the value for the count option and get the subroutine to figure out
     if it's defined and allocate/initialize the structure if it is. Set it's
     pointer in format_report_info.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_COUNT), "", option_value);
	call setup_totals_or_counts_info (ROW_COUNT, option_value,
	     format_report_info.flags.count_is_defined, count_ip);
	if format_report_info.flags.count_is_defined
	then format_report_info.count_info_ptr = count_ip;
	else format_report_info.count_info_ptr = null ();
%skip(1);
	return;
%skip(1);
     end setup_counts_info;
%page;
setup_header_info: proc;
%skip(1);
dcl shi_additional_indent fixed bin;
dcl shi_alignment_modes (3) fixed bin;
dcl shi_delimiter char (1);
dcl shi_inner_loop fixed bin;
dcl shi_loop fixed bin;
dcl shi_current_header_part fixed bin;
dcl shi_current_inner_position fixed bin;
dcl shi_current_position fixed bin;
dcl shi_header_info_ptr ptr;
dcl shi_header_length fixed bin;
dcl shi_header_part_length fixed bin;
dcl shi_n_parts_width (3) fixed bin;
dcl shi_next_newline_position fixed bin;
dcl shi_number_of_lines_found fixed bin;
dcl shi_number_of_parts_found fixed bin;
dcl shi_second_delimiter_position fixed bin;
dcl shi_starting_position fixed bin;
dcl shi_still_counting bit (1) aligned;
dcl shi_still_parsing bit (1) aligned;
%skip(3);
/*
     Get the header portion delimiter. Init maximum number of portions to three
     and set the widths for 1, 2, and 3 part headers. Make left, center
     and right portions alignment accordingly. Get the subroutine to figure out
     which headers/footers are defined and allocate/fill in the structures.
     Group headers and footers need grouping info set for them. The parsed
     versions of the character strings the headers/footers were set to are 
     placed contiguosly in a temp segment, and the rest of the temp seg is used
     during the evaluation of each (in rw_fr_build_page).
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME (
	     INDEX_FOR_DELIMITER), "", option_value);
	if option_value ^= ""
	then format_report_info.header_part_delimiter = substr (option_value, 1, 1);
	else format_report_info.header_part_delimiter = BLANK;
	shi_delimiter = format_report_info.header_part_delimiter;
	hi_init_maximum_number_of_parts = 3;
	shi_n_parts_width (1) = page_info.width - 1;
	shi_n_parts_width (2) = divide (shi_n_parts_width (1), 2, 17);
	shi_n_parts_width (3) = divide (shi_n_parts_width (1), 3, 17);
	shi_alignment_modes (1) = LEFT_ALIGNMENT;
	shi_alignment_modes (2) = CENTER_ALIGNMENT;
	shi_alignment_modes (3) = RIGHT_ALIGNMENT;
%page;
	call define_header (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_HEADER_VALUE),
	     format_report_info.flags.page_header_is_defined, 
	     format_report_info.page_header_info_ptr);
%skip(1);
	call define_header (OPTIONS.GENERAL_REPORT.NAME (INDEX_FOR_PAGE_FOOTER_VALUE),
	     format_report_info.flags.page_footer_is_defined,
	     format_report_info.page_footer_info_ptr);
%skip(1);
	call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_ROW_HEADER_VALUE),
	     format_report_info.flags.row_header_is_defined,
	     format_report_info.row_header_info_ptr);
%skip(1);
	call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_ROW_FOOTER_VALUE),
	     format_report_info.flags.row_footer_is_defined,
	     format_report_info.row_footer_info_ptr);
%skip(1);
	call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_HEADER_VALUE),
	     format_report_info.flags.group_header_is_defined,
	     format_report_info.group_header_info_ptr);
%skip(1);
	call define_header (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_FOOTER_VALUE),
	     format_report_info.flags.group_footer_is_defined,
	     format_report_info.group_footer_info_ptr);
%skip(1);
	call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_HEADER_TRIGGER),
	     format_report_info.flags.group_header_trigger_is_defined,
	     format_report_info.group_header_trigger_info_ptr);
%skip(1);
	call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP_FOOTER_TRIGGER),
	     format_report_info.flags.group_footer_trigger_is_defined,
	     format_report_info.group_footer_trigger_info_ptr);
%skip(1);
	format_report_info.headers_next_available_byte = headers_next_byte;
%skip(1);
	return;
%page;
define_header: proc (

	dh_header_option_name_parm,	  /* input: name of header/footer option */
	dh_header_is_defined_flag_parm, /* output: on if header is defined */
	dh_header_info_ptr_parm	  /* output: points to header_info structure */
		);
%skip(1);
dcl dh_header_option_name_parm char (*) varying parm;
dcl dh_header_is_defined_flag_parm bit (1) parm;
dcl dh_header_info_ptr_parm ptr parm;
%skip(3);
/*
     Parse the header and set pointer and bit to reflect it's definition.
*/
%skip(1);
	dh_header_info_ptr_parm = null ();
	call get_option_value (dh_header_option_name_parm, "", option_value);
	if option_value = ""
	then do;
	     dh_header_is_defined_flag_parm = OFF;
	     return;
	end;
%skip(1);
	call parse_header (option_value, shi_header_info_ptr);
	dh_header_is_defined_flag_parm = ON;
	dh_header_info_ptr_parm = shi_header_info_ptr;
%skip(1);
	return;
%skip(1);
     end define_header;
%page;
parse_header: proc (

	ph_header_value_parm,    /* input: the header to be parsed */
	ph_header_info_ptr_parm  /* output: ptr to the header info structure */
	         );
%skip(1);
dcl ph_header_info_ptr_parm ptr parm;
dcl ph_header_line_length fixed bin;
dcl ph_header_value_parm char (*) varying parm;
%skip(3);
/*
     Make sure header ends in new line. Allocate header_info structure based on
     how many lines it is. Cleanup header and place it in temp seg. For each
     part within each line fill in the structure and redistribute page space.
     Set the starting position on the page and alignment for each part.
*/
%skip(1);
	ph_header_info_ptr_parm = null ();
	if substr (ph_header_value_parm, length (ph_header_value_parm), 1) ^= NL
	then ph_header_value_parm = ph_header_value_parm || NL;
	call allocate_header_info_structure;
%skip(1);
	shi_current_position = 1;
%skip(1);
	do shi_loop = 1 to shi_number_of_lines_found;
	     call cleanup_and_save_header_line;
	     shi_current_header_part = 1;
	     shi_number_of_parts_found = 0;
	     shi_current_inner_position = 1;
	     shi_still_parsing = ON;
	     do while (shi_still_parsing);
		call set_header_part_info;
	     end;
	     call correct_header_part_anomaly;
	     do shi_inner_loop = 1 to hi_init_maximum_number_of_parts;
		call set_header_part_additional_info;
	     end;
	     headers_next_byte = headers_next_byte + ph_header_line_length;
	end;
%skip(1);
	ph_header_info_ptr_parm = header_ip;
%skip(1);
	return;		
%page;
allocate_header_info_structure: proc;
%skip(3);
/*
     Allocate structure based on number of lines it is made up of.
*/
%skip(1);
	shi_number_of_lines_found = 0;
	shi_current_position = 1;
	shi_header_length = length (ph_header_value_parm);
	shi_still_counting = ON;
%skip(1);
	do while (shi_still_counting);
	     shi_next_newline_position = index (substr (ph_header_value_parm,
		shi_current_position), NL);
	     shi_number_of_lines_found = shi_number_of_lines_found + 1;
	     shi_current_position = shi_current_position + shi_next_newline_position;
	     if shi_current_position > shi_header_length
	     then shi_still_counting = OFF;
	end;
%skip(1);
	hi_init_number_of_lines = shi_number_of_lines_found;
	allocate header_info in (work_area) set (header_ip);
	unspec (header_info.lines) = OFF;
%skip(1);
	return;
%skip(1);
     end allocate_header_info_structure;
%page;
cleanup_and_save_header_line: proc;
%skip(3);
/*
     Left, right, and center portion delimiters are optional. Place any
     missing ones. Save the cleaned up header line.
*/
%skip(1);
	shi_next_newline_position = index (substr (ph_header_value_parm,
	     shi_current_position), NL);
	ph_header_line = substr (ph_header_value_parm,
	     shi_current_position, shi_next_newline_position - 1);
	shi_current_position = shi_current_position + shi_next_newline_position;
%skip(1);
	if length (ph_header_line) = 0
	then ph_header_line = shi_delimiter || shi_delimiter;
	if substr (ph_header_line, 1, 1) ^= shi_delimiter
	then ph_header_line = shi_delimiter || ph_header_line;
	if substr (ph_header_line, length (ph_header_line), 1) ^= shi_delimiter
	then ph_header_line = ph_header_line || shi_delimiter;
%skip(1);
	ph_header_line_length = length (ph_header_line);
	substr (headers_temp_seg, headers_next_byte, ph_header_line_length) = ph_header_line;
%skip(1);
	return;
%skip(1);
     end cleanup_and_save_header_line;
%page;
correct_header_part_anomaly: proc;
%skip(1);
dcl chpa_loop fixed bin;
%skip(1);
/*
     Parts of a header/footer which are zero length have their space
     assigned to the parts whose length is greater than zero. This creates
     an environment where all space on the page is available for use. For
     example, if only the center part of a header has a length greater than
     zero, the text is centered on the page but it has 100% of the page width
     available to use. There are two cases where this action is not desired,
     and this subroutine takes care of these two special cases (listed in the
     table below as the two special cases).

		NORMAL RE-DISTIBUTION ACTION

1.	!!text!!		100%-centered
2.	!text!text!text!	33%-left aligned, 33%-centered, 33%-right aligned
3.	!text!!text!	50%-left aligned, 50%-right aligned
4.	!text!!!		100%-left aligned
5.	!!!text!		100%-right aligned

		SPECIAL CASE - NO RE-DISTRIBUTION ACTION

6.	!text!text!!	33%-left aligned, 33%-centered, 33%-UNUSED
7.	!!text!text!	33%-UNUSED, 33%-centered, 33%-right aligned

	 Special case, #7 above, followed immediately by #6.
*/
%skip(1);
	if (header_info.lines (shi_loop).parts (1).flags.present
	& header_info.lines (shi_loop).parts (1).length = 0)
	& (header_info.lines (shi_loop).parts (2).flags.present
	& header_info.lines (shi_loop).parts (2).length > 0)
	& (header_info.lines (shi_loop).parts (3).flags.present
	& header_info.lines (shi_loop).parts (3).length > 0)
	then return;
	else if (header_info.lines (shi_loop).parts (3).flags.present
	     & header_info.lines (shi_loop).parts (3).length = 0)
	     & (header_info.lines (shi_loop).parts (1).flags.present
	     & header_info.lines (shi_loop).parts (1).length > 0)
	     & (header_info.lines (shi_loop).parts (2).flags.present
	     & header_info.lines (shi_loop).parts (2).length > 0)
	     then return;
	     else;
%skip(1);
	do chpa_loop = 1 to hi_init_maximum_number_of_parts;
	     if header_info.lines (shi_loop).parts (chpa_loop).flags.present
	     then if header_info.lines (shi_loop).parts (chpa_loop).length = 0
		then do;
		     header_info.lines (shi_loop).parts (chpa_loop).flags.present = OFF;
		     shi_number_of_parts_found = shi_number_of_parts_found - 1;
		end;
	          else;
	     else;
	end;
%skip(1);
	return;
%skip(1);
     end correct_header_part_anomaly;
%page;
set_header_part_additional_info: proc;
%skip(3);
/*
     For each part that's present set it's width, starting position on the
     page, and alignment.
*/
%skip(1);
	if header_info.lines (shi_loop).parts (shi_inner_loop).flags.present
	then do;
	     header_info.lines (shi_loop).parts (shi_inner_loop).width
		= shi_n_parts_width (shi_number_of_parts_found);
	     if shi_number_of_parts_found = 1
	     then shi_starting_position = 1;
	     else if shi_number_of_parts_found = 2
		then if shi_inner_loop = 1
		     then shi_starting_position = 1;
	               else shi_starting_position = shi_n_parts_width (2)
			+ mod (shi_n_parts_width (1), 2) + 1;
		else if shi_inner_loop = 1
		     then shi_starting_position = 1;
		     else if shi_inner_loop = 2
			then do;
			     shi_starting_position = shi_n_parts_width (3) + 1;
			     shi_additional_indent = mod (shi_n_parts_width (1), 3);
			     if shi_additional_indent = 2
			     then shi_additional_indent = 1;
			     shi_starting_position = shi_starting_position + shi_additional_indent;
			end;
		          else shi_starting_position = shi_n_parts_width (1) - shi_n_parts_width (3) + 1;
	     header_info.lines (shi_loop).parts (shi_inner_loop).starting_position = shi_starting_position;
	     header_info.lines (shi_loop).parts (shi_inner_loop).alignment
		= shi_alignment_modes (shi_inner_loop);
	end;
%skip(1);
	return;
%skip(1);
     end set_header_part_additional_info;
%page;
set_header_part_info: proc;
%skip(3);
/*
     Find the portion and it's length. Mark it present and whether it
     contains active requests. Set the index and length to it. Check to make
     sure the maximum number of header parts isn't exceeded.
*/
%skip(1);
	shi_second_delimiter_position = index (substr (ph_header_line,
	     shi_current_inner_position + 1), shi_delimiter);
	shi_header_part_length = shi_second_delimiter_position - 1;
	shi_number_of_parts_found = shi_number_of_parts_found + 1;
	header_info.lines (shi_loop).parts (shi_current_header_part).flags.present = ON;
%skip(1);
	if shi_header_part_length ^= 0
	then if search (substr (ph_header_line, 
	     shi_current_inner_position + 1, shi_header_part_length), LEFT_OR_RIGHT_BRACKET) ^= 0
	     then header_info.lines (shi_loop).parts (shi_current_header_part).flags.active = ON;
	     else;
	else;
%skip(1);
	header_info.lines (shi_loop).parts (shi_current_header_part).index
	     = headers_next_byte + shi_current_inner_position;
	header_info.lines (shi_loop).parts (shi_current_header_part).length = shi_header_part_length;
%skip(1);
	shi_current_inner_position = shi_current_inner_position + shi_second_delimiter_position;
	if shi_current_inner_position >= ph_header_line_length
	then shi_still_parsing = OFF;
	else shi_current_header_part = shi_current_header_part + 1;
	if shi_current_header_part > hi_init_maximum_number_of_parts
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
	     "^/A header or footer was found which contained more than ^d parts."
	     || "^/The line in error was ^/^a", hi_init_maximum_number_of_parts, ph_header_line);
%skip(1);
	return;
%skip(1);
     end set_header_part_info;
%skip(1);	
     end parse_header;
%skip(1);
     end setup_header_info;
%page;
setup_input_column_info: proc;
%skip(1);
dcl sici_hit bit (1) aligned;
dcl sici_inner_loop fixed bin;
dcl sici_loop fixed bin;
%skip(3);
/*
     Allocate and init the input_columns_info and input_columns_order structures.
*/
%skip(1);
	initialize_number_of_columns = number_of_defined_columns;
	allocate input_columns_info in (work_area) set (input_columns_ip);
	unspec (input_columns_info.columns) = OFF;
	format_report_info.input_columns_info_ptr = input_columns_ip;
	allocate input_columns_order in (work_area) set (input_columns_op);
	format_report_info.input_columns_order_ptr = input_columns_op;
%skip(1);
/*
     Set the width, alignment, folding, prefix character, editing, title, 
     and data type for each column. Stash the editing string and the title
     in the editing strings temp segment.
*/
%skip(1);
	do sici_loop = 1 to number_of_defined_columns;
	     option_identifier = ltrim (convert (option_identifier, sici_loop));
	     input_columns_info.columns (sici_loop).input_column = sici_loop;
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_WIDTH), option_identifier, option_value);
	     input_columns_info.columns (sici_loop).width = convert (sici_loop, option_value);
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_ALIGNMENT), option_identifier, option_value);
	     call set_alignment_and_decimal_position (sici_loop, option_value);
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_FOLDING), option_identifier, option_value);
	     if option_value = "fill"
	     then input_columns_info.columns (sici_loop).folding_is_fill = ON;
	     else input_columns_info.columns (sici_loop).folding_is_fill = OFF;
	     input_columns_info.columns (sici_loop).prefix_character = "";
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_EDITING), option_identifier, option_value);
	     if option_value = ""
	     then input_columns_info.columns (sici_loop).editing = OFF;
	     else do;
		format_report_info.flags.editing_is_defined = ON;
		input_columns_info.columns (sici_loop).editing = ON;
		input_columns_info.columns (sici_loop).editing_string_length = length (option_value);
		input_columns_info.columns (sici_loop).editing_string_ptr
		     = addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte));
		substr (editing_strings_temp_seg, editing_strings_next_byte, 
		     input_columns_info.columns (sici_loop).editing_string_length) = option_value;
		editing_strings_next_byte = editing_strings_next_byte
		     + input_columns_info.columns (sici_loop).editing_string_length;
	     end;
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_TITLE), option_identifier, option_value);
	     if option_value = ""
	     then option_value = BLANK;
	     input_columns_info.columns (sici_loop).editing_string_result_length = length (option_value);
	     input_columns_info.columns (sici_loop).editing_string_result_ptr
		= addr (editing_strings_temp_seg_as_an_array (editing_strings_next_byte));
	     substr (editing_strings_temp_seg, editing_strings_next_byte, 
		input_columns_info.columns (sici_loop).editing_string_result_length) = option_value;
	     editing_strings_next_byte = editing_strings_next_byte
		+ input_columns_info.columns (sici_loop).editing_string_result_length;
%skip(1);
	     call set_data_type (sici_loop);
	end;
%skip(1);
/*
     Set the next available byte in the editing strings temp seg. Allocate
     the column map structure. Map the column order list and set the
     input_columns_info and input_columns_order structures to reflect the 
     order. Set the grouping info.
*/
%skip(1);
	format_report_info.editing_strings_next_available_byte = editing_strings_next_byte;
	column_map_number_of_columns = number_of_defined_columns;
	allocate column_map in (work_area) set (column_mp);
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_COLUMN_ORDER), "", option_value);
	call map_column_list (OUTPUT_MAP, option_value, no_of_columns_found);
	do sici_loop = 1 to number_of_defined_columns;
	     input_columns_info.columns (sici_loop).order = column_map.position (sici_loop);
	     input_columns_info.columns (sici_loop).input_column = sici_loop;
	     input_columns_order (sici_loop) = column_map.position (sici_loop);
	end;
%skip(1);
	call set_grouping_info (OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP),
	     format_report_info.flags.group_is_defined, format_report_info.group_info_ptr);
	if format_report_info.flags.group_is_defined
	then group_ip = format_report_info.group_info_ptr;
	else group_ip = null ();
%page;
/*
     Allocate/set the page_break_info structure. Any column requested as a
     page break candidate who is a member of the "group" columns has any
     columns more major in the group set also.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_PAGE_BREAK), "", option_value);
	if option_value = ""
	then do;
	     format_report_info.flags.page_break_is_defined = OFF;
	     format_report_info.page_break_info_ptr = null ();
	end;
	else do;
	     format_report_info.flags.page_break_is_defined = ON;
	     call map_column_list (INPUT_MAP, option_value, no_of_columns_found);
	     pbi_init_number_of_columns = input_columns_info.number_of_columns;
	     allocate page_break_info in (work_area) set (page_break_ip);
	     page_break_info.columns (*) = OFF;
	     format_report_info.page_break_info_ptr = page_break_ip;
	     do sici_loop = 1 to input_columns_info.number_of_columns;
		if column_map.present (sici_loop)
		then page_break_info.columns (sici_loop) = ON;
	     end;
	     if format_report_info.flags.group_is_defined
	     then do;
		do sici_loop = 1 to input_columns_info.number_of_columns;
		     sici_hit = OFF;
		     do sici_inner_loop = group_info.number_of_columns_to_group to 1 by -1;
			if group_info.column_number (sici_inner_loop) = sici_loop
			& page_break_info.columns (group_info.column_number (sici_inner_loop))
			then sici_hit = ON;
			if sici_hit
			then page_break_info.columns (group_info.column_number (sici_inner_loop)) = ON;
		     end;
		end;
	     end;
	end;
%page;
/*
     Allocate/set the outline_info structure. The columns named who are a
     member of the "group" of columns are treated separately from the columns
     who are not a member of the group.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_OUTLINE), "", option_value);
	if option_value = ""
	then do;
	     format_report_info.flags.outline_is_defined = OFF;
	     format_report_info.outline_info_ptr = null ();
	end;
	else do;
	     format_report_info.flags.outline_is_defined = ON;
	     call map_column_list (INPUT_MAP, option_value, no_of_columns_found);
	     if format_report_info.flags.group_is_defined
	     then oi_init_maximum_number_of_grouping_columns = group_info.number_of_columns_to_group;
	     else oi_init_maximum_number_of_grouping_columns = 0;
	     oi_init_maximum_number_of_single_columns = input_columns_info.number_of_columns;
	     allocate outline_info in (work_area) set (outline_ip);
	     format_report_info.outline_info_ptr = outline_ip;
	     outline_info.number_of_grouping_columns = 0;
	     if format_report_info.flags.group_is_defined
	     then do sici_loop = 1 to input_columns_info.number_of_columns;
		do sici_inner_loop = group_info.number_of_columns_to_group to 1 by -1;
		     if group_info.column_number (sici_inner_loop) = sici_loop
		     & column_map.present (group_info.column_number (sici_inner_loop))
		     then do;
			outline_info.number_of_grouping_columns
			     = outline_info.number_of_grouping_columns + 1;
			outline_info.grouping_columns (outline_info.number_of_grouping_columns)
			     = group_info.column_number (sici_inner_loop);
			column_map.present (group_info.column_number (sici_inner_loop)) = OFF;
		     end;
		end;
	     end;
	     outline_info.number_of_single_columns = 0;
	     if outline_info.number_of_grouping_columns ^= no_of_columns_found
	     then do sici_loop = 1 to input_columns_info.number_of_columns;
		if column_map.present (sici_loop)
		then do;
		     outline_info.number_of_single_columns = outline_info.number_of_single_columns + 1;
		     outline_info.single_columns (outline_info.number_of_single_columns) = sici_loop;
		end;
	     end;
	end;
%skip(1);
          return;
%skip(1);
     end setup_input_column_info;
%page;
setup_output_column_info: proc;
%skip(1);
dcl soci_inner_loop fixed bin;
dcl soci_loop fixed bin;
%skip(3);
/*
     Find out which columns are excluded from the page.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_EXCLUDE), "", option_value);
	if option_value ^= ""
	then do;
	     format_report_info.flags.exclude_is_defined = ON;
	     call map_column_list (INPUT_MAP, option_value, no_of_columns_found);
	     initialize_number_of_columns = number_of_defined_columns - no_of_columns_found;
	end;
	else do;
	     initialize_number_of_columns = number_of_defined_columns;
	     unspec (column_map) = OFF;
	end;
%skip(1);
/*
     If all columns are excluded fill them in as all present for the case
     where it is a report consisting of totals/subtotals only.
*/
%skip(1);
	if initialize_number_of_columns = 0
	then do;
	     format_report_info.flags.row_value_is_defined = OFF;
	     initialize_number_of_columns = number_of_defined_columns;
	     unspec (column_map) = OFF;
	end;
	else format_report_info.flags.row_value_is_defined = ON;
	allocate output_columns_info in (work_area) set (output_columns_ip);
	format_report_info.output_columns_info_ptr = output_columns_ip;
%page;
/*
     Allocate/set the output_columns_order array. Assign input_columns_info
     for each column that isn't excluded into output_columns_info, and make
     each output_columns_info reflect it's input_columns_info (i.e. if the
     user re-ordered and excluded columns, the output_columns_info structure
     will reflect it.)     
*/
%skip(1);
	output_columns_order_number_of_columns = output_columns_info.number_of_columns;
	allocate output_columns_order in (work_area) set (output_columns_op);
	soci_inner_loop = 1;
%skip(1);
	do soci_loop = 1 to number_of_defined_columns;
	     if ^column_map.present (input_columns_info.columns (soci_loop).order)
	     then do;
		output_columns_order (soci_inner_loop) = input_columns_info.columns (soci_loop).order;
		soci_inner_loop = soci_inner_loop + 1;
	     end;
	end;
%skip(1);
	do soci_loop = 1 to output_columns_info.number_of_columns;
	     output_columns_info.columns (soci_loop)
		= input_columns_info.columns (output_columns_order (soci_loop));
	     input_columns_info.columns (output_columns_order (soci_loop)).output_column = soci_loop;
	end;
%skip(1);
	return;
%skip(1);
     end setup_output_column_info;
%page;
setup_page_info: proc;
%skip(1);
dcl spi_current_detail_line fixed bin;
dcl spi_current_position fixed bin;
dcl spi_exceeds_max_seg_size bit (1) aligned;
dcl spi_last_column_on_detail_line bit (1) aligned;
dcl spi_loop fixed bin;
dcl spi_separator_width fixed bin;
%skip(3);
/*
     Get the page length and width. A page length of zero means the report is
     unpaginated. If page length is zero then set the internal page length
     to a healthy buffer size. Unpaginated reports are buffered into chunks
     that are mostly treated just like a page, because it would be foolish
     to try to do the whole report in one chunk when there may be several
     million rows in the table. Allocate formatted_page_info structure.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_PAGE_WIDTH), "", option_value);
	format_report_info.page_width = convert (spi_loop, option_value);
	if format_report_info.page_width = 0
	then format_report_info.flags.unlimited_page_width = ON;
	else format_report_info.flags.unlimited_page_width = OFF;
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_PAGE_LENGTH), "", option_value);
	format_report_info.page_length = convert (spi_loop, option_value);
	if format_report_info.page_length = 0
	then do;
	     report_control_info.flags.report_is_paginated = OFF;
	     format_report_info.flags.unlimited_page_length = ON;
	     format_report_info.page_length = BUFFER_PAGE_LENGTH;
	end;
	else do;
	     report_control_info.flags.report_is_paginated = ON;
	     format_report_info.flags.unlimited_page_length = OFF;
	end;
	fpi_init_maximum_number_of_detail_blocks = format_report_info.page_length;
	allocate formatted_page_info in (work_area) set (formatted_page_ip);
	format_report_info.formatted_page_info_ptr = formatted_page_ip;
%skip(1);
/*
     Get the definition of the title line. If page width is zero then calculate
     exactly what's needed; if it isn't zero then reduce the width of any
     column who exceeds page width to page width.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_TITLE_LINE), "", option_value);
	if option_value = "on"
	then format_report_info.flags.title_block_is_defined = ON;
	else format_report_info.flags.title_block_is_defined = OFF;
%skip(1);
	if format_report_info.page_width = 0
	then do;
	     spi_current_position = 1;
	     do spi_loop = 1 to output_columns_info.number_of_columns;
		spi_current_position = spi_current_position
		     + output_columns_info.columns (spi_loop).width;
		if spi_loop ^= output_columns_info.number_of_columns
		then do;
		     option_identifier = ltrim (convert (option_identifier, 
			output_columns_info.columns (spi_loop).input_column));
		     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
			(INDEX_FOR_SEPARATOR), option_identifier, option_value);
		     spi_current_position = spi_current_position + length (option_value);
		end;
		else;
	     end;
	     format_report_info.page_width = spi_current_position - 1;
	end;
	else do spi_loop = 1 to output_columns_info.number_of_columns;
	     if output_columns_info.columns (spi_loop).width > format_report_info.page_width
	     then output_columns_info.columns (spi_loop).width = format_report_info.page_width;
	end;
%skip(1);
/*
     Add one to page width to accomodate the newline. If report isn't paginated
     then check to make sure that our chosen page length * page width doesn't
     exceed the maximum segment size. If it does reduce accordingly.
*/
%skip(1);
	format_report_info.page_width = format_report_info.page_width + 1;
	if format_report_info.flags.unlimited_page_length
	then do;
	     spi_exceeds_max_seg_size = ON;
	     do while (spi_exceeds_max_seg_size);
		if format_report_info.page_width * (format_report_info.page_length - 6) ^> maximum_segment_size
		then spi_exceeds_max_seg_size = OFF;
		else do;
		     if format_report_info.page_length < 8
		     then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
			"The page width of ^d causes a single page to exceed the maximum segment size.",
			format_report_info.page_width);

		     format_report_info.page_length = divide (format_report_info.page_length, 2, 17);
		     if format_report_info.page_length < 7
		     then format_report_info.page_length = 7;
		     else;
		end;
	     end;
	end;
%page;
/*
     Allocate/set page_info structure. Make sure a single page doesn't exceed
     a segment for paginated reports. Allocate a second copy of the structure
     so rw_fr_build_page can adjust the length, width, and total_characters
     after formatting each page and then restore the original structure before
     beginning the next page. Allocate page_overstrike_info structure.
*/
%skip(1);
	allocate page_info in (work_area) set (page_ip);
	page_info.width = format_report_info.page_width;
	page_info.length = format_report_info.page_length - 6;
	if page_info.width * page_info.length > maximum_segment_size
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
	     "^/The page width of ^d and the page length of ^d cause a single page to exceed the maximum segment size.",
	     format_report_info.page_width, format_report_info.page_length);
	else;
	page_info.total_characters = page_info.width * page_info.length;
	page_info.page_info_size = size (page_info);
	page_info.page_ptr = report_control_info.report_temp_seg_ptr;
	page_info.formatted_page_info_ptr = format_report_info.formatted_page_info_ptr;
	format_report_info.page_info_ptr = page_ip;
	allocate page_info in (work_area) set (page_ip);
	page_info = format_report_info.page_info_ptr -> page_info;
	format_report_info.copy_of_page_info_ptr = page_ip;
	allocate page_overstrike_info in (work_area) set (page_overstrike_ip);
	format_report_info.overstrike_info_ptr = page_overstrike_ip;
%skip(1);
/*
     Allocate the generic_template (for headers and the like). Base template
     at the beginning of the temp seg and assign it initially the value of
     the generic template.
*/
%skip(1);
	generic_template_length = page_info.width;
	allocate generic_template in (work_area) set (generic_tp);
	generic_template = BLANK;
	substr (generic_template, generic_template_length, 1) = NL;
	format_report_info.generic_template_ptr = generic_tp;
	template_length = generic_template_length;
	template_ptr = temp_seg_ptr;
	template = generic_template;
%page;
/*
     Walk through the output columns. Set the number of detail lines a row
     value will take and do folding of columns which won't fit down to the
     next detail line(s). Create a template for each individual detail line
     and stash it away in the temp seg. Set the starting position on the page
     for each output column, and fill it's separator into the template. The
     last column of each detail line doesn't have a separator.
*/
%skip(1);
	spi_current_detail_line = 1;
	spi_current_position = 1;
%skip(1);
	do spi_loop = 1 to output_columns_info.number_of_columns;
	     option_identifier = ltrim (convert (option_identifier, 
		output_columns_info.columns (spi_loop).input_column));
	     if spi_loop = output_columns_info.number_of_columns
	     then spi_last_column_on_detail_line = ON;
	     else spi_last_column_on_detail_line = OFF;
%skip(1);
	     output_columns_info.columns (spi_loop).starting_position = spi_current_position;
	     output_columns_info.columns (spi_loop).output_line = spi_current_detail_line;
	     spi_current_position = spi_current_position + output_columns_info.columns (spi_loop).width;
%skip(1);
	     call get_option_value (OPTIONS.SPECIFIC_COLUMN.NAME
		(INDEX_FOR_SEPARATOR), option_identifier, option_value);
	     spi_separator_width = length (option_value);
	     if spi_current_position + spi_separator_width > page_info.width
	     then spi_last_column_on_detail_line = ON;
%skip(1);
	     if ^spi_last_column_on_detail_line
	     then if spi_current_position + spi_separator_width
		+ output_columns_info.columns (spi_loop + 1).width > page_info.width
		then spi_last_column_on_detail_line = ON;
%skip(1);
	     if ^spi_last_column_on_detail_line
	     then do;
		substr (template, spi_current_position, spi_separator_width) = option_value;
		spi_current_position = spi_current_position + spi_separator_width;
	     end;
	     else if spi_loop ^= output_columns_info.number_of_columns
		then do;
		     template_ptr = addrel (template_ptr, size (template));
		     template = generic_template;
		     spi_current_detail_line = spi_current_detail_line + 1;
		     spi_current_position = 1;
		end;
		else;
	end;
%page;
/*
     Initialize the number of templates, and allocate/set the 
     row_value_template_info structure. Allocate the template_map
     structure (used to determine which lines on a page have already
     had a template laid down).
*/
%skip(1);
	ti_init_number_of_templates = spi_current_detail_line;
	ti_init_template_width = template_length;
	allocate row_value_template_info in (work_area) set (row_value_template_ip);
	format_report_info.row_value_template_info_ptr = row_value_template_ip;
	template_map_number_of_bits = page_info.length;
	allocate template_map in (work_area) set (template_mp);
	format_report_info.template_map_ptr = template_mp;
	template_ptr = temp_seg_ptr;
	do spi_loop = 1 to spi_current_detail_line;
	     row_value_template_info.templates (spi_loop) = template;
	     template_ptr = addrel (template_ptr, size (template));
	end;
%skip(1);
/*
     If the title line is on then allocate/set the title_block_columns_info
     structure. Null the pointer to the title_block_info structure so that
     rw_fr_build_page will know it is the first time formatting the titles
     (it only formats the title block on page 1 and then places the resulting
     lines on the page for every one after page 1.)
*/
%skip(1);
	if format_report_info.flags.title_block_is_defined
	then do;
	     initialize_number_of_columns = output_columns_info.number_of_columns;
	     allocate title_block_columns_info in (work_area) set (title_block_columns_ip);
	     title_block_columns_info = output_columns_info;
	     format_report_info.title_block_columns_info_ptr = title_block_columns_ip;
	     do spi_loop = 1 to initialize_number_of_columns;
		column_ip = addr (title_block_columns_info.columns (spi_loop));
		column_info.flags.outline = OFF;
		column_info.flags.editing = ON;
		column_info.alignment = CENTER_ALIGNMENT;
	     end;
	     format_report_info.title_block_info_ptr = null ();
	end;
%skip(1);
	return;
%skip(1);
     end setup_page_info;
%page;
setup_report_info: proc;
%skip(3);
/*
     Set the truncation indicator. Allocate/set the format_document_options
     structure.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_TRUNCATION), "", option_value);
	format_report_info.truncation_indicator = option_value;
%skip(1);
	allocate format_document_options in (work_area) set (format_document_options_ptr);
	unspec (format_document_options) = OFF;
	format_document_options.version_number = format_document_version_2;
	format_document_options.switches.galley_sw = ON;
	format_document_options.switches.break_word_sw = ON;
	format_document_options.switches.max_line_length_sw = ON;
	format_document_options.switches.sub_err_sw = ON;
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_FORMAT_DOCUMENT_CONTROLS), "", option_value);
	if option_value = "off"
	then do;
	     format_document_options.switches.literal_sw = ON;
	     format_document_options.switches.dont_compress_sw = ON;
	end;
	call get_option_value (OPTIONS.GENERAL_REPORT.NAME
	     (INDEX_FOR_HYPHENATION), "", option_value);
	if option_value = "on"
	then format_document_options.switches.hyphenation_sw = ON;
	format_document_options.syllable_size = DEFAULT_SYLLABLE_SIZE;
	format_report_info.format_document_op = format_document_options_ptr;
%skip(1);
/*
     If it's a permanent report then setup the file which will contain a
     copy of each formatted page.
*/
%skip(1);
	if report_control_info.flags.permanent_report
	then do;
	     switch_name = unique_chars_ ("0"b) || ".rw_report";
	     format_report_info.report_entry_name = unique_chars_ ("0"b);
	     format_report_info.report_directory_name = report_control_info.temp_dir_name;
	     call iox_$attach_name (switch_name, iocb_ptr,
		"vfile_ " || rtrim (format_report_info.report_directory_name)
		|| ">" || rtrim (format_report_info.report_entry_name), 
		null (), code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to attach file ^a in dir ^a.",
		rtrim (format_report_info.report_directory_name),
		rtrim (format_report_info.report_entry_name));
	     call iox_$open (iocb_ptr, Direct_update, "0"b, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to open file ^a in dir ^a.",
		rtrim (format_report_info.report_directory_name),
		rtrim (format_report_info.report_entry_name));
	     format_report_info.report_iocb_ptr = iocb_ptr;
	end;
%skip(1);
	return;
%skip(1);
     end setup_report_info;
%page;
setup_status_info: proc;
%skip(3);
/*
     Allocate/set the status structure. This is the execution control structure
     that rw_fr_build_page lives and breathes by.
*/
%skip(1);
	allocate status in (work_area) set (status_pointer);
	unspec (status) = OFF;
%skip(1);
	status.number_of_lines_needed_for_detail_block = 0;
	if ^format_report_info.flags.row_header_is_defined
	then status.number_of_lines_needed_for_row_header = 0;
	else do;
	     header_ip = format_report_info.row_header_info_ptr;
	     status.number_of_lines_needed_for_row_header = header_info.number_of_lines;
	     status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block
		+ status.number_of_lines_needed_for_row_header;
	end;
	if format_report_info.flags.row_value_is_defined
	then do;
	     status.number_of_lines_needed_for_row_value = row_value_template_info.number_of_templates;
	     status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block
		+ status.number_of_lines_needed_for_row_value;
	end;
	if ^format_report_info.flags.row_footer_is_defined
	then status.number_of_lines_needed_for_row_footer = 0;
	else do;
	     header_ip = format_report_info.row_footer_info_ptr;
	     status.number_of_lines_needed_for_row_footer = header_info.number_of_lines;
	     status.number_of_lines_needed_for_detail_block = status.number_of_lines_needed_for_detail_block
		+ status.number_of_lines_needed_for_row_footer;
	end;
%skip(1);
	if ^format_report_info.flags.page_footer_is_defined
	then status.number_of_lines_needed_for_page_footer = 0;
	else do;
	     header_ip = format_report_info.page_footer_info_ptr;
	     status.number_of_lines_needed_for_page_footer = header_info.number_of_lines;
	end;
%skip(1);
	if ^format_report_info.flags.group_header_is_defined
	then status.number_of_lines_needed_for_group_header = 0;
	else do;
	     header_ip = format_report_info.group_header_info_ptr;
	     status.number_of_lines_needed_for_group_header = header_info.number_of_lines;
	end;
%page;
	if ^format_report_info.flags.group_footer_is_defined
	then status.number_of_lines_needed_for_group_footer = 0;
	else do;
	     header_ip = format_report_info.group_footer_info_ptr;
	     status.number_of_lines_needed_for_group_footer = header_info.number_of_lines;
	end;
%skip(1);
	status.current_row_ptr = null ();
	status.previous_row_ptr = null ();
	status.next_row_ptr = null ();
	status.last_row_number = 0;
	status.last_page_number = 0;
	status.current_pass_number = 1;
	status.flags.last_pass = ON;
%skip(1);
	format_report_info.status_ptr = status_pointer;
%skip(1);
	return;
%skip(1);
     end setup_status_info;
%page;
setup_subcounts_info: proc;
%skip(3);
/*
     Allocate/set the subcount_info, subcount_generation_info, and
     subcount_columns_info structures if the subcount option is defined.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_SUBCOUNT), "", option_value);
	call setup_subtotals_or_subcounts_info (ROW_SUBCOUNT, option_value,
	     format_report_info.flags.subcount_is_defined, subcount_ip);
	if format_report_info.flags.subcount_is_defined
	then do;
	     format_report_info.subcount_info_ptr = subcount_ip;
	     subcount_generation_ip = subcount_info.subtotal_generation_info_ptr;
	     subcount_columns_ip = subcount_info.columns_info_ptr;
	end;
	else format_report_info.subcount_info_ptr = null ();
%skip(1);
	return;
%skip(1);
     end setup_subcounts_info;
%page;
setup_subtotals_info: proc;
%skip(3);
/*
     Allocate/set the subtotal_info, subtotal_generation_info, and
     subtotal_columns_info structures if the subtotal option is defined.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_SUBTOTAL), "", option_value);
	call setup_subtotals_or_subcounts_info (ROW_SUBTOTAL, option_value,
	     format_report_info.flags.subtotal_is_defined, subtotal_ip);
	if format_report_info.flags.subtotal_is_defined
	then do;
	     format_report_info.subtotal_info_ptr = subtotal_ip;
	     subtotal_generation_ip = subtotal_info.subtotal_generation_info_ptr;
	     subtotal_columns_ip = subtotal_info.columns_info_ptr;
	end;
	else format_report_info.subtotal_info_ptr = null ();
%skip(1);
	return;
%skip(1);
     end setup_subtotals_info;
%page;
setup_subtotals_or_subcounts_info: proc (

	ssosi_subtotal_flag_parm,	/* input: on for subtotals, off for subcounts */
	ssosi_option_value_parm,	/* input: the value for the option */
	ssosi_defined_flag_parm,	/* output: on if it is defined */
	ssosi_subtotal_info_ptr_parm	/* output: points to subtotal_info structure */
				);
%skip(1);
dcl ssosi_comma_position fixed bin;
dcl ssosi_current_position fixed bin;
dcl ssosi_current_inner_position fixed bin;
dcl ssosi_defined_flag_parm bit (1) parm;
dcl ssosi_inner_loop fixed bin;
dcl ssosi_loop fixed bin;
dcl ssosi_next_blank fixed bin;
dcl ssosi_option_value_parm char (*) varying parm;
dcl ssosi_still_counting_subtotals bit (1) aligned;
dcl ssosi_subtotal_flag_parm bit (1) aligned parm;
dcl 1 ssosi_subtotal_columns_info like subtotal_columns_info based (ssosi_subtotal_columns_info_ptr);
dcl ssosi_subtotal_columns_info_ptr ptr;
dcl 1 ssosi_subtotal_generation_info like subtotal_generation_info based (ssosi_subtotal_generation_info_ptr);
dcl ssosi_subtotal_generation_info_ptr ptr;
dcl 1 ssosi_subtotal_info like subtotal_info based (ssosi_subtotal_info_ptr_parm);
dcl ssosi_subtotal_info_ptr_parm ptr parm;
dcl ssosi_subtotal_list_length fixed bin;
%skip(3);
/*
     This subroutine works for subcounts and subtotals. See if it's defined.
*/
%skip(1);
	if ssosi_option_value_parm = ""
	then do;
	     ssosi_defined_flag_parm = OFF;
	     ssosi_subtotal_info_ptr_parm = null ();
	     return;
	end;
%skip(1);
/*
     Great! First let's remove the subtotals/subcounts whose parents are
     excluded from the page and see if we still have any defined.
*/
%skip(1);
	ssosi_defined_flag_parm = ON;
	si_init_number_of_columns_to_subtotal = 0;
	ssosi_still_counting_subtotals = ON;
	ssosi_current_position = 1;
	ssosi_option_value_parm = ssosi_option_value_parm || BLANK;
	call remove_orphan_subtotals;
	if ssosi_option_value_parm = BLANK
	then do;
	     ssosi_defined_flag_parm = OFF;
	     ssosi_subtotal_info_ptr_parm = null ();
	     return;
	end;
	ssosi_subtotal_list_length = length (ssosi_option_value_parm);
%skip(1);
/*
     We have some defined. Let's see how many.
*/
%skip(1);
	do while (ssosi_still_counting_subtotals);
	     ssosi_next_blank = index (substr (ssosi_option_value_parm, ssosi_current_position), BLANK);
	     if ssosi_next_blank ^= 0
	     then si_init_number_of_columns_to_subtotal = si_init_number_of_columns_to_subtotal + 1;
	     else ssosi_still_counting_subtotals = OFF;
	     if ssosi_still_counting_subtotals
	     then ssosi_current_position = ssosi_current_position + ssosi_next_blank;
	     if ssosi_current_position > ssosi_subtotal_list_length
	     then ssosi_still_counting_subtotals = OFF;
	end;
%skip(1);
/*
     Allocate/set the subtotal_info structure.
*/
%skip(1);
	allocate ssosi_subtotal_info in (work_area) set (ssosi_subtotal_info_ptr_parm);
	ssosi_subtotal_info.current_level = 0;
	unspec (ssosi_subtotal_info.columns) = OFF;
	ssosi_subtotal_info.columns (*).subtotal = 0;
%page;
/*
     Allocate the subtotal_generation_info structure. This is a circular
     list used to place the value of each subtotal after it's been generated.
     During formatting when the removal of rows is necessary, the subtotals
     are restored back to their old values from this circular list.
*/
%skip(1);
	sgi_init_number_of_subtotals = si_init_number_of_columns_to_subtotal;
	sgi_init_number_of_generations = divide (page_info.length, 2, 17) + 1;
	allocate ssosi_subtotal_generation_info in (work_area)
	     set (ssosi_subtotal_generation_info_ptr);
	ssosi_subtotal_info.subtotal_generation_info_ptr = ssosi_subtotal_generation_info_ptr;
	ssosi_subtotal_generation_info.current_generation_block = -1;
%skip(1);
/*
     Allocate/set the subtotal_map structure so we can figure out how
     many levels of them we have (several subtotals defined on the same
     column, who are generated when different column's values change.) For
     the subtotal_info structure set the input column and level for each
     column. Set the highest_level in the same structure. For subtotals
     there is a requirement that they must be numbers; this isn't true
     for subcounts. Set the ioa_ string to edit them through. If the "watch"
     column is a member of the group of columns then mark it. Set the
     reset flag accordingly.
*/
%skip(1);
	subtotal_map_init_number_of_columns = input_columns_info.number_of_columns;
	allocate subtotal_map in (work_area) set (subtotal_map_ptr);
	unspec (subtotal_map.columns) = OFF;
	ssosi_current_position = 1;
	ssosi_subtotal_info.highest_level = 0;
%skip(1);
	do ssosi_loop = 1 to si_init_number_of_columns_to_subtotal;
	     ssosi_current_inner_position = 1;
	     ssosi_next_blank = index (substr (ssosi_option_value_parm, ssosi_current_position), BLANK);
	     ssosi_option_value = substr (ssosi_option_value_parm, 
		ssosi_current_position, ssosi_next_blank - 1);
	     ssosi_comma_position = index (ssosi_option_value, COMMA);
	     ssosi_column_name = substr (ssosi_option_value, 1, ssosi_comma_position - 1);
	     ssosi_subtotal_info.columns (ssosi_loop).input_column = get_column_number ();
	     subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).present = ON;
	     subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number
		= subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number + 1;
	     ssosi_subtotal_info.columns (ssosi_loop).level
		= subtotal_map.columns (ssosi_subtotal_info.columns (ssosi_loop).input_column).number;
	     if ssosi_subtotal_info.columns (ssosi_loop).level > ssosi_subtotal_info.highest_level
	     then ssosi_subtotal_info.highest_level = ssosi_subtotal_info.columns (ssosi_loop).level;
	     if ssosi_subtotal_flag_parm
	     then do;
		if input_columns_info.columns (ssosi_subtotal_info.columns
		.input_column (ssosi_loop)).subsystem_data_type = NUMERIC_DATA_TYPE
		| input_columns_info.columns (ssosi_subtotal_info.columns
		.input_column (ssosi_loop)).subsystem_data_type = DECIMAL_DATA_TYPE
		then;
	          else call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
		     "^/A subtotal was specified for the ^a column and it is not numeric.",
		     table_info.columns.column_name (ssosi_subtotal_info.columns.input_column (ssosi_loop)));
		call set_ioa_string_for_total_or_subtotal (
		     addr (table_info.columns (ssosi_subtotal_info.columns.input_column (ssosi_loop)).column_data_type),
		     ssosi_subtotal_info.columns.ioa_string (ssosi_loop));
	     end;
	     else ssosi_subtotal_info.columns.ioa_string (ssosi_loop) = "^d";
	     ssosi_current_inner_position = ssosi_current_inner_position + ssosi_comma_position;
	     ssosi_comma_position = index (substr (ssosi_option_value, ssosi_current_inner_position), COMMA);
	     ssosi_column_name = substr (ssosi_option_value,
		ssosi_current_inner_position, ssosi_comma_position - 1);
	     ssosi_subtotal_info.columns (ssosi_loop).watch_column = get_column_number ();
	     if format_report_info.flags.group_is_defined
	     then do ssosi_inner_loop = 1 to group_info.number_of_columns_to_group;
		if group_info.column_number (ssosi_inner_loop)
		= ssosi_subtotal_info.columns (ssosi_loop).watch_column
		then ssosi_subtotal_info.columns (ssosi_loop).flags.group_column = ON;
	     end;
	     ssosi_subtotal_info.columns (ssosi_loop).flags.reset
		= (substr (ssosi_option_value, ssosi_current_inner_position + ssosi_comma_position) = RESET);
	     ssosi_current_position = ssosi_current_position + ssosi_next_blank;
	end;
%skip(1);
/*
     Allocate/set the subtotal_columns_info structure. Assign the values of
     the output_columns to them, and set the prefix of all to blank. Walk
     through the subtotal_columns_info structure setting the prefix of each
     one that is really a subtotal/subcount to "-", and set the alignment in
     the case of subcounts to right.
*/
%skip(1);
	initialize_number_of_columns = output_columns_info.number_of_columns;
	allocate ssosi_subtotal_columns_info in (work_area) set (ssosi_subtotal_columns_info_ptr);
	ssosi_subtotal_info.columns_info_ptr = ssosi_subtotal_columns_info_ptr;
	ssosi_subtotal_columns_info = output_columns_info;
	ssosi_subtotal_columns_info.columns (*).prefix_character = BLANK;
%skip(1);
	do ssosi_loop = 1 to ssosi_subtotal_info.number_of_columns_to_subtotal;
	     ssosi_subtotal_columns_info.columns (input_columns_info.columns
		(ssosi_subtotal_info.columns (ssosi_loop).input_column).output_column).prefix_character = "-";
	     if ^ssosi_subtotal_flag_parm
	     then ssosi_subtotal_columns_info.columns (input_columns_info.columns
		(ssosi_subtotal_info.columns (ssosi_loop).input_column).output_column).alignment = RIGHT_ALIGNMENT;
	end;
%skip(1);
	return;
%page;
get_column_number: proc () returns (fixed bin);
%skip(1);
dcl gcn_loop fixed bin;
%skip(3);
/*
     Get the column number for the supplied column name. These names have been
     verified in rw_options, so any name that isn't found indicates the
     parsing code in this module messed up somewhere.
*/
%skip(1);
	do gcn_loop = 1 to number_of_defined_columns;
	     if ssosi_column_name = table_info.columns.column_name (gcn_loop)
	     then return (gcn_loop);
	end;
%skip(1);
	if ssosi_subtotal_flag_parm
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
	     "The column name ""^a"" in the subtotal list ""^a"" isn't valid.",
	     ssosi_column_name, ssosi_option_value_parm);
	else call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
	     "The column name ""^a"" in the subcount list ""^a"" isn't valid.",
	     ssosi_column_name, ssosi_option_value_parm);
%skip(1);
	return (0);
%skip(1);
     end get_column_number;
%page;
remove_orphan_subtotals: proc;
%skip(1);
dcl ros_column_number fixed bin;
dcl ros_current_position fixed bin;
dcl ros_next_blank fixed bin;
dcl ros_next_comma fixed bin;
dcl ros_still_eliminating_orphans bit (1) aligned;
dcl ros_subtotal_list_length fixed bin;
%skip(3);
/*
     Walk through the list eliminating any subtotals whose parents have been
     excluded from the page.
*/
%skip(1);
	ssosi_option_value = "";
	ros_subtotal_list_length = length (ssosi_option_value_parm);
	ros_current_position = 1;
	ros_still_eliminating_orphans = ON;
%skip(1);
	do while (ros_still_eliminating_orphans);
	     ros_next_blank = index (substr (ssosi_option_value_parm, 
		ros_current_position), BLANK);
	     ros_next_comma = index (substr (ssosi_option_value_parm,
		ros_current_position), COMMA);
	     ssosi_column_name = substr (ssosi_option_value_parm, 
		ros_current_position, ros_next_comma - 1);
	     ros_column_number = get_column_number ();
	     if input_columns_info.columns (ros_column_number).output_column ^= 0
	     then ssosi_option_value = ssosi_option_value
		|| substr (ssosi_option_value_parm, ros_current_position, ros_next_blank);
	     ros_current_position = ros_current_position + ros_next_blank;
	     if ros_current_position > ros_subtotal_list_length
	     then ros_still_eliminating_orphans = OFF;
	end;
%skip(1);
	ssosi_option_value_parm = ssosi_option_value;
%skip(1);
	return;
%skip(1);
     end remove_orphan_subtotals;
%skip(1);
     end setup_subtotals_or_subcounts_info;
%page;
setup_totals_info: proc;
%skip(3);
/*
     Get the subroutine to figure out if we have any defined.
*/
%skip(1);
	call get_option_value (OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_TOTAL), "", option_value);
	call setup_totals_or_counts_info (ROW_TOTAL, option_value,
	     format_report_info.flags.total_is_defined, total_ip);
	if format_report_info.flags.total_is_defined
	then format_report_info.total_info_ptr = total_ip;
	else format_report_info.total_info_ptr = null ();
%skip(1);
	return;
%skip(1);
     end setup_totals_info;
%page;
setup_totals_or_counts_info: proc (

	stoci_total_flag_parm,    /* input: on for totals, off for counts */
	stoci_option_value_parm,  /* input: the value for the option */
	stoci_defined_flag_parm,  /* output: on if it's defined */
	stoci_total_info_ptr_parm /* output: points to total_info structure */
	);
%skip(1);
dcl stoci_defined_flag_parm bit (1) parm;
dcl stoci_inner_loop fixed bin;
dcl stoci_loop fixed bin;
dcl stoci_option_value_parm char (*) varying parm;
dcl 1 stoci_total_columns_info like total_columns_info based (stoci_total_columns_info_ptr);
dcl stoci_total_columns_info_ptr ptr;
dcl stoci_total_flag_parm bit (1) aligned parm;
dcl 1 stoci_total_info like total_info based (stoci_total_info_ptr_parm);
dcl stoci_total_info_ptr_parm ptr parm;
%skip(3);
/*
     See if we have any defined.
*/
%skip(1);
	if stoci_option_value_parm = ""
	then do;
	     stoci_defined_flag_parm = OFF;
	     stoci_total_info_ptr_parm = null ();
	     return;
	end;
%skip(1);
/*
     Yes we do. Get a map and remove any totals whose parents are excluded
     from the page. Adjust our count accordingly.
*/
%skip(1);
	stoci_defined_flag_parm = ON;
	call map_column_list (INPUT_MAP, stoci_option_value_parm, 
	     ti_init_number_of_columns_to_total);
	do stoci_loop = 1 to number_of_defined_columns;
	     if column_map.present (stoci_loop)
	     then if input_columns_info.columns (stoci_loop).output_column = 0
		then do;
		     column_map.present (stoci_loop) = OFF;
		     ti_init_number_of_columns_to_total = ti_init_number_of_columns_to_total - 1;
		end;
		else;
	     else;
	end;
%skip(1);
/*
     There may not be any defined at this point.
*/
%skip(1);
	if ti_init_number_of_columns_to_total ^> 0
	then do;
	     stoci_defined_flag_parm = OFF;
	     stoci_total_info_ptr_parm = null ();
	     return;
	end;
%skip(1);
/*
     Looks like we still have some left. Allocate the total_info structure 
     and zero all totals.
*/
%skip(1);
	allocate stoci_total_info in (work_area) set (stoci_total_info_ptr_parm);
	stoci_total_info.columns.total (*) = 0;
	stoci_inner_loop = 1;
%skip(1);
/*
     Walk through the column map setting the input column and ioa_ string.
     There is a requirement that totals be defined on columns that are
     numbers; no such requirement for counts.
*/
%skip(1);
	do stoci_loop = 1 to output_columns_info.number_of_columns;
	     if column_map.present (output_columns_info.columns (stoci_loop).input_column)
	     then do;
		stoci_total_info.columns.input_column (stoci_inner_loop)
		     = output_columns_info.columns (stoci_loop).input_column;
		if stoci_total_flag_parm
		then do;
		     if input_columns_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop))
		     .subsystem_data_type = NUMERIC_DATA_TYPE
		     | input_columns_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop))
		     .subsystem_data_type = DECIMAL_DATA_TYPE
		     then;
		     else call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
			"^/A total was specified for the ^a column and it is not numeric.",
			table_info.columns.column_name (stoci_total_info.columns.input_column (stoci_inner_loop)));
		     call set_ioa_string_for_total_or_subtotal (
			addr (table_info.columns (stoci_total_info.columns.input_column (stoci_inner_loop)).column_data_type),
			stoci_total_info.columns.ioa_string (stoci_inner_loop));
		end;
		else stoci_total_info.columns.ioa_string (stoci_inner_loop) = "^d";
		stoci_inner_loop = stoci_inner_loop + 1;
	     end;
	end;
%page;
/*
     Allocate the total_columns_info structure. Assign the output_columns_info
     to total_columns_info. Set outlining on for all and right alignment if we
     are playing with counts rather than totals.
*/
%skip(1);
	initialize_number_of_columns = output_columns_info.number_of_columns;
	allocate stoci_total_columns_info in (work_area) set (stoci_total_columns_info_ptr);
	stoci_total_info.columns_info_ptr = stoci_total_columns_info_ptr;
	stoci_total_columns_info = output_columns_info;
	stoci_total_columns_info.columns (*).flags.outline = ON;
	if ^stoci_total_flag_parm
	then stoci_total_columns_info.columns (*).alignment = RIGHT_ALIGNMENT;
%skip(1);
	return;
%skip(1);
     end setup_totals_or_counts_info;
%page;
set_alignment_and_decimal_position: proc (

	saadp_column_number_parm, /* input: number of column */
	saadp_option_value_parm   /* input: value of option for column */
				 );
%skip(1);
dcl saadp_claimed_digits char (7) varying;
dcl saadp_column_number_parm parm;
dcl saadp_option_value_parm char (*) varying parm;
%skip(3);
/*
     Set the alignment and in the case of decimal, the position within the
     display width where the decimal alignment should take place.
*/
%skip(1);
	if saadp_option_value_parm = "center"
	then input_columns_info.columns (saadp_column_number_parm).alignment 
	     = CENTER_ALIGNMENT;
	else if saadp_option_value_parm = "left"
	     then input_columns_info.columns (saadp_column_number_parm)
	          .alignment = LEFT_ALIGNMENT;
	     else if saadp_option_value_parm = "right"
		then input_columns_info.columns (saadp_column_number_parm)
		     .alignment = RIGHT_ALIGNMENT;
	          else if saadp_option_value_parm = "both"
		     then input_columns_info.columns (saadp_column_number_parm)
		          .alignment = BOTH_ALIGNMENT;
		     else do;
			input_columns_info.columns (saadp_column_number_parm)
			     .alignment = DECIMAL_ALIGNMENT;
			saadp_claimed_digits = after (saadp_option_value_parm, BLANK);
			if verify (saadp_claimed_digits, DIGITS) ^= 0
			then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
			     "^/The decimal alignment position could not be converted to an integer. ""^a""",
			     saadp_option_value_parm);
			input_columns_info.columns (saadp_column_number_parm).decimal_position
			     = convert (saadp_column_number_parm, saadp_claimed_digits);
			if input_columns_info.columns (saadp_column_number_parm).decimal_position
			> input_columns_info.columns (saadp_column_number_parm).width
			then call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
			     "^/The decimal alignment position ^d is larger than the column width ^d for column number ^d.",
			     input_columns_info.columns (saadp_column_number_parm).decimal_position,
			     input_columns_info.columns (saadp_column_number_parm).width,
			     saadp_column_number_parm);
		     end;
%skip(1);
	return;
%skip(1);
     end set_alignment_and_decimal_position;
%page;
set_data_type: proc (sdt_column_number_parm);
%skip(1);
dcl sdt_column_number_parm fixed bin parm;
dcl sdt_column_type fixed bin (6) unsigned unaligned;
%skip(3);
/*
     Simplify all of the possibilities into numeric, decimal, bit or character.
*/
%skip(1);
	arg_descriptor_ptr = addr (table_info.columns.column_data_type (sdt_column_number_parm));
	sdt_column_type = arg_descriptor.type;
%skip(1);
	if (sdt_column_type >= 1 & sdt_column_type <= 8)
	| (sdt_column_type = 33 | sdt_column_type = 34)
	then input_columns_info.columns (sdt_column_number_parm)
	     .subsystem_data_type = NUMERIC_DATA_TYPE;
	else if (sdt_column_type >= 9 & sdt_column_type <= 12)
	     | (sdt_column_type = 29 | sdt_column_type = 30)
	     | (sdt_column_type = 35 | sdt_column_type = 36)
	     | (sdt_column_type >= 38 & sdt_column_type <= 46)
	     then input_columns_info.columns (sdt_column_number_parm)
	          .subsystem_data_type = DECIMAL_DATA_TYPE;
	     else if (sdt_column_type = 19 | sdt_column_type = 20)
		then input_columns_info.columns (sdt_column_number_parm)
		     .subsystem_data_type = BIT_DATA_TYPE;
	          else if (sdt_column_type = 21 | sdt_column_type = 22)
		     then input_columns_info.columns (sdt_column_number_parm)
		          .subsystem_data_type = CHAR_DATA_TYPE;
		     else call ssu_$abort_line (sci_ptr, rw_error_$bad_report_setup,
			"^/The table information described an unsupported data type.^/The data type was ^d.", 
			sdt_column_type);
%skip(1);
	return;
%skip(1);
     end set_data_type;
%page;
dcl BLANK char (1) static int options (constant) init (" ");
dcl BUFFER_PAGE_LENGTH fixed bin int static options (constant) init (264);
dcl COMMA char (1) static int options (constant) init (",");
dcl DEFAULT_SYLLABLE_SIZE fixed bin static int options (constant) init (2);
dcl DIGITS char (10) static int options (constant) init ("0123456789");
dcl INPUT_MAP bit (1) aligned static int options (constant) init ("1"b);
dcl LEFT_OR_RIGHT_BRACKET char (2) internal static options (constant) init ("[]");
dcl NL char (1) internal static options (constant) init ("
");
dcl OFF bit (1) aligned internal static options (constant) init ("0"b);
dcl ON bit (1) aligned internal static options (constant) init ("1"b);
dcl OUTPUT_MAP bit (1) aligned static int options (constant) init ("0"b);
dcl RESET char (5) static int options (constant) init ("reset");
dcl ROW_COUNT bit (1) aligned static int options (constant) init ("0"b);
dcl ROW_SUBCOUNT bit (1) aligned static int options (constant) init ("0"b);
dcl ROW_SUBTOTAL bit (1) aligned static int options (constant) init ("1"b);
dcl ROW_TOTAL bit (1) aligned static int options (constant) init ("1"b);
%page;
dcl addr builtin;
dcl addrel builtin;
dcl after builtin;
%skip(1);
dcl code fixed bin (35);
dcl convert builtin;
%skip(1);
dcl divide builtin;
%skip(1);
%skip(1);
dcl iocb_ptr ptr;
dcl index builtin;
dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
%skip(1);
dcl lcn_column_name char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl length builtin;
dcl ltrim builtin;
%skip(1);
dcl mod builtin;
%skip(1);
dcl no_of_columns_found fixed bin;
dcl normalized_option_name char (97) varying;
dcl null builtin;
dcl number_of_defined_columns fixed bin;
%skip(1);
dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl output_columns_order (output_columns_order_number_of_columns) fixed bin based (output_columns_op);
dcl output_columns_order_number_of_columns fixed bin;
dcl output_columns_op ptr;
%skip(1);
dcl ph_header_line char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl rtrim builtin;
dcl rw_error_$bad_option_value fixed bin(35) ext static;
dcl rw_error_$bad_report_setup fixed bin(35) ext static;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl rw_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35));
%skip(1);
dcl sci_ptr ptr;
dcl search builtin;
dcl size builtin;
dcl ssosi_column_name char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl ssosi_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl ssu_$abort_line entry() options(variable);
dcl 1 subtotal_map aligned based (subtotal_map_ptr),
      2 number_of_columns fixed bin,
      2 columns (subtotal_map_init_number_of_columns refer (subtotal_map.number_of_columns)),
        3 present bit (1),
        3 number fixed bin;
dcl substr builtin;
dcl subtotal_map_init_number_of_columns fixed bin;
dcl subtotal_map_ptr ptr;
dcl switch_name char (32);
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl temp_seg_ptr ptr;
%skip(1);
dcl unique_chars_ entry (bit(*)) returns(char(15));
dcl unspec builtin;
%skip(1);
dcl verify builtin;
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include format_document_options;
%page;
%include iox_modes;
%page;
%include rw_format_options;
%page;
%include rw_names_and_values;
%page;
%include rw_options_extents;
%page;
%include rw_page_info;
%page;
%include rw_report_info;
%page;
%include rw_report_structures;
%page;
%include rw_table_info;
%skip(3);
     end rw_fr_new_report;




		    rw_list_format_options.pl1      11/16/84  1356.0rew 11/16/84  1354.4      139257



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
%skip(3);
/*   The main level procedure called to implement the
     report_writer_ list_format_options request. Description and usage follows.

     This request does either 1, 2 or 3 listed below.
     
     1) Lists the ACTIVE option names and values.

     2) Lists ALL the option names and values.

     3) Lists USER SPECIFIED option names and values.
     
     Usage (1): "list_format_options" or "list_format_options -active"

     Only the active option names and values are listed.

     Usage (2): list_format_options -all

     All of the formatting option names and values are listed.

     Usage (3): list_format_options -format_option_args
        or      [list_format_options -format_option_args]

     Where -format_option_args are the same ones taken by the 
     set_format_options_request except no values are supplied.
     When used as an active request only one format option can
     be specified.

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_list_format_options: proc (

	sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
	report_cip_parm /* input: points to report_control_info */
		         );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
/*
          Mainline Processing Overview.

          (1) Determine requested usage.

          (2) (a) For usage 1 and 2 get the active or all the option
                   names and values.

              (b) For usage 3 as a request, get the option value, list it, 
                  continue until all user provided option names are exhausted, 
                  then return. For usage 3 as an active request do the same
                  except only one format option is specified.
	     
          (3) List the names and values.
*/
%page;
%skip(3);
	call initialize;
%skip(1);
          if usage_1
	then call rw_options$get_active (report_cip,
	     names_and_values_info_ptr, no_of_names_and_values,
	     names_and_values_ptr, size_of_names_and_values, code);
	else if usage_2
	     then call rw_options$get_all (report_cip,
		names_and_values_info_ptr, no_of_names_and_values,
		names_and_values_ptr, size_of_names_and_values, code);
	     else do;
		call get_and_list_user_specified_option_values;
		return;
	     end;
%skip(1);
	if code ^= 0 
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
          call list_the_values;
%skip(1);
          return;
%page;
get_and_list_option_name: proc;
%skip(3);
	call rw_options$get (report_cip, long_option_name, 
	     option_identifier, normalized_option_name, 
	     option_value, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
	if active_request_flag
	then do;
	     if ^identifier_needed
	     then number_of_legal_args = 1;
	     else number_of_legal_args = 2;
	     if number_of_args_supplied > number_of_legal_args
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		INVALID_ACTIVE_REQUEST_MESSAGE);
	     else;
	     return_value = requote_string_ ((option_value));
	     return;
	end;
	else;
%skip(1);
	if index (option_value, NEWLINE) = 0
	then do;
	     padded_option_name = normalized_option_name;
	     call ioa_ ("^a", padded_option_name || QUOTE
		|| option_value || QUOTE);
	end;
	else call ioa_ ("^a^x^a^/^a^a^x^a", 
	     normalized_option_name, "beginning",
	     option_value, normalized_option_name, "end");
%skip(1);
	return;
%skip(1);
     end get_and_list_option_name;
%page;
get_and_list_star_name: proc;
%skip(3);
	/* Get and list the names and values for the columns named
	   by the starname. */
%skip(1);
	if active_request_flag
	then call ssu_$abort_line (sci_ptr, error_table_$nostars,
	     "^/When used as an active request starnames are not allowed.");
%skip(1);
	option_name_table.the_name (1) = long_option_name;
	option_name_table.the_identifier (1) = option_identifier;
%skip(1);
	call rw_options$get_named (report_cip, 
	     option_name_table_ptr, no_of_options_in_name_table,
	     names_and_values_info_ptr, no_of_names_and_values,
	     names_and_values_ptr, size_of_names_and_values, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
	call list_the_values;
%skip(1);
	return;
%skip(1);
     end get_and_list_star_name;
%page;
get_and_list_user_specified_option_values: proc;
%skip(3);
/*
	Walk through the loop once for each format option. Pick up the
          format option name and have it expanded into a long name, and
          determine if it needs a column identifier. If it does need a
          column identifier then pick it up. Get the option value associated
          with the format option. If called as an active request then set the
          return value and return. If called as a regular request then list
          the value and repeat the loop as long as there are more options.
*/
%skip(1);
          names_and_values_area_ptr = report_control_info.name_value_area_ptr;
	no_of_options_in_name_table = 1;
	allocate option_name_table in (names_and_values_area)
	     set (option_name_table_ptr);
%skip(1);
          option_identifier = "";
	current_arg_number = 1;
%skip(1);
	call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length);
	current_arg_number = current_arg_number + 1;
          still_processing_args = ON;
%skip(1);
          do while (still_processing_args);
%skip(1);
	     option_name = arg;
               call rw_options$check_name (report_cip, option_name, 
		long_option_name, identifier_needed, code);
	     if code ^= 0
	     then if code = rw_error_$no_columns_defined
		then call ssu_$abort_line (sci_ptr, code,
		     "^/There must be columns defined before the value of ^a can be listed.", 
		     long_option_name);
	          else if code = rw_error_$bad_option_name
		     then call ssu_$abort_line (sci_ptr, code,
		          "^/^a is not a valid option name.", option_name);
		     else call ssu_$abort_line (sci_ptr, code);
	     else;
%skip(1);
	     this_is_a_star_name = OFF;
	     if identifier_needed
	     then do;
		if current_arg_number > number_of_args_supplied
	          then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "The option ^a was not followed by a column identifier.",
		     long_option_name);
		else;
		call ssu_$arg_ptr (sci_ptr, current_arg_number, 
		     arg_ptr, arg_length);
		current_arg_number = current_arg_number + 1;
		option_identifier = arg;
		call rw_options$check_identifier (report_cip,
		     long_option_name, option_identifier,
		     normalized_option_name, code);
		if code ^= 0
		then if code = rw_error_$bad_option_identifier
		     then call ssu_$abort_line (sci_ptr, code,
		          "^/^a is not a valid column identifier for ^a.",
		          option_identifier, long_option_name);
		     else if code = error_table_$nostars
			then this_is_a_star_name = ON;
		          else call ssu_$abort_line (sci_ptr, code);
		else;
	     end;
	     else;
%skip(1);
	     if this_is_a_star_name
	     then call get_and_list_star_name;
	     else call get_and_list_option_name;
%skip(1);
	     if active_request_flag
	     then return;
%skip(1);
	     if current_arg_number > number_of_args_supplied
	     then still_processing_args = OFF;
	     else do;
		call ssu_$arg_ptr (sci_ptr, current_arg_number,
		     arg_ptr, arg_length);
		current_arg_number = current_arg_number + 1;
	     end;
%skip(1);
	end;
%skip(1);
	return;
%skip(1);
     end get_and_list_user_specified_option_values;
%page;
initialize: proc;
%skip(3);
/*

	If zero args then usage_1 is requested.  If there are any args
	supplied then walk through them all once setting the usage_1 and
	usage_2 flags as -active and -all are found.  If -active and -all
	are not found then usage_3 has been requested, or an incorrectly
	spelled control arg has been given.  If -active or -all are found
	then there can't be any format_option_args supplied.

*/
%skip(1);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
          usage_1 = OFF;
	usage_2 = OFF;
	usage_3 = OFF;
%skip(1);
          /* Find the longest column name for the current columns. */
%skip(1);
	table_ip = report_control_info.table_information_ptr;
	if table_ip = null
	then the_longest_option_name 
	     = LONGEST_GENERAL_REPORT_OPTION_NAME_LENGTH + 5;
	else do;
	     if LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH
	     > LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH
	     then the_longest_option_name 
		= LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH;
	     else the_longest_option_name
		= LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH;
	     the_longest_option_name = the_longest_option_name
		+ table_info.maximum_column_name_length + 5;
	end;
	padded_option_name_ptr = addr (chunk_of_automatic_storage);
%skip(1);
	call ssu_$return_arg (sci_ptr, number_of_args_supplied,
	     active_request_flag, return_value_ptr, return_value_length);
%page;
	if number_of_args_supplied = 0
	then do;
	     usage_1 = ON;
	     if active_request_flag
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		INVALID_ACTIVE_REQUEST_MESSAGE);
	     else;
	end;
	else do;
	     number_of_control_args_found = 0;
	     do loop = 1 to number_of_args_supplied;
		call ssu_$arg_ptr (sci_ptr, loop, arg_ptr, arg_length);
		if arg = "-active" | arg = "-act"
		then do;
		     number_of_control_args_found 
			= number_of_control_args_found + 1;
		     usage_1 = ON;
		     usage_2 = OFF;
		end;
		else if arg = "-all" | arg = "-a"
		     then do;
			number_of_control_args_found 
			     = number_of_control_args_found + 1;
			usage_2 = ON;
			usage_1 = OFF;
		     end;
		     else;
	     end;
	     if usage_1 | usage_2
	     then if active_request_flag
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, 
		     INVALID_ACTIVE_REQUEST_MESSAGE);
	          else if number_of_control_args_found ^= number_of_args_supplied
		     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		          "^/When used, ^[-all^;-active^] must be the only argument given.",
		          fixed (usage_1 || usage_2));
		     else;
	     else;
	end;
%skip(1);
	if ^usage_1 & ^usage_2
	then usage_3 = ON;
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
list_the_values: proc;
%skip(3);
/*
	Walk through the loop once for each format option value. The
          user may have requested that the active options were to be
          listed, and the result of this may be zero option values to list.
*/
%skip(1);
          if no_of_names_and_values = 0
	then do;
	     call ioa_ ("^a^/^a",
		"All of the formatting options are set to their default values.",
		"There are no column options defined.");
	     return;
	end;
%skip(1);
          do loop = 1 to no_of_names_and_values;
%skip(1);
	     option_value = substr (names_and_values, 
		name_value_info.value.index (loop), 
		name_value_info.value.length (loop));
%skip(1);
	     if index (option_value, NEWLINE) = 0
	     then do;
		padded_option_name = substr (names_and_values,
		name_value_info.name.index (loop), 
		name_value_info.name.length (loop));
	          call ioa_ ("^a", padded_option_name || QUOTE
		     || option_value || QUOTE);
	     end;
	     else call ioa_ ("^a^x^a^/^a^a^x^a", 
		substr (names_and_values, 
		name_value_info.name.index (loop), 
		name_value_info.name.length (loop)), 
		"beginning", option_value, 
		substr (names_and_values, 
		name_value_info.name.index (loop), 
		name_value_info.name.length (loop)), "end");
%skip(1);
	end;
%skip(1);
          return;
%skip(1);          
     end list_the_values;
%page;
dcl INVALID_ACTIVE_REQUEST_MESSAGE char (79) static int options (constant) init (
"^/When used as an active request only one format option value can be requested.");
dcl NEWLINE char (1) static int options (constant) init ("
");
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
dcl QUOTE char (1) static int options (constant) init ("""");
%skip(1);
dcl active_request_flag bit (1) aligned;
dcl addr builtin;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl chunk_of_automatic_storage char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH);
dcl code fixed bin (35);
dcl current_arg_number fixed bin;
%skip(1);
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$nostars fixed bin(35) ext static;
%skip(1);
dcl fixed builtin;
%skip(1);
dcl identifier_needed bit (1) aligned;
dcl index builtin;
dcl ioa_ entry() options(variable);
%skip(1);
dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl loop fixed bin;
%skip(1);
dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr);
dcl names_and_values_area_ptr ptr;
dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
dcl null builtin;
dcl number_of_args_supplied fixed bin;
dcl number_of_control_args_found fixed bin;
dcl number_of_legal_args fixed bin;
%skip(1);
dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl padded_option_name char (the_longest_option_name) based (padded_option_name_ptr);
dcl padded_option_name_ptr ptr;
%skip(1);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl return_value char (return_value_length) varying based (return_value_ptr);
dcl return_value_length fixed bin (21);
dcl return_value_ptr ptr;
dcl rw_error_$bad_option_identifier fixed bin(35) ext static;
dcl rw_error_$bad_option_name fixed bin(35) ext static;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl rw_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35));
dcl rw_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35));
dcl rw_options$get entry (ptr, char(*) var, char(*) var, char(*) var, char(*) var, fixed bin(35));
dcl rw_options$get_active entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
dcl rw_options$get_all entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
dcl rw_options$get_named entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), ptr, fixed bin(21),	fixed bin(35));
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21));
dcl still_processing_args bit (1) aligned;
dcl substr builtin;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl the_longest_option_name fixed bin;
dcl this_is_a_star_name bit (1) aligned;
%skip(1);
dcl usage_1 bit (1) aligned;
dcl usage_2 bit (1) aligned;
dcl usage_3 bit (1) aligned;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include rw_names_and_values;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_table_info;
%skip(3);
     end rw_list_format_options;




		    rw_options.pl1                  10/03/86  1241.9rew 10/02/86  1512.2      870912



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


/****^  HISTORY COMMENTS:
  1) change(86-08-18,JSLove), approve(86-08-18,MCR7518),
     audit(86-08-21,Parisek), install(86-10-02,MR12.0-1175):
     Changed to call match_star_name_ instead of rw_match_star_name.
     Rw_match_star_name was deleted when the new match_star_name_ was
     installed.
                                                   END HISTORY COMMENTS */


/* format: off */
%skip(1);
rw_options: proc;
%skip(1);
/*
     
     This module provides an interface to the options used in formatting
     reports. The following external entry points in order of appearance
     are available:

     check_identifier

     Called to check a column/option identifier.  Translates an option name
     and option identifier into a character string consisting of the option
     name and real option identifier (i.e.  translates 1 into the name of
     column 1.) Can also be used to determine if the column name is a star
     name.

     check_name
     
     Called to check an option name, expand the short option name into a
     long name, and determine if it needs a column/option identifier.

     define_new_column_options

     Called when the user has selected a new set of columns or done something
     that has resulted in no columns being defined.

     get
     
     Called to get the value of a formatting option.

     get_active
     
     Called to get the names and values of the active formatting
     options.

     get_all
     
     Called to get the names and values of all of the formatting
     options.

     get_named
     
     Called to get the names and values of a set of formatting options.  The
     options are named by the caller, but the names of columns can be names,
     star names or numbers.  The names returned by this module are actual
     column names instead of numbers or star names.

     set_and_check
     
     Called to set a formatting option to a provided value.  The option
     name and value are checked for validity.

     set_all_to_system_defaults
     
     Called to set all of the formatting options to their default
     values.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 - Became report_writer_.

*/
%page;
%skip(3);
/* These parameters are described at each entry where they are used. */
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl identifier_needed_parm bit (1) aligned parm;
dcl long_option_name_parm char (*) varying parm;
dcl names_and_values_info_ptr_parm ptr parm;
dcl names_and_values_ptr_parm ptr parm;
dcl no_of_names_and_values_parm fixed bin (21) parm;
dcl no_of_options_in_name_table_parm fixed bin (21) parm;
dcl normalized_option_name_parm char (*) varying parm;
dcl option_identifier_parm char (*) varying parm;
dcl option_name_parm char (*) varying parm;
dcl option_name_table_ptr_parm ptr parm;
dcl option_value_parm char (*) varying parm;
dcl report_cip_parm ptr parm;
dcl size_of_names_and_values_parm fixed bin (21) parm;
dcl system_default_parm bit (1) aligned parm;
%skip(5);
	return;
%page;
check_identifier: entry (
%skip(1);
          report_cip_parm,             /* input: points to report_control_info */
	option_name_parm,            /* input: option name to look up */
	option_identifier_parm,      /* input: option identifier to look up */
          normalized_option_name_parm, /* output: the option name and identifier */
	code_parm		         /* output: success or failure */
	     );
%skip(1);
/*

     This entry is called to translate an option name and identifier into
     a character string that contains the option name and real option
     identifier. That is, an option identifier can be a number or the name
     of a column. The returned option identifier is always the name of the
     column. The option_name_parm should be the expanded version, as this
     entry shouldn't be called until the check_name entry was called. This
     entry does not support star names, but is useful for determining if
     the identifier is a star name.

*/
%skip(1);
          me = "rw_options$check_identifier";
	report_cip = report_cip_parm;
	option_name = option_name_parm;
	option_identifier = option_identifier_parm;
	normalized_option_name_parm = "";
	code_parm = 0;
%skip(1);
	call housekeeping;
%skip(1);
	call normalize_option_name (option_name, option_identifier, 
	     option_type, option_table_index, normalized_option_name, code);
	code_parm = code;
	normalized_option_name_parm = normalized_option_name;
%skip(1);
          return;
%page;
check_name: entry (
%skip(1);
          report_cip_parm,        /* input: points to report_control_info */
          option_name_parm,       /* input: option name to determine type of */
          long_option_name_parm,  /* output: long version of above name */
          identifier_needed_parm, /* output: ON means identifier needed */
          code_parm               /* output: success or failure */
		  );
%skip(1);
/*

     This entry point is called to check an option name and determine the
     type of option the caller is dealing with.  There are two types of
     options.  Ones like "-page_size" (general report or general column
     options) which do not require anything else to identify them.  For these
     types "0"b is returned to describe their type.  Others like "-width"
     (specific column options) require a column number or name to identify
     which they apply to.  For these types "1"b is returned.  The short or
     long name provided is used to find the long name of the option and this
     long name is returned.

*/
%skip(1);
	me = "rw_options$check_name";
          report_cip = report_cip_parm;
	option_name = option_name_parm;
	long_option_name_parm = "";
	identifier_needed_parm = OFF;
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
	call expand_short_option_name (option_name, long_option_name, code);
	if code ^= 0
	then do;
	     code_parm = code;
	     return;
	end;
	else long_option_name_parm = long_option_name;
%skip(1);
          call lookup_option_number (long_option_name,
	     option_type, option_table_index);
	if option_type = SPECIFIC_COLUMN_OPTION
	then identifier_needed_parm = ON;
	else;
%page;
	if ^valid_select
	then if (option_type = GENERAL_COLUMN_OPTION
	     | option_type = SPECIFIC_COLUMN_OPTION)
	     then code_parm = rw_error_$no_columns_defined;
	     else;
	else;
%skip(1);
          return;
%page;
define_new_column_options: entry (
%skip(1);
	report_cip_parm    /* input: points to report_control_info */
	);
/*

     This entrypoint is called when the user has selected a new set of
     columns or the user has done something that results in no columns
     being defined. It makes sure:

     1) That the options which refer to columns are up to date.  This means
     deleting the old column options and loading the value seg with the new
     column default options if the user has defined new columns since the last
     time this entry was called, or deleting the old column options if the
     user has unsuccessfully tried to define columns since the last time
     this entry was called.

*/
	call housekeeping;
%skip(1);
/* 

     If we are out of date, or, there are no columns defined
     but the column options are still around, then delete the column
     options.  Then if there are valid column definitions available,
     load the new column default values.

*/
%skip(1);
	if ^valid_select
	then do;
	     call value_$get (value_seg_ptr, PERMANENT,
		OPTIONS.GENERAL_COLUMN.NAME (1), returned_option_value, code);
	     if code = 0
	     then call delete_column_options;
	     else if code ^= error_table_$oldnamerr
		then call ssu_$abort_line (sci_ptr, code,
		     "While trying to get the value of ^a for ^a.",
		     OPTIONS.GENERAL_COLUMN.NAME (1), me);
	          else;
	end;
%skip(1);
          if valid_select
	then call load_value_seg_with_column_defaults;
%skip(1);
	return;
%page;
get:	entry (
%skip(1);
          report_cip_parm,             /* input: points to report_control_info */
          option_name_parm,            /* input: option name to get value for */
	option_identifier_parm,      /* input: option identifier for name */
	normalized_option_name_parm, /* output: the option name and identifier */
          option_value_parm,           /* output: option value defined for name */
          code_parm                    /* output: success or failure */
	     );
%skip(1);
/*

     This entry point is called by subroutines and requests. It
     attempts to get the option value associated with the caller provided
     option name. For option names that require an identifier, the option
     name concatenated with a blank and the real option identifier is also
     returned. That is, column names rather than numbers are always returned.

*/
%skip(1);	
          me = "rw_options$get";
%skip(1);
	report_cip = report_cip_parm;
	option_name = option_name_parm;
	option_identifier = option_identifier_parm;
%skip(1);
	normalized_option_name_parm = "";
	option_value_parm = "";
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
	call normalize_option_name (option_name,
	     option_identifier, option_type, option_table_index, 
	     normalized_option_name, code);
	if code ^= 0
	then do;
	     code_parm = code;
	     return;
	end;

%skip(1);
	call value_$get (value_seg_ptr, PERMANENT,
	     normalized_option_name, option_value, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to get the value for ^a.", 
	     normalized_option_name);
%skip(1);
	normalized_option_name_parm = normalized_option_name;
	option_value_parm = option_value;
%skip(1);
          return;
%page;
get_active: entry (
%skip(1);
          report_cip_parm,                /* input: points to report_control_info */
          names_and_values_info_ptr_parm, /* output: ptr to names and values info */
          no_of_names_and_values_parm,    /* output: no of name-value pairs */
          names_and_values_ptr_parm,      /* output: ptr to the names and values */
          size_of_names_and_values_parm,  /* output: length of names_and_values char string */
          code_parm                       /* output: success or failure */
	      );
%skip(1);
/*

     This entrypoint is called by the report writer list_format_options and
     save_format_options requests to get all the active formatting option
     names and values.  They are returned as a character string, along
     with a structure which describes the character string.

*/
%skip(1);
          me = "rw_options$get_active";
	report_cip = report_cip_parm;
	names_and_values_info_ptr_parm = null ();
	no_of_names_and_values_parm = 0;
	names_and_values_ptr_parm = null ();
	size_of_names_and_values_parm = 0;
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
          call get_all_names_and_values;
	call extract_active_from_all;
%skip(1);
	names_and_values_info_ptr_parm = like_names_and_values_info_ptr;
          no_of_names_and_values_parm = no_of_active_names_and_values;
	names_and_values_ptr_parm = names_and_values_ptr;
	size_of_names_and_values_parm = size_of_names_and_values;
%skip(1);
          return;
%page;
get_all: entry (
%skip(1);
          report_cip_parm,                /* input: points to report_control_info */
          names_and_values_info_ptr_parm, /* output: ptr to names and values info */
          no_of_names_and_values_parm,    /* output: no of name-value pairs */
          names_and_values_ptr_parm,      /* output: ptr to the names and values */
          size_of_names_and_values_parm,  /* output: length of names_and_values char string */
          code_parm                       /* output: success or failure */
	      );
%skip(1);
/*

     This entrypoint is called by the report writer list_format_options and
     save_format_options requests to get all of the formatting option names
     and values.  They are returned as a character string, along with a
     structure which describes the character string.

*/
%skip(1);
          me = "rw_options$get_all";
	report_cip = report_cip_parm;
	names_and_values_info_ptr_parm = null ();
	no_of_names_and_values_parm = 0;
	names_and_values_ptr_parm = null ();
	size_of_names_and_values_parm = 0;
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
          call get_all_names_and_values;
%skip(1);
	names_and_values_info_ptr_parm = names_and_values_info_ptr;
	no_of_names_and_values_parm = no_of_names_and_values;
	names_and_values_ptr_parm = names_and_values_ptr;
	size_of_names_and_values_parm = size_of_names_and_values;
%skip(1);
          return;
%page;
get_named: entry (
%skip(1);
          report_cip_parm,                  /* input: points to report_control_info */
          option_name_table_ptr_parm,       /* input: an array of option names and identifiers */
          no_of_options_in_name_table_parm, /* input: no of option names */
          names_and_values_info_ptr_parm,   /* output: ptr to names and values info */
          no_of_names_and_values_parm,      /* output: no of name value pairs */
          names_and_values_ptr_parm,        /* output: ptr to the names and values */
          size_of_names_and_values_parm,    /* output: length of names_and_values char string */
          code_parm                         /* output: success or failure */
	      );
%skip(1);
/*

     This entrypoint is called by the report writer save_format_options and
     list_format_options requests.  It takes an array of names as input and
     creates a character string containing all of the names and values, along
     with a structure which describes the character string.

*/
%skip(1);
          me = "rw_options$get_named";
	report_cip = report_cip_parm;
	option_name_table_ptr = option_name_table_ptr_parm;
	no_of_options_in_name_table = no_of_options_in_name_table_parm;
	names_and_values_info_ptr_parm = null();
	no_of_names_and_values_parm = 0;
	names_and_values_ptr_parm = null ();
	size_of_names_and_values_parm = 0;
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
          call get_named_values (code);
          if code ^= 0
	then code_parm = code;
	else do;
	     names_and_values_info_ptr_parm = names_and_values_info_ptr;
	     no_of_names_and_values_parm = no_of_names_and_values;
	     names_and_values_ptr_parm = names_and_values_ptr;
	     size_of_names_and_values_parm = size_of_names_and_values;
	end;
%skip(1);
          return;
%page;
set_and_check: entry (
%skip(1);
          report_cip_parm,        /* input: points to report_control_info */
          option_name_parm,       /* input: option name to set value for */
	option_identifier_parm, /* input: option identifier for name */
          option_value_parm,      /* input: option value to set */
          system_default_parm,    /* input: on = set value to system default */
          code_parm               /* output: success or failure */
		);
%skip(1);
/*

     This entry point is called by the set_format_options request to set a user
     specified option name to either a user provided option value or the system
     provided default.  It first makes sure that the option name is valid.  The
     caller should have first called the check_name entry of this
     suboutine and had the option name expanded and checked at that time.  If
     the user has requested that it be set to the system default value, it sets
     it from system tables.  Otherwise it determines if the value is legitimate
     for the particular option.  It is then set if the value is correct.

*/
%skip(1);
          me = "rw_options$set_and_check";
	report_cip = report_cip_parm;
	option_name = option_name_parm;
	option_identifier = option_identifier_parm;
	option_value = option_value_parm;
	system_default = system_default_parm;
	code_parm = 0;
%skip(1);
          call housekeeping;
%skip(1);
     	call set_the_values (option_name, option_identifier,
	     option_value, system_default, code);
	code_parm = code;
%skip(1);
          return;
%page;
set_all_to_system_defaults: entry (
%skip(1);
          report_cip_parm,  /* input: points to report_control_info */
          code_parm	        /* output: success or failure */
			   );
%skip(1);
/*

     This entrypoint is called by the set_format_options request to set all
     of the formatting options to the system provided defaults.  It first
     sets the general report options. It then sets the general and specific
     column options if a valid statement is available. If there are old
     column options hanging around they are deleted before the set operation.

*/
%skip(1);
          me = "rw_options$set_all_to_system_defaults";
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
          call housekeeping;
          call load_value_seg_with_report_defaults;
%skip(1);
	if ^valid_select
	then return;
%skip(1);
          call value_$get (value_seg_ptr, PERMANENT,
	     OPTIONS.GENERAL_COLUMN.NAME (1), returned_option_value, code);
	if code = 0
	then call delete_column_options;
	else if code ^= error_table_$oldnamerr
	     then call ssu_$abort_line (sci_ptr, code,
	          "While trying to get the value of ^a for ^a.",
	          OPTIONS.GENERAL_COLUMN.NAME (1), me);
	     else;
%skip(1);
	call load_value_seg_with_column_defaults;
%skip(1);
	return;
%page;
delete_column_options: proc;
%skip(3);
/*

     This proc is called to delete the column option names and values so that
     leftover column options from another select don't get confused with the
     current column options. If it runs into trouble the line is aborted 
     here because reporting can't possibly continue.

*/
%skip(1);
dcl dco_inner_loop fixed bin;
dcl dco_loop fixed bin;
%skip(1);
          alloc_name_count = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE
	     + NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;	     
	alloc_max_name_len = max (LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH,
	     LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH)
	     + length (BLANK) + length (STAR_DOT_STAR_STAR);
	allocate match_info in (names_and_values_area)
	     set (match_info_ptr);
	match_info.version = match_info_version_1;
%skip(1);
	do dco_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
	     match_info.name_array.exclude_sw (dco_loop) = OFF;
	     match_info.name_array.regexp_sw (dco_loop) = OFF;
	     match_info.name_array.name (dco_loop) 
		= OPTIONS.GENERAL_COLUMN.NAME (dco_loop);
%skip(1);
	end;
%skip(1);
          dco_inner_loop = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE + 1;
%skip(1);
	do dco_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
	     match_info.name_array.exclude_sw (dco_inner_loop) = OFF;
	     match_info.name_array.regexp_sw (dco_inner_loop) = OFF;
	     match_info.name_array.name (dco_inner_loop) = 
		OPTIONS.SPECIFIC_COLUMN.NAME (dco_loop) 
		|| BLANK || STAR_DOT_STAR_STAR;
	     dco_inner_loop = dco_inner_loop + 1;
%skip(1);
	end;
%page;
          call value_$list (value_seg_ptr, PERMANENT, match_info_ptr,
	     names_and_values_area_ptr, value_list_info_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^a", "While trying to get the option names for the columns.");
%skip(1);
          do dco_loop = 1 to value_list_info.pair_count;
%skip(1);
	     call value_$delete (value_seg_ptr, PERMANENT,
		substr (value_list_info.chars, 
		value_list_info.pairs.name_index (dco_loop), 
		value_list_info.pairs.name_len (dco_loop)), code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to delete the value of ^a.", 
		substr (value_list_info.chars, 
		value_list_info.pairs.name_index (dco_loop), 
		value_list_info.pairs.name_len (dco_loop)));
%skip(1);
	end;
%skip(1);
	report_control_info.options_identifier = 
	     report_control_info.options_identifier + 1;
%skip(1);
          return;
%skip(1);
     end delete_column_options;
%page;
expand_short_option_name: proc (

	eson_option_name_parm,       /* input: option name to expand */
	eson_long_option_name_parm,  /* output: long version of option name */
	eson_code_parm	         /* output: success or failure */
			 );
%skip(3);
/*

     When this proc is called it expects eson_option_name_parm to contain the
     short or long option name.  It sets eson_long_option_name_parm based on
     the value of eson_option_name_parm.  If the name isn't valid it sets
     eson_code_parm to reflect this.  It first does a binary table search on
     the short_names table and if it's unsucessful it does the same to the
     long_names table.

*/
%skip(1);
dcl eson_code_parm fixed bin (35) parm;
dcl eson_long_option_name_parm char (*) varying parm;
dcl eson_option_name_parm char (*) varying parm;
dcl eson_table_index fixed bin;
%skip(3);
	eson_long_option_name_parm = "";
	eson_code_parm = 0;
%skip(1);
	eson_table_index = lookup_name_from_table (eson_option_name_parm,
	     OPTION_NAMES_AS_ARGS.SHORT_NAME);
	if eson_table_index ^= 0
	then do;
	     eson_long_option_name_parm = OPTION_NAMES_AS_ARGS.
		LONG_NAME_IN_SHORT_NAME_ORDER (eson_table_index);
	     return;
	end;
%skip(1);
	eson_table_index = lookup_name_from_table (eson_option_name_parm,
	     OPTION_NAMES_AS_ARGS.LONG_NAME);
	if eson_table_index ^= 0
	then eson_long_option_name_parm = eson_option_name_parm;
	else eson_code_parm = rw_error_$bad_option_name;
%skip(1);
	return;
%page;
lookup_name_from_table: proc (

	lnft_name_parm, /* input: name to look up */
	lnft_table_parm /* output: table to do lookup from */
		         ) returns (fixed bin);
%skip(3);
dcl lnft_loop1 fixed bin;
dcl lnft_loop2 fixed bin;
dcl lnft_loop3 fixed bin;
dcl lnft_name_parm char (*) varying parm;
dcl lnft_table_parm (*) char (*) varying parm;
%skip(1);
          lnft_loop1 = 1;
	lnft_loop2 = hbound (lnft_table_parm, 1);
%skip(1);
	do while (lnft_loop1 <= lnft_loop2);
%skip(1);
	     lnft_loop3 = divide (lnft_loop1 + lnft_loop2, 2, 17);
	     if lnft_name_parm = lnft_table_parm (lnft_loop3)
	     then return (lnft_loop3);
%skip(1);
	     if lnft_name_parm < lnft_table_parm (lnft_loop3)
	     then lnft_loop2 = lnft_loop3 - 1;
	     else lnft_loop1 = lnft_loop3 + 1;
%skip(1);
	end;
%skip(1);
	return (0);
%skip(1);
     end lookup_name_from_table;
%skip(3);
     end expand_short_option_name;
%page;
extract_active_from_all: proc;
%skip(3);
/*

     This proc is called by the entry get_active to extract the names and
     values from the value list structures that are considered active.  It
     expects that get_all_names_and_values has just been called, and moves the
     index and length of each name and value considered active, into a
     structure returned to the caller of the get_active entrypoint.

*/
%skip(1);
dcl eafa_inner_loop fixed bin;
dcl eafa_loop fixed bin;
%skip(3);
	no_of_names_and_values_in_bit_map = no_of_names_and_values;
	no_of_active_names_and_values = no_of_names_and_values;
%skip(1);
	allocate names_and_values_bit_map in (names_and_values_area)
	     set (names_and_values_bit_map_ptr);
	unspec (names_and_values_bit_map) = OFF;
%skip(1);
          do eafa_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
%skip(1);
	     if report_control_info.format_options_flags.
		general_report_default_value (eafa_loop)
	     then do;
		names_and_values_bit_map (eafa_loop) = ON;
		no_of_active_names_and_values = 
		     no_of_active_names_and_values - 1;
	     end;
%skip(1);
	end;
%page;
          if valid_select
	then do;
	     eafa_inner_loop = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE + 1;
	     do eafa_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
		if report_control_info.format_options_flags
		     .general_column_default_value (eafa_loop)
		then do;
		     names_and_values_bit_map (eafa_inner_loop) = ON;
		     no_of_active_names_and_values =
			no_of_active_names_and_values - 1;
		end;
		eafa_inner_loop = eafa_inner_loop + 1;
	     end;
	end;
%skip(1);
	allocate like_name_value_info in (names_and_values_area) 
	     set (like_names_and_values_info_ptr);
%skip(1);
          eafa_inner_loop = 1;
%skip(1);
          do eafa_loop = 1 to no_of_names_and_values_in_bit_map;
               if names_and_values_bit_map (eafa_loop) = OFF
	     then do;
		like_name_value_info.name.index (eafa_inner_loop) =
		     name_value_info.name.index (eafa_loop);
		like_name_value_info.name.length (eafa_inner_loop) =
		     name_value_info.name.length (eafa_loop);
                    like_name_value_info.value.index (eafa_inner_loop) =
		     name_value_info.value.index (eafa_loop);
		like_name_value_info.value.length (eafa_inner_loop) =
		     name_value_info.value.length (eafa_loop);
		eafa_inner_loop = eafa_inner_loop + 1;
	     end;
	end;
%skip(1);
          return;
%skip(1);
     end extract_active_from_all;
%page;
get_all_names_and_values: proc;
%skip(3);
/*
          
     This proc is called to obtain all of the names and values.  It first gets
     the general report options.  Then, if there are column options defined,
     the general column options are gotten, followed by the specific column
     options.

*/
%skip(1);
dcl ganav_inner_loop fixed bin;
dcl ganav_loop fixed bin;
dcl ganav_loop_limit fixed bin;
dcl ganav_no_of_chars_already_done fixed bin (21);
%skip(3);
	/* Get the names and values for the general report options. */
%skip(1);
	alloc_name_count = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
	alloc_max_name_len = LONGEST_GENERAL_REPORT_OPTION_NAME_LENGTH;
	allocate match_info in (names_and_values_area) set (match_info_ptr);
	match_info.version = match_info_version_1;
%skip(1);
          do ganav_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
%skip(1);
	     match_info.name_array.exclude_sw (ganav_loop) = OFF;
	     match_info.name_array.regexp_sw (ganav_loop) = OFF;
	     match_info.name_array.name (ganav_loop) 
		= OPTIONS.GENERAL_REPORT.NAME (ganav_loop);
%skip(1);
	end;
%skip(1);
          call value_$list (value_seg_ptr, PERMANENT, match_info_ptr,
	     names_and_values_area_ptr, value_list_info_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^/While trying to get the report option names and values.");
%skip(1);
	general_report_names_and_values_info_ptr = value_list_info_ptr;
%page;
	/* Get the names and values for the general and specific column options. */
%skip(1);
          if valid_select
	then do;
%skip(1);
	     alloc_name_count = NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
	     alloc_max_name_len = LONGEST_GENERAL_COLUMN_OPTION_NAME_LENGTH;
	     allocate match_info in (names_and_values_area) 
		set (match_info_ptr);
	     match_info.version = match_info_version_1;
%skip(1);
	     do ganav_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
		match_info.name_array.exclude_sw (ganav_loop) = OFF;
		match_info.name_array.regexp_sw (ganav_loop) = OFF;
		match_info.name_array.name (ganav_loop)
		     = OPTIONS.GENERAL_COLUMN.NAME (ganav_loop);
%skip(1);
	     end;
%skip(1);
               call value_$list (value_seg_ptr, PERMANENT, match_info_ptr,
		names_and_values_area_ptr, value_list_info_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"^/While trying to get the general column option names and values.");
%skip(1);
	     general_columns_names_and_values_info_ptr = value_list_info_ptr;
%skip(1);
	     alloc_name_count = NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;
	     alloc_max_name_len = LONGEST_SPECIFIC_COLUMN_OPTION_NAME_LENGTH
		+ length (BLANK) + length (STAR_DOT_STAR_STAR);
	     allocate match_info in (names_and_values_area) 
		set (match_info_ptr);
	     match_info.version = match_info_version_1;
%skip(1);
	     do ganav_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
		match_info.name_array.exclude_sw (ganav_loop) = OFF;
		match_info.name_array.regexp_sw (ganav_loop) = OFF;
		match_info.name_array.name (ganav_loop)
		     = OPTIONS.SPECIFIC_COLUMN.NAME (ganav_loop) 
		     || BLANK || STAR_DOT_STAR_STAR;
%skip(1);
	     end;
%skip(1);
               call value_$list (value_seg_ptr, PERMANENT, match_info_ptr,
		names_and_values_area_ptr, value_list_info_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to get the specific column option names and values.");
%skip(1);
	     specific_columns_names_and_values_info_ptr = value_list_info_ptr;
%skip(1);
	end;
%skip(1);
	/* Set the number of options we have and the length of them. */
%skip(1);
          if valid_select
	then size_of_names_and_values = 
	     general_report_names_and_values_info_ptr -> value_list_info.chars_len
               + general_columns_names_and_values_info_ptr -> value_list_info.chars_len
               + specific_columns_names_and_values_info_ptr -> value_list_info.chars_len;
	else size_of_names_and_values =
	     general_report_names_and_values_info_ptr -> value_list_info.chars_len;
	allocate names_and_values in (names_and_values_area)
	     set (names_and_values_ptr);
%skip(1);
          if valid_select
          then no_of_names_and_values = 
	     general_report_names_and_values_info_ptr -> value_list_info.pair_count
               + general_columns_names_and_values_info_ptr -> value_list_info.pair_count
               + specific_columns_names_and_values_info_ptr -> value_list_info.pair_count;
	else no_of_names_and_values =
	     general_report_names_and_values_info_ptr -> value_list_info.pair_count;
	allocate name_value_info in (names_and_values_area) 
	     set (names_and_values_info_ptr);
%skip(1);
     	/* Move the general report options and their lengths and index
             into the callers table. */
%skip(1);
          value_list_info_ptr = general_report_names_and_values_info_ptr;
          substr (names_and_values, 1, value_list_info.chars_len)
	     = value_list_info.chars;
%skip(1);
	do ganav_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
%skip(1);
	     name_value_info.name.index (ganav_loop) = 
		value_list_info.pairs.name_index (ganav_loop);
	     name_value_info.name.length (ganav_loop) = 
		value_list_info.pairs.name_len (ganav_loop);
               name_value_info.value.index (ganav_loop) =
		value_list_info.pairs.value_index (ganav_loop);
	     name_value_info.value.length (ganav_loop) = 
		value_list_info.pairs.value_len (ganav_loop);
%skip(1);
	end;
%skip(1);
          if ^valid_select
          then return;
%skip(1);
     	/* Move the general and specific column options and their lengths
             and index into the callers table. */
%skip(1);
          ganav_no_of_chars_already_done = value_list_info.chars_len;
          ganav_inner_loop = NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE + 1;
	value_list_info_ptr = general_columns_names_and_values_info_ptr;
	substr (names_and_values, ganav_no_of_chars_already_done + 1,
	     value_list_info.chars_len) = value_list_info.chars;
%skip(1);
          do ganav_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
	     name_value_info.name.index (ganav_inner_loop) = 
		value_list_info.pairs.name_index (ganav_loop) 
		+ ganav_no_of_chars_already_done;
	     name_value_info.name.length (ganav_inner_loop) = 
		value_list_info.pairs.name_len (ganav_loop);
%skip(1);
               name_value_info.value.index (ganav_inner_loop) =
		value_list_info.pairs.value_index (ganav_loop) 
		+ ganav_no_of_chars_already_done;
	     name_value_info.value.length (ganav_inner_loop) = 
		value_list_info.pairs.value_len (ganav_loop);
	     ganav_inner_loop = ganav_inner_loop + 1;
%skip(1);
	end;
%skip(1);
          ganav_no_of_chars_already_done = 
	     ganav_no_of_chars_already_done + value_list_info.chars_len;
	value_list_info_ptr = specific_columns_names_and_values_info_ptr;
	substr (names_and_values, ganav_no_of_chars_already_done + 1,
	     value_list_info.chars_len) = value_list_info.chars;
%skip(1);
          ganav_loop_limit = NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE
	     * table_info.column_count;
%skip(1);
          do ganav_loop = 1 to ganav_loop_limit;
%skip(1);
	     name_value_info.name.index (ganav_inner_loop) = 
		value_list_info.pairs.name_index (ganav_loop) 
		+ ganav_no_of_chars_already_done;
	     name_value_info.name.length (ganav_inner_loop) = 
		value_list_info.pairs.name_len (ganav_loop);
%skip(1);
               name_value_info.value.index (ganav_inner_loop) =
		value_list_info.pairs.value_index (ganav_loop) 
		+ ganav_no_of_chars_already_done;
	     name_value_info.value.length (ganav_inner_loop) = 
		value_list_info.pairs.value_len (ganav_loop);
	     ganav_inner_loop = ganav_inner_loop + 1;
%skip(1);
	end;
%skip(1);
          return;
%skip(1);
     end get_all_names_and_values;
%page;
get_general_column_default_value: proc (

	ggcdv_option_name_parm, /* input: name of option */
	ggcdv_option_value_parm /* output: default value for above option */
			        );
%skip(3);
/*

     When this proc is called it expects ggcdv_option_name_parm to contain
     the name of the option that the default should be generated for.  It
     sets ggcdv_option_value_parm to this default value or "ERROR" if things
     don't work out well.

*/
%skip(1);
dcl ggcdv_loop fixed bin;
dcl ggcdv_option_name_parm char (*) varying parm;
dcl ggcdv_option_value_parm char (*) varying parm;
%skip(1);
	if ggcdv_option_name_parm 
	     = OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_COLUMN_ORDER)
	then do;
	     ggcdv_option_value_parm = table_info.columns.column_name (1);
	     if number_of_defined_columns = 1
	     then return;
	     do ggcdv_loop = 2 to number_of_defined_columns;
		ggcdv_option_value_parm = ggcdv_option_value_parm || BLANK
		     || table_info.columns.column_name (ggcdv_loop);
	     end;
	end;
	else ggcdv_option_value_parm = "ERROR";
%skip(1);
	return;
%skip(1);
     end get_general_column_default_value;
%page;
get_specific_column_default_value: proc (

	gscdv_option_name_parm,	/* input: option name */
	gscdv_option_identifier_parm,	/* input: identifier for name */
	gscdv_option_value_parm       /* output: value for the option */
				);
%skip(3);
/*

     This proc gets the default value of any given column.  When called, it
     expects that gscdv_option_name_parm contains a valid option name and
     gscdv_option_identifier_parm contains a valid option identifier which has
     been normalized into a column name.  It places the default value in
     gscdv_option_value_parm.  This proc expects that table_info is available
     and up to date, which means there has to be a set of columns defined.
     Error conditions are handled by setting the value "ERROR".  There should
     never be any error conditions unless this proc is used incorrectly.

*/
%skip(1);
dcl gscdv_column_option_number fixed bin;
dcl gscdv_column_type fixed bin (6) unsigned unaligned;
dcl gscdv_hit bit (1) aligned;
dcl gscdv_loop fixed bin;
dcl gscdv_option_identifier_parm char (*) varying parm;
dcl gscdv_option_name_parm char (*) varying parm;
dcl gscdv_option_value_parm char (*) varying parm;
%skip(1);
          gscdv_hit = OFF;
%skip(1);
	do gscdv_loop = 1 to number_of_defined_columns while (^gscdv_hit);
	     if table_info.columns.column_name (gscdv_loop) 
		= gscdv_option_identifier_parm
	     then do;
		gscdv_hit = ON;
		gscdv_column_option_number = gscdv_loop;
	     end;
	end;
%skip(1);
	if ^gscdv_hit 
	then do;
	     gscdv_option_value_parm = "ERROR";
	     return;
	end;
%page;
          if gscdv_option_name_parm 
	     = OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_ALIGNMENT)
	then do;
	     arg_descriptor_ptr = addr (table_info.columns.column_data_type (
		gscdv_column_option_number));
	     gscdv_column_type = arg_descriptor.type;
	     if (gscdv_column_type >= 1 & gscdv_column_type <= 8)             /* NUMERIC */
	     | (gscdv_column_type = 33 | gscdv_column_type = 34)
	     then gscdv_option_value_parm = RIGHT;
	     else if (gscdv_column_type >= 9 & gscdv_column_type <= 12)       /* DECIMAL */
		| (gscdv_column_type = 29 | gscdv_column_type = 30)
		| (gscdv_column_type = 35 | gscdv_column_type = 36)
		| (gscdv_column_type >= 38 & gscdv_column_type <= 46)
		then if fixed_arg_descriptor.scale > 0
		     then gscdv_option_value_parm = DECIMAL || BLANK || ltrim (char
		          (table_info.columns.column_length (gscdv_column_option_number)
		          - fixed_arg_descriptor.scale));
	               else gscdv_option_value_parm = RIGHT;
	          else if (gscdv_column_type >= 19 & gscdv_column_type <= 22) /* CHAR OR BIT */
		     then gscdv_option_value_parm = LEFT;
		     else call ssu_$abort_line (sci_ptr, 0,
		     "The table information described an unsupported data type.^/The data descriptor was ^d.", 
		     gscdv_column_type);
	end;
          else if gscdv_option_name_parm
	     = OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_TITLE)
	     then gscdv_option_value_parm
	     = table_info.columns.column_name (gscdv_column_option_number);
	     else if gscdv_option_name_parm 
		= OPTIONS.SPECIFIC_COLUMN.NAME (INDEX_FOR_WIDTH)
		then gscdv_option_value_parm = ltrim (char 
		     (table_info.columns.column_length (gscdv_column_option_number)));
	          else gscdv_option_value_parm = "ERROR";
%skip(1);
     end get_specific_column_default_value;
%page;
get_named_values: proc (gnv_code_parm);
%skip(3);
/*

     This proc is called by the get_named entrypoint to get the names and
     values which match a set of option names and identifiers supplied by the
     caller of the get_named entry.  The option name can be a short or long
     name.  The column/option identifier provided can be a column name,
     column number, or star name.  The star names can only match column
     names; star name matching of column numbers is not attempted.
     Unfortunately, value_$list has an ugly little quirk of not returning the
     code error_table_$nomatch when star names result in no match, if any
     other name in the match_info structure does get a match.  So we have to
     pre-match star names or else user specified star names that don't get a
     match could well go unnoticed.

*/
%skip(1);
dcl gnv_code_parm fixed bin (35) parm;
dcl gnv_current_star_name fixed bin;
dcl gnv_inner_loop fixed bin;
dcl gnv_loop fixed bin;
dcl gnv_match_info_index fixed bin;
dcl gnv_number_of_matches fixed bin;
%skip(1);
	gnv_code_parm = 0;
%skip(1);
	alloc_name_count = no_of_options_in_name_table;
	if valid_select
	then alloc_max_name_len = MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH;
	else alloc_max_name_len = MAXIMUM_OPTION_NAME_LENGTH;
%skip(1);
	star_name_info_ptr = names_and_values_temp_seg_ptr;
	star_name_info.maximum_number_of_star_names 
	     = no_of_options_in_name_table;
	star_name_info.star_name_map (*) = OFF;
	star_name_info.number_of_star_names = 1;
%skip(1);
	allocate column_map in (names_and_values_area) set (column_map_ptr);
%skip(1);
	do gnv_loop = 1 to no_of_options_in_name_table;
%skip(1);
	     call normalize_option_name (
		option_name_table.the_name (gnv_loop),
		option_name_table.the_identifier (gnv_loop),
		option_type, option_table_index, 
		normalized_option_name, gnv_code_parm);
	     if gnv_code_parm = 0
	     then if option_type = SPECIFIC_COLUMN_OPTION
		then option_name_table.the_identifier (gnv_loop)
		     = after (normalized_option_name, BLANK);
	          else option_name_table.the_identifier (gnv_loop) = "";
	     else if gnv_code_parm = error_table_$nostars
		then do;
		     call match_column_names (
			option_name_table.the_identifier (gnv_loop),
			column_map, gnv_number_of_matches, gnv_code_parm);
		     if gnv_code_parm ^= 0
		     then call ssu_$abort_line (sci_ptr, gnv_code_parm,
			"^/The column identifier ^a did not match any column names.",
			option_name_table.the_identifier (gnv_loop));
		     else;
		     if gnv_number_of_matches ^= 1
		     then alloc_name_count = alloc_name_count
			+ gnv_number_of_matches - 1;
		     star_name_info.star_name_map (gnv_loop) = ON;
		     star_name_info.column_maps_info (
			star_name_info.number_of_star_names)
			.number_of_matches = gnv_number_of_matches;
		     star_name_info.column_maps_info (
			star_name_info.number_of_star_names)
			.column_bit_map (*) = column_map (*);
		     star_name_info.number_of_star_names
			= star_name_info.number_of_star_names + 1;
		end;
		else if gnv_code_parm = rw_error_$bad_option_name
		     then call ssu_$abort_line (sci_ptr, gnv_code_parm,
		          "^/^a is not a valid option name.",
		          option_name_table.the_name (gnv_loop));
		     else if gnv_code_parm = rw_error_$bad_option_identifier
			then call ssu_$abort_line (sci_ptr, gnv_code_parm,
			     "^/^a is not a valid option identifier for ^a.",
			     option_name_table.the_identifier (gnv_loop),
		               option_name_table.the_name (gnv_loop));
			else call ssu_$abort_line (sci_ptr, gnv_code_parm);
%skip(1);
	end;
%skip(1);
	star_name_info.number_of_star_names
	     = star_name_info.number_of_star_names - 1;
%skip(1);
	allocate match_info in (names_and_values_area) set (match_info_ptr);
	match_info.version = match_info_version_1;
%skip(1);
	gnv_match_info_index = 1;
	gnv_current_star_name = 1;
	do gnv_loop = 1 to no_of_options_in_name_table;
%skip(1);
	     match_info.name_array.exclude_sw (gnv_match_info_index) = OFF;
	     match_info.name_array.regexp_sw (gnv_match_info_index) = OFF;
%skip(1);
	     if ^star_name_info.star_name_map (gnv_loop)
	     then do;
		if option_name_table.the_identifier (gnv_loop) = ""
		then match_info.name_array.name (gnv_match_info_index)
		     = option_name_table.the_name (gnv_loop);
		else match_info.name_array.name (gnv_match_info_index)
		     = option_name_table.the_name (gnv_loop)
		     || BLANK || option_name_table.the_identifier (gnv_loop);
		gnv_match_info_index = gnv_match_info_index + 1;
	     end;
	     else do;
		column_map_ptr = addr (star_name_info
		     .column_maps_info (gnv_current_star_name)
		     .column_bit_map (1));
		do gnv_inner_loop = 1 to number_of_defined_columns;
		     if column_map (gnv_inner_loop)
		     then do;
			match_info.name_array.name (gnv_match_info_index)
			     = option_name_table.the_name (gnv_loop)
			     || BLANK || table_info.columns.column_name (gnv_inner_loop);
			gnv_match_info_index = gnv_match_info_index + 1;
		     end;
		end;
		gnv_current_star_name = gnv_current_star_name + 1;
	     end;
%skip(1);
	end;
%skip(1);	
	call value_$list (value_seg_ptr, PERMANENT, match_info_ptr,
	     names_and_values_area_ptr, value_list_info_ptr, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^/Unable to get the values of the specified format options.");
	else;
%skip(1);
	no_of_names_and_values = value_list_info.pair_count;
	allocate name_value_info in (names_and_values_area) 
	     set (names_and_values_info_ptr);
%skip(1);
	do gnv_loop = 1 to no_of_names_and_values;
               name_value_info.name.length (gnv_loop) 
		= value_list_info.pairs.name_len (gnv_loop);
	     name_value_info.name.index (gnv_loop) 
		= value_list_info.pairs.name_index (gnv_loop);
               name_value_info.value.length (gnv_loop) 
		= value_list_info.pairs.value_len (gnv_loop);
	     name_value_info.value.index (gnv_loop) 
		= value_list_info.pairs.value_index (gnv_loop);
	end;
%skip(1);
	size_of_names_and_values = value_list_info.chars_len;
	allocate names_and_values in (names_and_values_area)
	     set (names_and_values_ptr);
          names_and_values = value_list_info.chars;
%skip(1);
          return;
%skip(1);
     end get_named_values;
%page;
housekeeping: proc;
%skip(3);
/*

     This procedure is called to set up various automatic versions of some of
     some things we will need to run this subroutine.

*/
%skip(1);
	report_cip = report_cip_parm;
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	value_seg_ptr = report_control_info.value_seg_ptr;
	names_and_values_area_ptr = report_control_info.name_value_area_ptr;
	names_and_values_temp_seg_ptr = report_control_info.name_value_temp_seg_ptr;
%skip(1);
	table_control_ip = report_control_info.table_control_info_ptr;
	table_ip = report_control_info.table_information_ptr;
	if table_ip = null
	then do;
	     valid_select = OFF;
	     number_of_defined_columns = 0;
	end;
	else do;
	     valid_select = ON;
	     number_of_defined_columns = table_info.column_count;
	end;
%skip(1);
          return;
%skip(1);
     end housekeeping;
%page;
load_value_seg_with_column_defaults: proc;
%skip(3);
/*

     This procedure is called to load all of the column default values into
     the value seg.  It expects that table_info has been set and is current
     (which means there must be a valid select available.)

*/
%skip(1);
dcl lvswcd_inner_loop fixed bin;
dcl lvswcd_loop fixed bin;
%skip(1);
	do lvswcd_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
	     lvswcd_option_name = OPTIONS.GENERAL_COLUMN.NAME (lvswcd_loop);
	     lvswcd_option_value = OPTIONS.GENERAL_COLUMN.VALUE (lvswcd_loop);
	     if length (lvswcd_option_value) > 0
	     then if substr (lvswcd_option_value, 1, 1) = LEFT_BRACKET
		then do;
		     call get_general_column_default_value (
			lvswcd_option_name, lvswcd_option_value);
		     if lvswcd_option_value = "ERROR"
		     then call ssu_$abort_line (sci_ptr, 0,
			"While trying to get the default value for ^a.",
			lvswcd_option_name);
		     else;
		end;
		else;
	     else;
%skip(1);
	     call value_$set (value_seg_ptr, PERMANENT, lvswcd_option_name,
		lvswcd_option_value, returned_option_value, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to set the value ^a for ^a.",
		lvswcd_option_value, lvswcd_option_name);
%skip(1);
	end;
%page;
	do lvswcd_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;
%skip(1);
	     lvswcd_option_name = OPTIONS.SPECIFIC_COLUMN.NAME (lvswcd_loop);
%skip(1);
	     do lvswcd_inner_loop = 1 to number_of_defined_columns;
%skip(1);
		lvswcd_option_identifier 
		     = table_info.columns.column_name (lvswcd_inner_loop);
		normalized_option_name
		     = lvswcd_option_name || BLANK || lvswcd_option_identifier;
		lvswcd_option_value = OPTIONS.SPECIFIC_COLUMN.VALUE (lvswcd_loop);
		if length (lvswcd_option_value) > 0
		then if substr (lvswcd_option_value, 1, 1) = LEFT_BRACKET
		     then do;
			call get_specific_column_default_value (
			     lvswcd_option_name, lvswcd_option_identifier,
			     lvswcd_option_value);
			if lvswcd_option_value = "ERROR"
			then call ssu_$abort_line (sci_ptr, 0,
			     "While trying to get the default value for ^a.",
			     normalized_option_name);
			else;
		     end;
		     else;
		else;
%skip(1);
		call value_$set (value_seg_ptr, PERMANENT, 
		     normalized_option_name, lvswcd_option_value, 
		     returned_option_value, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code,
		     "While trying to set the value ^a for ^a.",
		     lvswcd_option_value, normalized_option_name);
%skip(1);
	     end;
%skip(1);
	end;
%skip(1);
	report_control_info.options_identifier
	     = report_control_info.options_identifier + 1;
	report_control_info.format_options_flags
	     .general_column_default_value (*) = ON;
%skip(1);
          return;
%skip(1);
     end load_value_seg_with_column_defaults;
%page;
load_value_seg_with_report_defaults: proc;
%skip(3);
/*

     This proc is called to load the value seg with the general report option
     defaults from the OPTIONS.GENERAL_REPORT table found in the include file
     rw_format_options.incl.pl1.

*/
%skip(1);
dcl lvswrd_loop fixed bin;
%skip(1);
          do lvswrd_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
%skip(1);
	     call value_$set (value_seg_ptr, PERMANENT, 
		OPTIONS.GENERAL_REPORT.NAME (lvswrd_loop), 
		OPTIONS.GENERAL_REPORT.VALUE (lvswrd_loop), 
		returned_option_value, code);
	     if code ^= 0 
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to set the value ^a for ^a.",
		OPTIONS.GENERAL_REPORT.VALUE (lvswrd_loop), 
		OPTIONS.GENERAL_REPORT.NAME (lvswrd_loop));
%skip(1);
	end;
%skip(1);
	report_control_info.options_identifier = 
	     report_control_info.options_identifier + 1;
	report_control_info.format_options_flags.general_report_default_value (*) = ON;
%skip(1);
	return;
%skip(1);
     end load_value_seg_with_report_defaults;
%page;
lookup_option_number: proc (

	lon_option_name_parm,  /* input: option name to look up */
	lon_option_type_parm,  /* output: the table to index into */
	lon_option_index_parm  /* output: the index into the table */
		       );
%skip(1);
/*
     
     This proc looks up option names from the three tables of option names.
     lon_option_name_parm is expected to contain the name of the option.
     lon_option_type_parm is set to indicate whether it is a general report,
     general column, or specific column option. lon_option_index_parm is
     the index into the appropriate table so the caller can obtain its value.

*/
%skip(1);
dcl lon_loop fixed bin;
dcl lon_option_name_parm char (*) varying parm;
dcl lon_option_type_parm fixed bin parm;
dcl lon_option_index_parm fixed bin parm;
%skip(1);
	lon_option_type_parm = 0;
%skip(1);
          lon_option_index_parm = lookup_general_report_option ();
	if lon_option_index_parm ^= 0
	then do;
	     lon_option_type_parm = GENERAL_REPORT_OPTION;
	     return;
	end;
%skip(1);
	lon_option_index_parm = lookup_general_column_option ();
	if lon_option_index_parm ^= 0
	then do;
	     lon_option_type_parm = GENERAL_COLUMN_OPTION;
	     return;
	end;
%skip(1);
	lon_option_index_parm = lookup_specific_column_option ();
	if lon_option_index_parm ^= 0
	then lon_option_type_parm = SPECIFIC_COLUMN_OPTION;
%skip(1);
	return;
%page;
lookup_general_column_option: proc () returns (fixed bin);
%skip(1);
	/* Look up the option name from the general column names table. */
%skip(1);
	do lon_loop = 1 to NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE;
	     if lon_option_name_parm = OPTIONS.GENERAL_COLUMN.NAME (lon_loop)
	     then return (lon_loop);
	end;
%skip(1);
	return (0);
%skip(1);
     end lookup_general_column_option;
%skip(3);
lookup_general_report_option: proc () returns (fixed bin);
%skip(1);
	/* Look up the option name from the general report names table. */
%skip(1);
	do lon_loop = 1 to NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE;
	     if lon_option_name_parm = OPTIONS.GENERAL_REPORT.NAME (lon_loop)
	     then return (lon_loop);
	end;
%skip(1);
	return (0);
%skip(1);
     end lookup_general_report_option;
%skip(3);
lookup_specific_column_option: proc () returns (fixed bin);
%skip(1);
	/* Look up the option name from the specific column names table. */
%skip(1);
	do lon_loop = 1 to NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE;
	     if lon_option_name_parm = OPTIONS.SPECIFIC_COLUMN.NAME (lon_loop)
	     then return (lon_loop);
	end;
%skip(1);
	return (0);
%skip(1);
     end lookup_specific_column_option;
%skip(1);
     end lookup_option_number;
%page;
match_column_names: proc (

	mcn_star_name_parm,         /* input: star name to match */
	mcn_column_map_parm,        /* input/output: array of match bits */
	mcn_number_of_matches_parm, /* output: number of matches */
	mcn_code_parm	        /* output: success or failure */
		     );
%skip(3);
/*

     This proc is called with a star name to determine which columns match
     it. The variable mcn_star_name_parm contains the variable which is used
     to try to get a match. The array mcn_column_map_parm contains one bit
     for each defined column. Each column that matches the star name has its
     corresponding bit turned on, and the variable mcn_number_of_matches_parm
     contains the number of columns that matched. The variable mcn_code_parm
     is set to reflect any problems encountered.

*/
%skip(1);
dcl mcn_code_parm fixed bin (35) parm;
dcl mcn_loop fixed bin;
dcl mcn_column_map_parm (*) bit (1) parm;
dcl mcn_number_of_matches fixed bin;
dcl mcn_number_of_matches_parm fixed bin parm;
dcl mcn_star_name_parm char (*) varying parm;
%skip(1);
	mcn_column_map_parm (*) = OFF;
	mcn_number_of_matches_parm = 0;
	mcn_code_parm = 0;
%skip(1);
	if hbound (mcn_column_map_parm, 1) ^= number_of_defined_columns
	then call ssu_$abort_line (sci_ptr, 0, "^a ^a^/^a",
	     "Invalid use of match_column_names by ", me,
	     "The match table was not equal to the number of defined columns.");
	else;
%skip(1);
	mcn_number_of_matches = 0;
	do mcn_loop = 1 to number_of_defined_columns;
	     call match_star_name_ (
		(table_info.columns.column_name (mcn_loop)), 
		(mcn_star_name_parm), mcn_code_parm);
	     if mcn_code_parm = 0
	     then do;
		mcn_column_map_parm (mcn_loop) = ON;
		mcn_number_of_matches = mcn_number_of_matches + 1;
	     end;
	     else if mcn_code_parm ^= error_table_$nomatch
		then return;
	          else;
	end;
%skip(1);
	if mcn_number_of_matches ^= 0
	then do;
	     mcn_number_of_matches_parm = mcn_number_of_matches;
	     mcn_code_parm = 0;
	end;
	else;
%skip(1);
	return;
%skip(1);
     end match_column_names;
%page;
normalize_option_name: proc (

	non_option_name_parm,            /* input: the option name */
	non_option_identifier_parm,      /* input: the column name or number */
	non_option_type_parm,            /* output: the type of option */
	non_option_table_index_parm,     /* output: index into options table */
	non_normalized_option_name_parm, /* output: the option and column name */
	non_code_parm		   /* output: success or failure */
		        );
%skip(1);
/*

     This proc is called to set general purpose info about the option currently
     being dealt with.  It expects non_option_name_parm to contain a name
     which can be used to determine whether or not it requires an identifier.
     The option_name must already have been expanded into a long name (see
     the "check_name" entry for expansion of option names).  If an
     identifier is needed, it expects non_option_identifier_parm to contain
     it.  The identifier can be the name of a column or the position of the
     column in the select.  If the identifier is a star name or invalid,
     non_code_parm is set.  It places the option name into
     non_normalized_option_name_parm if a column identifier isn't needed, and
     the option name and column name in it when an identifier is needed.
     When errors occur normalized_option_name is set to "", except for
     starnames.  The variable non_option_type_parm is set to flag whether it
     is a general report, general column, or specific column option.  The
     variable non_option_table_index_parm is set so the caller can index into
     the appropriate options table.

*/
%skip(1);
dcl non_code_parm fixed bin (35) parm;
dcl non_column_option_number fixed bin;
dcl non_loop fixed bin;
dcl non_normalized_option_name_parm char (*) varying parm;
dcl non_option_identifier_parm char (*) varying parm;
dcl non_option_name_parm char (*) varying parm;
dcl non_option_table_index_parm fixed bin parm;
dcl non_option_type_parm fixed bin parm;
%skip(3);
	non_normalized_option_name_parm = "";
          non_code_parm = 0;
%skip(1);
	call lookup_option_number (non_option_name_parm,
	     non_option_type_parm, non_option_table_index_parm);
	if non_option_table_index_parm = 0
	then do;
	     non_code_parm = rw_error_$bad_option_name;
	     return;
	end;
%skip(1);	
	if (non_option_type_parm = GENERAL_COLUMN_OPTION 
	| non_option_type_parm = SPECIFIC_COLUMN_OPTION)
          & (^valid_select)
	then do;
	     code = rw_error_$no_columns_defined;
	     return;
	end;
	else;
%skip(1);
          if non_option_type_parm = GENERAL_REPORT_OPTION
	| non_option_type_parm = GENERAL_COLUMN_OPTION
	then do;
	     non_normalized_option_name_parm = non_option_name_parm;
	     return;
	end;
%skip(1);
	if search (non_option_identifier_parm, STAR_OR_QUESTION_MARK) ^= 0
	then do;
	     non_code_parm = error_table_$nostars;
	     non_normalized_option_name_parm = non_option_name_parm
		|| BLANK || non_option_identifier_parm;
	     return;
	end;
%skip(1);
          if verify (non_option_identifier_parm, DIGITS) = 0
	then if convert (based_fixed_bin_71, non_option_identifier_parm)
	     <= LARGEST_FIXED_BIN_17_NUMBER
	     then do;
		non_column_option_number = convert (non_column_option_number, 
		     non_option_identifier_parm);
		if non_column_option_number < 1
		| non_column_option_number > number_of_defined_columns
		then non_code_parm = rw_error_$bad_option_identifier;
		else non_normalized_option_name_parm = non_option_name_parm || BLANK
		     || table_info.columns.column_name (non_column_option_number);
		return;
	     end;
	     else do;
		non_code_parm = rw_error_$bad_option_identifier;
		return;
	     end;
	else;
%skip(1);
          do non_loop = 1 to number_of_defined_columns;
	     if non_option_identifier_parm = table_info.columns.column_name (non_loop)
	     then do;
		non_normalized_option_name_parm =
		     non_option_name_parm || BLANK || non_option_identifier_parm;
		return;
	     end;
	end;
%skip(1);
          non_code_parm = rw_error_$bad_option_identifier;
%skip(1);
	return;
%skip(1);
     end normalize_option_name;
%page;
set_the_values: proc (

	stv_option_name_parm,	   /* input: option name */
	stv_option_identifier_parm,	   /* input: column identifier */
	stv_option_value_parm,	   /* input: option value */
	stv_system_default_parm,	   /* input: on means yes */
	stv_code_parm		   /* output: success or failure */
		   );
%skip(1);
/*

     This proc is called to set the value of a format option. If the value
     is a star name then the value is set for every name that matches the
     star name. The internal proc set_value sets the value. For a normal
     column name, it is called once with normalized_option_name used for
     the set operation. For star names, normalized_option_name is changed
     before each call with a column name that matched the star name.

*/     
%skip(1);
dcl stv_code_parm fixed bin (35) parm;
dcl stv_loop fixed bin;
dcl stv_number_of_matches fixed bin;
dcl stv_option_name_parm char (*) varying parm;
dcl stv_option_identifier_parm char (*) varying parm;
dcl stv_option_value_parm char (*) varying parm;
dcl stv_system_default_parm bit (1) aligned parm;
dcl stv_value_has_been_tested bit (1) aligned;
%skip(1);
	call normalize_option_name (stv_option_name_parm, 
	     stv_option_identifier_parm, option_type, option_table_index, 
	     normalized_option_name, stv_code_parm);
	if stv_code_parm = 0
	then do;
	     call set_value (stv_code_parm);
	     return;
	end;
	else if stv_code_parm ^= error_table_$nostars
	     then return;
%skip(1);
	allocate column_map in (names_and_values_area) 
	     set (column_map_ptr);
	call match_column_names (stv_option_identifier_parm,
	     column_map, stv_number_of_matches, stv_code_parm);
	if stv_code_parm ^= 0
	then return;
%page;
	do stv_loop = 1 to number_of_defined_columns;
%skip(1);
	     if column_map (stv_loop)
	     then do;
		normalized_option_name = stv_option_name_parm
		     || BLANK || table_info.columns.column_name (stv_loop);
		call set_value (stv_code_parm);
		if stv_code_parm ^= 0
		then return;
	     end;
%skip(1);
	end;
%skip(1);
	return;
%page;
set_value: proc (

	sv_code_parm		   /* output: success or failure */
		   );
%skip(3);
/*

     This proc is called to set the value of a format option.  The variable
     stv_system_default_parm is used to determine if the caller wants the
     system default value for the named option.  normalized_option_name is
     used to determine who's to be set.  stv_option_value_parm is the value
     which will be set if stv_system_default_parm is off.  option_type and
     option_table_index are used to find the value which will be set when
     stv_system_default_parm is on. The bit that indicates whether or not
     a value is the same as the system default is set for the general report
     and general column options. These bits are used by the get_active entry
     to determine which values are considered active. If the caller requested
     that it be set to the system default, the value is set from the OPTIONS
     table. General column and specific column values from this table
     sometimes need the actual value computed based on the current set of
     columns. These values are recognizable because they begin with a left 
     bracket. The procs get_general_column_default_value and 
     get_specific_column_default_value are called to compute the value. There
     is a dependency between the -group option and the two options 
     -group_footer_trigger and -group_header_trigger. If the -group option
     is being set back to the default then the function valid_option_value is
     invoked to make sure the other two are set back to their defaults.

*/
%skip(3);
dcl sv_code_parm fixed bin (35) parm;
dcl sv_force_group_triggers_consistency bit (1);
%skip(1);
	sv_code_parm = 0;
%skip(1);
	if ^stv_system_default_parm
	then do;
	     sv_option_value = stv_option_value_parm;
	     if ^valid_option_value (stv_option_name_parm, sv_option_value)
	     then do;
		stv_code_parm = rw_error_$bad_option_value;
		return;
	     end;
	     else;
	end;
	else do;
	     if option_type = GENERAL_REPORT_OPTION
	     then do;
		sv_option_value 
		     = OPTIONS.GENERAL_REPORT.VALUE (option_table_index);
		report_control_info.format_options_flags.
		     general_report_default_value (option_table_index) = ON;
	     end;
	     else if option_type = GENERAL_COLUMN_OPTION
		then do;
		     sv_option_value
			= OPTIONS.GENERAL_COLUMN.VALUE (option_table_index);
		     if length (sv_option_value) > 0
		     then if substr (sv_option_value, 1, 1) = LEFT_BRACKET
			then call get_general_column_default_value (
			     stv_option_name_parm, sv_option_value);
		          else;
		     else if stv_option_name_parm = OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP)
			then sv_force_group_triggers_consistency
			     = valid_option_value (stv_option_name_parm, sv_option_value);
		          else;
		     report_control_info.format_options_flags.
			general_column_default_value (option_table_index) = ON;
		end;
	          else do;
		     sv_option_value = 
			OPTIONS.SPECIFIC_COLUMN.VALUE (option_table_index);
		     if length (sv_option_value) > 0
		     then if substr (sv_option_value, 1, 1) = LEFT_BRACKET
			then do;
			     sv_spare_option_identifier 
				= after (normalized_option_name, BLANK);
			     call get_specific_column_default_value (
				stv_option_name_parm,
				sv_spare_option_identifier,
				sv_option_value);
			end;
		          else;
		     else;
		end;
	     if sv_option_value = "ERROR"
	     then call ssu_$abort_line (sci_ptr, 0,
		"Unable to set the value of ^a to the system default.",
		normalized_option_name);
	end;
%skip(1);
          call value_$set (value_seg_ptr, PERMANENT,
	     normalized_option_name, sv_option_value,
	     returned_option_value, code);
%skip(1);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to set the value ^a for ^a.",
	     sv_option_value, normalized_option_name);
%skip(1);
	report_control_info.options_identifier = 
	     report_control_info.options_identifier + 1;
%skip(1);
     	if stv_system_default_parm 
	| option_type = SPECIFIC_COLUMN_OPTION
	then return;
%page;
     	if option_type = GENERAL_REPORT_OPTION
	then do;
	     if sv_option_value
	     = OPTIONS.GENERAL_REPORT.VALUE (option_table_index)
	     then report_control_info.format_options_flags.
		general_report_default_value (option_table_index) = ON;
	     else report_control_info.format_options_flags.
		general_report_default_value (option_table_index) = OFF;
	end;
	else do;
	     stv_value_has_been_tested = OFF;
	     if length (sv_option_value) > 0
	     & length (OPTIONS.GENERAL_COLUMN.VALUE (option_table_index)) > 0
	     then if substr (OPTIONS.GENERAL_COLUMN.VALUE (
		option_table_index), 1, 1) = LEFT_BRACKET
		then do;
		     call get_general_column_default_value (
			stv_option_name_parm, sv_spare_option_value);
		     if sv_spare_option_value = "ERROR"
		     then call ssu_$abort_line (sci_ptr, 0,
			"Unable to get the default value of ^a.",
			stv_option_name_parm);
		     else;
		     stv_value_has_been_tested = ON;
		     if sv_option_value = sv_spare_option_value
		     then report_control_info.format_options_flags.
			general_column_default_value (option_table_index) = ON;
		     else report_control_info.format_options_flags.
			general_column_default_value (option_table_index) = OFF;
		end;
		else;
	     else;
	     if ^stv_value_has_been_tested
	     then if sv_option_value
		= OPTIONS.GENERAL_COLUMN.VALUE (option_table_index)
		then report_control_info.format_options_flags.
		     general_column_default_value (option_table_index) = ON;
		else report_control_info.format_options_flags.
		     general_column_default_value (option_table_index) = OFF;
	     else;
	end;
%skip(1);
	return;
%skip(1);
     end set_value;
%skip(1);
     end set_the_values;
%page;
valid_option_value: proc (

	vov_option_name_parm,	/* input: option name */
	vov_option_value_parm	/* input: option value */
		     ) returns (bit (1));
%skip(3);
/*

     This function is invoked to check the value for an option.  It expects
     that vov_option_name_parm contains a valid option name which has been
     expanded, and that vov_option_value_parm contains the value to check for
     validity.  This function calls an internal procedure to do the checking.
     These internal procedures are declared in the three tables immediately
     following this description.  If it is a valid value, "1"b is returned.
     "0"b indicates an invalid value.

*/
%skip(1);
dcl vov_any_or_all bit (1) aligned;
dcl vov_check_result_bit bit (1) aligned;
%skip(1);
dcl vov_check_procs_for_general_report_options (NUMBER_OF_GENERAL_REPORT_OPTIONS_IN_TABLE) entry init (

check_any_single_printable_character,	/* "-delimiter" */
check_on_or_off,			/* "-format_document_controls" */
check_on_or_off,			/* "-hyphenation" */
check_any_character_string,		/* "-page_footer_value" */
check_any_character_string,		/* "-page_header_value" */
check_zero_or_greater_than_six,	/* "-page_length" */
check_zero_or_any_positive_integer,	/* "-page_width" */
check_on_or_off,			/* "-title_line" */
check_any_printable_string_no_NL	/* "-truncation" */
);
%skip(1);
dcl vov_check_procs_for_general_column_options (NUMBER_OF_GENERAL_COLUMN_OPTIONS_IN_TABLE) entry init (

check_all_column_names_eventually,	/* "-column_order" */
check_any_column_names_or_none,	/* "-count" */
check_any_column_names_or_none,	/* "-exclude" */
check_and_keep_triggers_consistent,	/* "-group" */
check_any_valid_group_list,		/* "-group_footer_trigger" */
check_any_character_string,		/* "-group_footer_value" */
check_any_valid_group_list,		/* "-group_header_trigger" */
check_any_character_string,		/* "-group_header_value" */
check_any_column_names_or_none,	/* "-outline" */
check_any_column_names_or_none,	/* "-page_break" */
check_any_character_string,		/* "-row_footer_value" */
check_any_character_string,		/* "-row_header_value" */
check_subcount_list_or_none,		/* "-subcount" */
check_subtotal_list_or_none,		/* "-subtotal" */
check_any_column_names_or_none	/* "-total" */
);
%skip(1);
dcl vov_check_procs_for_specific_column_options (NUMBER_OF_SPECIFIC_COLUMN_OPTIONS_IN_TABLE) entry init (

check_any_alignment_mode,		/* "-alignment" */
check_any_character_string,		/* "-editing" */
check_any_folding_action,		/* "-folding" */
check_any_printable_string_no_NL,	/* "-separator" */
check_any_character_string,		/* "-title" */
check_any_positive_integer		/* "-width" */
);
%skip(1);
dcl vov_character_string char (80) varying;
dcl vov_complete_the_list bit (1) aligned;
dcl vov_loop fixed bin;
dcl vov_loop_limit fixed bin;
dcl vov_number_tester fixed bin;
dcl vov_one_to_nine_found bit (1) aligned;
dcl vov_option_name_parm char (*) varying parm;
dcl vov_option_value_parm char (*) varying parm;
dcl vov_target_character char (1);
%skip(3);
          vov_check_result_bit = OFF;
%skip(1);
	call lookup_option_number (vov_option_name_parm,
	     option_type, option_table_index);
	if option_table_index = 0
	then return (OFF);
%skip(1);
	if option_type = GENERAL_REPORT_OPTION
	then call vov_check_procs_for_general_report_options (option_table_index);
	else if option_type = GENERAL_COLUMN_OPTION
	     then call vov_check_procs_for_general_column_options (option_table_index);
	     else call vov_check_procs_for_specific_column_options (option_table_index);
%skip(1);
          return (vov_check_result_bit);
%page;
check_all_column_names_eventually: proc;
%skip(3);
	vov_any_or_all = ANY;
	vov_complete_the_list = ON;
          vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
%skip(1);
          return;
%skip(1);
     end check_all_column_names_eventually;
%page;
check_and_keep_triggers_consistent: proc;
%skip(1);
dcl caktc_group_list_ptr ptr;
dcl caktc_inner_loop fixed bin;
dcl caktc_loop fixed bin;
%skip(3);
	if vov_option_value_parm = ""
	then do;
	     do caktc_loop = INDEX_FOR_GROUP_HEADER_TRIGGER, INDEX_FOR_GROUP_FOOTER_TRIGGER;
		call value_$set (value_seg_ptr, PERMANENT,
		     OPTIONS.GENERAL_COLUMN.NAME (caktc_loop),
		     OPTIONS.GENERAL_COLUMN.VALUE (caktc_loop),
		     returned_option_value, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code,
		     "While trying to set the value ^a for ^a.",
		     OPTIONS.GENERAL_COLUMN.NAME (caktc_loop),
		     OPTIONS.GENERAL_COLUMN.VALUE (caktc_loop));
		report_control_info.format_options_flags.
		     general_column_default_value (caktc_loop) = ON;
	     end;
	     vov_check_result_bit = ON;
	     return;
	end;
%skip(1);
	vov_any_or_all = ANY;
	vov_complete_the_list = OFF;
	vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
	if ^vov_check_result_bit
	then return;
%skip(1);
	caktc_group_list_ptr = judgement_table_ptr;
	caktc_option_value = vov_option_value_parm;
	do caktc_loop = INDEX_FOR_GROUP_HEADER_TRIGGER, INDEX_FOR_GROUP_FOOTER_TRIGGER;
	     call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop),
		vov_option_value_parm, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code,
		"While trying to get the value of ^a.",
		OPTIONS.GENERAL_COLUMN.NAME (caktc_loop));
	     if vov_option_value_parm ^= ""
	     then do;
		vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
		do caktc_inner_loop = 1 to number_of_defined_columns;
		     if judgement_table.present (caktc_inner_loop)
		     then if ^(caktc_group_list_ptr -> judgement_table.present (caktc_inner_loop))
			then judgement_table.present (caktc_inner_loop) = OFF;
		          else;
		     else;
		end;
		vov_option_value_parm = "";
		do caktc_inner_loop = 1 to number_of_defined_columns;
		     if judgement_table.present (caktc_inner_loop)
		     then vov_option_value_parm = vov_option_value_parm
			|| table_info.columns (caktc_inner_loop).column_name || BLANK;
		     else;
		end;
		vov_option_value_parm = rtrim (vov_option_value_parm);
		call value_$set (value_seg_ptr, PERMANENT,
		     OPTIONS.GENERAL_COLUMN.NAME (caktc_loop), vov_option_value_parm,
		     returned_option_value, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code,
		     "While trying to set the value ^a for ^a.",
		     vov_option_value_parm, OPTIONS.GENERAL_COLUMN.NAME (caktc_loop));
		if vov_option_value_parm = ""
		then report_control_info.format_options_flags.
		     general_column_default_value (caktc_loop) = ON;
	     end;
	end;
%skip(1);
	vov_check_result_bit = ON;
	vov_option_value_parm = caktc_option_value;
%skip(1);
	return;
%skip(1);
     end check_and_keep_triggers_consistent;
%page;
check_any_alignment_mode: proc;
%skip(3);
          if vov_option_value_parm = RIGHT
          | vov_option_value_parm = LEFT
          | vov_option_value_parm = CENTER
	| vov_option_value_parm = BOTH
	then vov_check_result_bit = ON;
	else do;
	     vov_character_string = before (vov_option_value_parm, BLANK);
	     if vov_character_string ^= DECIMAL
	     then return;
	     vov_character_string 
		= ltrim (rtrim (after (vov_option_value_parm, DECIMAL)));
	     if verify (vov_character_string, DIGITS) = 0
	     then if convert (based_fixed_bin_71, vov_character_string) > 0
		& convert (based_fixed_bin_71, vov_character_string) < 60
		then vov_check_result_bit = ON;
	          else;
	     else;
	end;
%skip(1);
          return;
%skip(1);
     end check_any_alignment_mode;
%page;
check_any_character_string: proc;
%skip(3);
          vov_check_result_bit = ON;
%skip(1);
	return;
%skip(1);
     end check_any_character_string;
%skip(1);
check_any_column_names_or_none: proc;
%skip(3);
          if vov_option_value_parm = ""
	then do;
	     vov_check_result_bit = ON;
	     return;
	end;
	vov_any_or_all = ANY;
	vov_complete_the_list = OFF;
	vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
%skip(1);
	return;
%skip(1);
     end check_any_column_names_or_none;
%skip(3);
check_any_folding_action: proc;
%skip(3);
          if vov_option_value_parm = FILL
	| vov_option_value_parm = TRUNCATE
          then vov_check_result_bit = ON;
%skip(1);
          return;
%skip(1);
     end check_any_folding_action;
%page;
check_any_printable_string_no_NL: proc;
%skip(3);
          vov_loop_limit = length (vov_option_value_parm);
	if vov_loop_limit = 0
	then  do;
	     vov_check_result_bit = ON;
	     return;
	end;
	do vov_loop = 1 to vov_loop_limit;
	     vov_target_character = substr (vov_option_value_parm, vov_loop, 1);
	     if vov_target_character < BLANK
	     | vov_target_character > TILDE
	     then return;
	end;
          vov_check_result_bit = ON;
%skip(1);
          return;
%skip(1);
     end check_any_printable_string_no_NL;
%skip(3);
check_any_single_printable_character: proc;
%skip(3);
          if length (vov_option_value_parm) = 1
	then if vov_option_value_parm >= BLANK 
	     & vov_option_value_parm <= TILDE
	     then vov_check_result_bit = ON;
	     else;
	else;
%skip(1);
          return;
%skip(1);
     end check_any_single_printable_character;
%page;
check_any_positive_integer: proc;
%skip(3);
          vov_loop_limit = length (vov_option_value_parm);
	if vov_loop_limit = 0
	then return;
	vov_one_to_nine_found = OFF;
	do vov_loop = 1 to vov_loop_limit;
	     vov_target_character = substr (vov_option_value_parm, vov_loop, 1);
	     if vov_target_character < ZERO
	     | vov_target_character > NINE
	     then return;
	     if vov_target_character ^= ZERO
	     then vov_one_to_nine_found = ON;
	end;
%skip(1);
	if convert (based_fixed_bin_71, vov_option_value_parm)
	<= LARGEST_FIXED_BIN_17_NUMBER
	then if vov_one_to_nine_found
	     then vov_check_result_bit = ON;
%skip(1);
          return;
%skip(1);
     end check_any_positive_integer;
%page;
check_any_valid_group_list: proc;
%skip(1);
dcl cavgl_group_list_judgement_table_ptr ptr;
dcl cavgl_loop fixed bin;
%skip(3);
	if vov_option_value_parm = ""
	then do;
	     vov_check_result_bit = ON;
	     return;
	end;
	vov_any_or_all = ANY;
	vov_complete_the_list = OFF;
	vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
	if ^vov_check_result_bit
	then return;
	cavgl_group_list_judgement_table_ptr = judgement_table_ptr;
	cavgl_save_option_value = vov_option_value_parm;
	call value_$get (value_seg_ptr, PERMANENT, OPTIONS.GENERAL_COLUMN.NAME
	     (INDEX_FOR_GROUP), vov_option_value_parm, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "While trying to get the value of ^a.", 
	     OPTIONS.GENERAL_COLUMN.NAME (INDEX_FOR_GROUP));
	vov_check_result_bit = replace_column_list_after_checking (judgement_table_ptr);
	if ^vov_check_result_bit
	then return;
	vov_option_value_parm = cavgl_save_option_value;
	vov_check_result_bit = OFF;
%skip(1);
	do cavgl_loop = 1 to number_of_defined_columns;
	     if cavgl_group_list_judgement_table_ptr -> judgement_table.present (cavgl_loop)
	     then if ^judgement_table.present (cavgl_loop)
		then return;
	          else;
	     else;
	end;
	vov_check_result_bit = ON;
%skip(1);
	return;
%skip(1);
     end check_any_valid_group_list;
%page;
check_on_or_off: proc;
%skip(3);
	if vov_option_value_parm = "on"
	| vov_option_value_parm = "off"
          then vov_check_result_bit = ON;
%skip(1);
	return;
%skip(1);
     end check_on_or_off;
%page;
check_subcount_list_or_none: proc;
%skip(3);
	if vov_option_value_parm = ""
	then do;
	     vov_check_result_bit = ON;
	     return;
	end;
%skip(1);
     	vov_check_result_bit = replace_subtotal_list_after_checking (ALLOW_DUPLICATES);
%skip(1);
	return;
%skip(1);
     end check_subcount_list_or_none;
%skip(3);
check_subtotal_list_or_none: proc;
%skip(3);
	if vov_option_value_parm = ""
	then do;
	     vov_check_result_bit = ON;
	     return;
	end;
%skip(1);
     	vov_check_result_bit = replace_subtotal_list_after_checking (DONT_ALLOW_DUPLICATES);
%skip(1);
	return;
%skip(1);
     end check_subtotal_list_or_none;
%skip(3);
check_zero_or_any_positive_integer: proc;
%skip(3);
          if verify (vov_option_value_parm, DIGITS) = 0
	then if convert (based_fixed_bin_71, vov_option_value_parm)
	     <= LARGEST_FIXED_BIN_17_NUMBER
	     then vov_check_result_bit = ON;
%skip(1);
          return;
%skip(1);
     end check_zero_or_any_positive_integer;
%page;
check_zero_or_greater_than_six: proc;
%skip(3);
          if verify (vov_option_value_parm, DIGITS) = 0
	then if convert (based_fixed_bin_71, vov_option_value_parm)
	     <= LARGEST_FIXED_BIN_17_NUMBER
	     then do;
		vov_number_tester = convert (vov_number_tester,
		     vov_option_value_parm);
		if vov_number_tester = 0
		|  vov_number_tester > 6
		then vov_check_result_bit = ON;
	     end;
	     else;
	else;
%skip(1);
          return;
%skip(1);
     end check_zero_or_greater_than_six;
%page;
replace_column_list_after_checking: proc (
	rclac_judgement_table_ptr_parm	/* output: points to the judgement table */
				 ) returns (bit(1));
%skip(3);
/*

     This proc is called to check a list of columns, which may be given as
     column names or numbers, and then create a new list containing only column
     names if the check proved sucessful.  It expects that
     vov_option_value_parm contains the list of columns.  The variable
     vov_any_or_all_parm dictates what type of checking is done.  Since the
     time when this code was written the restriction of having all columns
     named in a "-column_order" option was removed, but this subroutine still
     provides the service of validating that all columns are present in a list
     because it is felt an additional option which has this requirement may
     be added sometime in the future.  If the check proves sucessfull,
     vov_option_value_parm is replaced with a list of column names, and "1"b is
     returned.  An unsucessful check returns "0"b and the value of
     vov_option_value_parm isn't set. If the variable vov_complete_the_list
     is on the list is filled in with any missing columns; if it is off the
     list will only contain the names of the columns found. The judgment_table
     structure if filled in to describe the original list found. Each bit 
     turned on indicates that particular column was found in the list and the
     number field of the structure indicates where in the list it was found.

*/
%skip(1);
dcl rclac_code fixed bin (35);
dcl rclac_column_name_length fixed bin;
dcl rclac_current_position fixed bin;
dcl rclac_finished bit (1) aligned;
dcl rclac_first_blank fixed bin;
dcl rclac_hit bit (1) aligned;
dcl rclac_inner_loop fixed bin;
dcl 1 rclac_judgement_table (number_of_defined_columns) like judgement_table based (rclac_judgement_table_ptr);
dcl rclac_judgement_table_ptr ptr;
dcl rclac_judgement_table_ptr_parm ptr parm;
dcl rclac_loop fixed bin;
dcl rclac_no_of_claimed_digits fixed bin;
dcl rclac_spare_option_value_length fixed bin;
dcl rclac_still_skipping_blanks bit (1) aligned;
dcl rclac_target_character char (1);
%skip(1);
	rclac_judgement_table_ptr_parm = null ();
          if vov_option_value_parm = ""
	then return (OFF);
%skip(1);
          rclac_spare_option_value =  ltrim (rtrim (translate
	     (vov_option_value_parm, BLANK, TAB))) || BLANK;
	rclac_spare_option_value_length = length (rclac_spare_option_value);
	rclac_current_position = 1;
%skip(1);
          allocate rclac_judgement_table in (names_and_values_area)
	     set (rclac_judgement_table_ptr);
	unspec (rclac_judgement_table) = OFF;
%skip(1);
          rclac_finished = OFF;
%skip(1);
          do rclac_loop = 1 to number_of_defined_columns while (^rclac_finished);
%skip(1);
	     rclac_first_blank = index (substr (rclac_spare_option_value, 
		rclac_current_position), BLANK) 
		+ rclac_current_position - 1;
	     if rclac_first_blank >= rclac_spare_option_value_length
	     then if rclac_loop ^= number_of_defined_columns
		& vov_any_or_all = ALL
		then return (OFF);
	          else rclac_finished = ON;
	     else;
%skip(1);
	     rclac_target_character = substr (rclac_spare_option_value, 
		rclac_current_position, 1);
	     if rclac_target_character >= ZERO 
	     & rclac_target_character <= NINE
	     then do;
		rclac_no_of_claimed_digits 
		     = rclac_first_blank - rclac_current_position;
		if rclac_no_of_claimed_digits < 1
		then return (OFF);
%skip(1);
		rclac_judgement_table.number (rclac_loop) = cv_dec_check_
		     (substr (rclac_spare_option_value, rclac_current_position, 
		     rclac_no_of_claimed_digits), rclac_code);
		if rclac_code ^= 0
		then return (OFF);
%skip(1);
		if rclac_judgement_table.number (rclac_loop) < 1 
		| rclac_judgement_table.number (rclac_loop) > number_of_defined_columns
		then return (OFF);
	     end;
	     else do;
		rclac_hit = OFF;
		rclac_column_name_length 
		     = rclac_first_blank - rclac_current_position;
%skip(1);
		do rclac_inner_loop = 1 to number_of_defined_columns while (^rclac_hit);
		     if substr (rclac_spare_option_value, 
		     rclac_current_position, rclac_column_name_length) 
		     = table_info.columns.column_name (rclac_inner_loop)
		     then rclac_hit = ON;
		end;
%skip(1);
		if ^rclac_hit
		then return (OFF);
		else rclac_judgement_table.number (rclac_loop) 
		     = rclac_inner_loop - 1;
	     end;
%skip(1);
	     if rclac_judgement_table.present (rclac_judgement_table.number (rclac_loop))
	     then return (OFF);
%skip(1);
	     rclac_judgement_table.present (
		rclac_judgement_table.number (rclac_loop)) = ON;
%skip(1);
               if ^rclac_finished
	     then do;
		rclac_still_skipping_blanks = ON;
		rclac_current_position = rclac_first_blank + 1;
		do while (rclac_still_skipping_blanks);
		     if substr (rclac_spare_option_value, 
		     rclac_current_position, 1) ^= BLANK
		     then rclac_still_skipping_blanks = OFF;
		     else rclac_current_position 
			= rclac_current_position + 1;
		end;
		if rclac_current_position < rclac_spare_option_value_length
		& rclac_loop >= number_of_defined_columns
		then return (OFF);
	     end;
	end;
%skip(1);
          if vov_any_or_all = ALL
	then do rclac_loop = 1 to number_of_defined_columns;
	     if ^rclac_judgement_table.present (rclac_loop)
	     then return (OFF);
	end;
%skip(1);
          rclac_spare_option_value = "";
%skip(1);
	do rclac_loop = 1 to number_of_defined_columns;
	     if rclac_judgement_table.number (rclac_loop) ^= 0
	     then rclac_spare_option_value = rclac_spare_option_value 
		|| table_info.columns.column_name (
		rclac_judgement_table.number (rclac_loop)) || BLANK;
	end;
%skip(1);
	if vov_complete_the_list
	then do rclac_loop = 1 to number_of_defined_columns;
	     if ^rclac_judgement_table.present (rclac_loop)
	     then rclac_spare_option_value = rclac_spare_option_value
		|| table_info.columns.column_name (rclac_loop) || BLANK;
	end;
%skip(1);
	vov_option_value_parm = rtrim (rclac_spare_option_value);
	rclac_judgement_table_ptr_parm = rclac_judgement_table_ptr;
%skip(1);
          return (ON);
%skip(1);
     end replace_column_list_after_checking;
%page;
replace_subtotal_list_after_checking: proc (rslac_allow_duplicates_parm) returns (bit(1));
%skip(3);
/*

     This proc is called to check a list of subtotal triplets, and then
     create a new list if the check proved successful.  The syntax of a
     triplet is "column_1,column_2{,reset|running}".  Each triplet is
     separated by whitespace. column_N can be given as a column name or
     column number. It expects that vov_option_value_parm contains the
     list of subtotal triplets. If the check proves successful,
     vov_option_value_parm is replaced with a list of triplets which has
     each column number replaced by the column name, and the optional
     third portion of a triplet filled in. A single blank separates each
     triplet in the new list.

*/
%skip(1);
dcl rslac_allow_duplicates_parm bit (1) aligned parm;
dcl rslac_blank_position fixed bin;
dcl rslac_code fixed bin (35);
dcl rslac_current_position fixed bin;
dcl rslac_original_option_value_length fixed bin;
dcl rslac_still_parsing bit (1) aligned;
%skip(1);
	if vov_option_value_parm = ""
	then return (OFF);
%skip(1);
          rslac_original_option_value =  ltrim (rtrim (translate
	     (vov_option_value_parm, BLANK, TAB))) || BLANK;
	rslac_original_option_value_length 
	     = length (rslac_original_option_value);
	rslac_result_option_value = "";
	rslac_current_position = 1;
	rslac_still_parsing = ON;
%skip(1);
	do while (rslac_still_parsing);
	     call get_triplet (rslac_code);
	     if rslac_code = 0
	     then call parse_triplet (rslac_allow_duplicates_parm, rslac_code);
	end;
%skip(1);
	if rslac_code ^= 0
	then return (OFF);
%skip(1);
	vov_option_value_parm = rtrim (rslac_result_option_value);
%skip(1);
	return (ON);
%page;
get_triplet: proc (gt_code_parm);
%skip(3);
dcl gt_code_parm fixed bin (35) parm;
dcl gt_still_skipping_blanks bit (1) aligned;
%skip(1);
	gt_code_parm = 0;
	rslac_blank_position 
	     = index (substr (rslac_original_option_value, 
	     rslac_current_position), BLANK);
	rslac_triplet = substr (rslac_original_option_value,
	     rslac_current_position, rslac_blank_position - 1);
	rslac_current_position 
	     = rslac_current_position + rslac_blank_position;
%skip(1);
	if rslac_current_position >= rslac_original_option_value_length
	then rslac_still_parsing = OFF;
	else do;
	     gt_still_skipping_blanks = ON;
	     do while (gt_still_skipping_blanks);
		if substr (rslac_original_option_value, 
		rslac_current_position, 1) = BLANK
		then rslac_current_position = rslac_current_position + 1;
		else gt_still_skipping_blanks = OFF;
	     end;
	end;
%skip(1);
	return;
%skip(1);
     end get_triplet;
%page;
parse_triplet: proc (
	pt_allow_duplicates_parm,	/* input: on means allow duplicate definitions,
				   a subtotal can also "watch" itself */
	 pt_code_parm		/* output: success or failure */
		);
%skip(3);
dcl pt_allow_duplicates_parm bit (1) aligned parm;
dcl pt_character_string char (80) varying;
dcl pt_code_parm fixed bin (35) parm;
dcl pt_column_number fixed bin;
dcl pt_comma_position fixed bin;
dcl pt_current_position fixed bin;
dcl pt_first_column_found fixed bin;
dcl pt_hit bit (1) aligned;
dcl pt_inner_loop fixed bin;
dcl pt_loop fixed bin;
dcl pt_second_column_found fixed bin;
dcl pt_triplet_length fixed bin;
%skip(1);
	pt_code_parm = 1;
	pt_triplet_length = length (rslac_triplet);
	pt_current_position = 1;
%skip(1);
	do pt_loop = 1 to 2;
	     pt_comma_position = index (substr (rslac_triplet, 
		pt_current_position), COMMA);
	     if pt_comma_position = 0
	     then if pt_loop = 1
		then return;
	          else pt_comma_position 
		     = pt_triplet_length + 2 - pt_current_position;
	     else;
	     pt_character_string = substr (rslac_triplet, 
		pt_current_position, pt_comma_position - 1);
	     pt_current_position = pt_current_position + pt_comma_position;
	     if pt_current_position > pt_triplet_length & pt_loop = 1
	     then return;
	     if verify (pt_character_string, DIGITS) = 0
	     then do;
		if convert (based_fixed_bin_71, pt_character_string) > LARGEST_FIXED_BIN_17_NUMBER
		then return;
		pt_column_number = convert (pt_column_number, pt_character_string);
		if pt_column_number < 1
		| pt_column_number > number_of_defined_columns
		then return;
		else;
		rslac_result_option_value
		     = rslac_result_option_value 
		     || table_info.columns.column_name (pt_column_number) || COMMA;
		if pt_loop = 1
		then pt_first_column_found = pt_column_number;
		else pt_second_column_found = pt_column_number;
	     end;
	     else do;
		pt_hit = OFF;
		do pt_inner_loop = 1 to number_of_defined_columns while (^pt_hit);
		     if pt_character_string 
		     = table_info.columns.column_name (pt_inner_loop)
		     then do;
			pt_hit = ON;
			pt_column_number = pt_inner_loop;
		     end;
		end;
		if ^pt_hit
		then return;
		else;
		if pt_loop = 1
		then pt_first_column_found = pt_column_number;
		else pt_second_column_found = pt_column_number;
		rslac_result_option_value
		     = rslac_result_option_value
		     || pt_character_string || COMMA;
	     end;
	end;
%skip(1);
	if ^pt_allow_duplicates_parm
	then if pt_first_column_found = pt_second_column_found
	     then return;
	     else;
	else;
%skip(1);
	if pt_current_position >= pt_triplet_length
	then rslac_result_option_value
	     = rslac_result_option_value || RESET || BLANK;
	else do;
	     pt_character_string = substr (rslac_triplet, 
		pt_current_position);
	     if pt_character_string = RESET
	     then rslac_result_option_value
		= rslac_result_option_value || RESET || BLANK;
	     else if pt_character_string = RUNNING
		then rslac_result_option_value
		     = rslac_result_option_value || RUNNING || BLANK;
	          else return;
	end;
%skip(1);
	pt_code_parm = 0;
%skip(1);
	return;
%skip(1);
     end parse_triplet;
%skip(1);
     end replace_subtotal_list_after_checking;
%skip(1);
     end valid_option_value;
%page;
%skip(1);
dcl ALL bit (1) aligned static int options (constant) init ("1"b);
dcl ALLOW_DUPLICATES bit (1) aligned static int options (constant) init ("1"b);
dcl ANY bit (1) aligned static int options (constant) init ("0"b);
%skip(1);
dcl BLANK char (1) static int options (constant) init (" ");
dcl BOTH char (4) static int options (constant) init ("both");
%skip(1);
dcl CENTER char (6) static int options (constant) init ("center");
dcl COMMA char (1) static int options (constant) init (",");
%skip(1);
dcl DECIMAL char (7) static int options (constant) init ("decimal");
dcl DIGITS char (10) static int options (constant) init ("0123456789");
dcl DONT_ALLOW_DUPLICATES bit (1) aligned static int options (constant) init ("0"b);
%skip(1);
dcl FILL char (4) static int options (constant) init ("fill");
%skip(1);
dcl LARGEST_FIXED_BIN_17_NUMBER fixed bin (21) internal static options (constant) init (131070);
dcl LEFT char (4) static int options (constant) init ("left");
dcl LEFT_BRACKET char (1) static int options (constant) init ("[");
%skip(1);
dcl NINE char (1) static int options (constant) init ("9");
%skip(1);
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
%skip(1);
dcl PERMANENT bit (36) aligned static int options (constant) init ("01"b);
%skip(1);
dcl RESET char (5) static int options (constant) init ("reset");
dcl RIGHT char (5) static int options (constant) init ("right");
dcl RUNNING char (7) static int options (constant) init ("running");
%skip(1);
dcl STAR_OR_QUESTION_MARK char (2) static int options (constant) init ("*?");
dcl STAR_DOT_STAR_STAR char (4) static int options (constant) init ("*.**");
%skip(1);
dcl TAB char (1) static int options (constant) init ("	");
dcl TILDE char (1) static int options (constant) init ("~");
dcl TRUNCATE char (8) static int options (constant) init ("truncate");
%skip(1);
dcl ZERO char (1) static int options (constant) init ("0");
%page;
dcl addr builtin;
dcl after builtin;
%skip(1);
dcl based_fixed_bin_71 fixed bin (71) based;
dcl before builtin;
%skip(1);
dcl caktc_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl cavgl_save_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl char builtin;
dcl code fixed bin (35);
dcl column_map (number_of_defined_columns) bit (1) based (column_map_ptr);
dcl column_map_ptr ptr;
dcl convert builtin;
dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
%skip(1);
dcl divide builtin;
%skip(1);
dcl error_table_$nomatch fixed bin(35) ext static;
dcl error_table_$nostars fixed bin(35) ext static;
dcl error_table_$oldnamerr fixed bin(35) ext static;
%skip(1);
dcl general_columns_names_and_values_info_ptr ptr;
dcl general_report_names_and_values_info_ptr ptr;
%skip(1);
dcl hbound builtin;
%skip(1);
dcl index builtin;
%skip(1);
dcl 1 judgement_table (number_of_defined_columns) aligned based (judgement_table_ptr),
      2 present bit (1),
      2 number fixed bin (35);
dcl judgement_table_ptr ptr;
%skip(1);
dcl length builtin;
dcl 1 like_name_value_info (no_of_active_names_and_values) based (like_names_and_values_info_ptr) like name_value_info;
dcl like_names_and_values_info_ptr ptr;
dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl ltrim builtin;
dcl lvswcd_option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl lvswcd_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl lvswcd_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl max builtin;
dcl me char (64);
%skip(1);
dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr);
dcl names_and_values_area_ptr ptr;
dcl names_and_values_bit_map (no_of_names_and_values_in_bit_map) bit (1) based (names_and_values_bit_map_ptr);
dcl names_and_values_bit_map_ptr ptr;
dcl names_and_values_temp_seg_ptr ptr;
dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
dcl no_of_active_names_and_values fixed bin;
dcl no_of_names_and_values_in_bit_map fixed bin;
dcl null builtin;
dcl number_of_defined_columns fixed bin;
%skip(1);
dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl option_table_index fixed bin;
dcl option_type fixed bin;
dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl returned_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl rclac_spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl rslac_original_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl rslac_result_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl rslac_triplet char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl rtrim builtin;
dcl rw_error_$bad_option_identifier fixed bin(35) ext static;
dcl rw_error_$bad_option_name fixed bin(35) ext static;
dcl rw_error_$bad_option_value fixed bin(35) ext static;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl match_star_name_ entry (char(*), char(*), fixed bin(35));
%skip(1);
dcl sci_ptr ptr;
dcl search builtin;
dcl specific_columns_names_and_values_info_ptr ptr;
dcl 1 star_name_info based (star_name_info_ptr),
      2 maximum_number_of_star_names fixed bin,
      2 number_of_star_names fixed bin,
      2 star_name_map (maximum_number_of_star_names) bit (1),
      2 column_maps_info (number_of_star_names),
        3 number_of_matches fixed bin,
        3 column_bit_map (number_of_defined_columns) bit (1);
dcl star_name_info_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl substr builtin;
dcl sv_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl sv_spare_option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl sv_spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl sys_info$max_seg_size fixed bin(35) ext static;
dcl system_default bit (1) aligned;
%skip(1);
dcl translate builtin;
%skip(1);
dcl unspec builtin;
%skip(1);
dcl valid_select bit (1) aligned;
dcl value_seg_ptr ptr;
dcl value_$delete entry (ptr, bit(36) aligned, char(*), fixed bin(35));
dcl value_$get entry() options(variable);
dcl value_$list entry (ptr, bit(36) aligned, ptr, ptr, ptr, fixed bin(35));
dcl value_$set entry() options(variable);
dcl verify builtin;
%skip(1);
%page;
%include access_mode_values;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include rw_format_options;
%page;
%include rw_names_and_values;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_table_info;
%page;
%include rw_table_control_info;
%page;
%include status_structures;
%page;
%include value_structures;
%skip(3);
     end rw_options;




		    rw_requests.pl1                 11/16/84  1356.2rew 11/16/84  1354.5       94806



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This procedure is called by ssu_ whenever any of the report writer
     requests are invoked by the user. They are: column_value, display,
     display_builtins, list_format_options, restore_format_options,
     save_format_options, and set_format_options. This procedure is called
     with a pointer to the ssu_ info structure and a pointer to the
     subsystem's info structure. It obtains the pointer to the 
     report_control_info structure and then calls down to the appropriate
     report writer subroutine to have the request executed, passing along
     the report_control_info pointer. The names and values area is refreshed
     before execution of some of the requests (the ones that use it), rather
     than freeing everything allocated in it.

     It also provides the miscellaneous functions of: setting the initial
     report_writer_ info pointer in internal static when a report_writer_
     invocation is first created; replaces the current report_writer_ info
     pointer for the calling subsystem with a newly provided one, when the
     calling subsystem wants to multiplex several report_writer_ invocations
     within one subsystem invocation; and, removing the report_writer_ info
     pointer from internal static.

     The following entrypoints are provided:

     column_value           | These entrypoints are called by ssu_ whenever: a
     display	        | user at the terminal types one of these request
     display_builtins       | names; or, the calling subsystem calls ssu_
     list_format_options    | execute_line, execute_string, or
     restore_format_options | evaluate_active_string with one of these request
     save_format_options    | names as an argument.
     set_format_options     |

     delete_report_info_pointer  | This entrypoint is called to remove the
			   | report_writer_ info pointer from internal
			   | static storage.

     set_initial_report_info_ptr | This entrypoint is called to place the
			   | report_writer_ info pointer into internal
			   | static when a report_writer_ invocation is
			   | first created.

     set_report_writer_info_ptr  | This entrypoint is called to replace the
			   | existing report_writer_ info pointer with
			   | a caller provided one. The next time a
			   | standard report_writer_ request is invoked,
			   | it will get this new one.

     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - October 1984.

*/
%page;
rw_requests: proc;
%skip(3);
/* These parameters are described at each entry where they are used. */
%skip(3);
dcl code_parm fixed bin (35) parm;
dcl message_parm char (*) varying parm;
dcl report_writer_info_ptr_parm ptr parm;
dcl sci_ptr_parm ptr parm;
dcl subsystems_info_ptr_parm ptr parm;
%skip(3);
	call com_err_ (error_table_$badcall, "rw_requests");
%skip(1);
	return;
%page;
column_value: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
	         );
%skip(3);
	call load_report_control_info_ptr (DONT_REFRESH_THE_AREA);
	call rw_column_value (sci_ptr, report_cip);
%skip(1);
	return;
%page;
delete_report_info_ptr: entry (

	sci_ptr_parm	         /* input: ssu_ info pointer */
			    );
%skip(1);
dcl drip_loop fixed bin;
dcl drip_pointer_number fixed bin;
%skip(1);
	sci_ptr = sci_ptr_parm;
	drip_pointer_number = 0;
%skip(1);
	do drip_loop = 1 to report_writer_info.number_of_pointers
	     while (drip_pointer_number = 0);
	     if sci_ptr = report_writer_info.pointers (drip_loop).ssu
	     then drip_pointer_number = drip_loop;
	end;
%skip(1);
	if drip_pointer_number = 0
	then call ssu_$abort_line (sci_ptr, error_table_$fatal_error,
	     "^/Unable to delete the report writer info pointer.");
	report_writer_info.number_of_pointers
	     = report_writer_info.number_of_pointers - 1;
	if drip_pointer_number = report_writer_info.number_of_pointers + 1
	then return;
%skip(1);
	do drip_loop = drip_pointer_number to report_writer_info.number_of_pointers;
	     report_writer_info.pointers (drip_loop).ssu
		= report_writer_info.pointers (drip_loop + 1).ssu;
	     report_writer_info.pointers (drip_loop).report_writer
		= report_writer_info.pointers (drip_loop + 1).report_writer;
	end;
%skip(1);
	return;
%page;
display: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
	    );
%skip(3);
	call load_report_control_info_ptr (DONT_REFRESH_THE_AREA);
	call rw_display (sci_ptr, report_cip);
%skip(1);
	return;
%page;
display_builtins: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
		   );
%skip(3);
	call load_report_control_info_ptr (DONT_REFRESH_THE_AREA);
	call rw_display_builtins (sci_ptr, report_cip);
%skip(1);
	return;
%page;
list_format_options: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
		      );
%skip(3);
	call load_report_control_info_ptr (REFRESH_THE_AREA);
	call rw_list_format_options (sci_ptr, report_cip);
%skip(1);
	return;
%page;
restore_format_options: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
		         );
%skip(3);
	call load_report_control_info_ptr (DONT_REFRESH_THE_AREA);
	call rw_restore_format_options (sci_ptr, report_cip);
%skip(1);
	return;
%page;
save_format_options: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
		      );
%skip(3);
	call load_report_control_info_ptr (REFRESH_THE_AREA);
	call rw_save_format_options (sci_ptr, report_cip);
%skip(1);
	return;
%page;
set_initial_report_info_ptr: entry (

	sci_ptr_parm,	         /* input: ssu_ info pointer */
	report_writer_info_ptr_parm, /* input: points to report_control_info structure */
	code_parm		    /* output: success or failure */
			    );
%skip(1);
	if report_writer_info.number_of_pointers + 1
	> hbound (report_writer_info.pointers, 1)
	then do;
	     code_parm = error_table_$fatal_error;
	     return;
	end;
	else code_parm = 0;
	report_writer_info.pointers (report_writer_info.number_of_pointers + 1).ssu
	     = sci_ptr_parm;
	report_writer_info.pointers (report_writer_info.number_of_pointers + 1).report_writer
	     = report_writer_info_ptr_parm;
	report_writer_info.number_of_pointers = report_writer_info.number_of_pointers + 1;
%skip(1);
	return;
%page;
set_format_options: entry (

	sci_ptr_parm,	         /* input: ptr to the ssu_ info structure */
	subsystems_info_ptr_parm     /* input: ptr to the subsystems info */
		     );
%skip(3);
	call load_report_control_info_ptr (REFRESH_THE_AREA);
	call rw_set_format_options (sci_ptr, report_cip);
%skip(1);
	return;
%page;
set_report_writer_info_ptr: entry (

	report_writer_info_ptr_parm, /* input: points to report_control_info structure */
	sci_ptr_parm,	         /* input: ssu_ info pointer */
	code_parm,	         /* output: success or failure */
	message_parm	         /* output: reason for the failure */
			    );
%skip(1);
dcl srwip_loop fixed bin;
%skip(1);
	code_parm = 0;
	message_parm = "";
%skip(1);
	do srwip_loop = 1 to report_writer_info.number_of_pointers;
	     if report_writer_info.pointers (srwip_loop).ssu = sci_ptr_parm
	     then do;
		report_writer_info.pointers (srwip_loop).report_writer
		     = report_writer_info_ptr_parm;
		return;
	     end;
	end;
%skip(1);
	code_parm = rw_error_$no_ssu_ptr_match;
	message_parm = "^/The current report_writer_ info pointer will be retained.";
%skip(1);
	return;
%page;
load_report_control_info_ptr: proc (

	lrcip_refresh_the_area_parm /* input: ON means to refresh the area */
	);
%skip(1);
dcl lrcip_loop fixed bin;
dcl lrcip_not_found bit (1) aligned;
dcl lrcip_refresh_the_area_parm bit (1) aligned parm;
%skip(1);
	sci_ptr = sci_ptr_parm;
%skip(1);
	lrcip_not_found = "1"b;
	do lrcip_loop = 1 to report_writer_info.number_of_pointers
	     while (lrcip_not_found);
	     if report_writer_info.pointers (lrcip_loop).ssu = sci_ptr
	     then do;
		report_cip = report_writer_info.pointers (lrcip_loop).report_writer;
		lrcip_not_found = "0"b;
	     end;
	end;
	if lrcip_not_found
	then call ssu_$abort_line (sci_ptr, rw_error_$logic_error,
	     "^/Unable to find the report writer info pointer for the request.");
%skip(1);
	if lrcip_refresh_the_area_parm
	then do;
	     call ssu_$release_area (sci_ptr, report_control_info.name_value_area_ptr);
	     call ssu_$get_area (sci_ptr, report_control_info.area_info_ptr,
		"rw_.names_and_values_area", report_control_info.name_value_area_ptr);
	end;
%skip(1);
	return;
%skip(1);
     end load_report_control_info_ptr;
%page;
dcl DONT_REFRESH_THE_AREA bit (1) aligned internal static options (constant) init ("0"b);
%skip(1);
dcl REFRESH_THE_AREA bit (1) aligned internal static options (constant) init ("1"b);
%skip(1);
dcl com_err_ entry() options(variable);
%skip(1);
dcl error_table_$badcall fixed bin(35) ext static;
dcl error_table_$fatal_error fixed bin(35) ext static;
%skip(1);
dcl hbound builtin;
%skip(1);
dcl names_and_values_area_ptr ptr;
dcl null builtin;
%skip(1);
dcl 1 report_writer_info aligned internal static,
      2 number_of_pointers fixed bin init (0),
      2 pointers (512),
        3 ssu ptr,
        3 report_writer ptr;
dcl rw_column_value entry (ptr, ptr);
dcl rw_display entry (ptr, ptr);
dcl rw_display_builtins entry (ptr, ptr);
dcl rw_error_$logic_error fixed bin(35) ext static;
dcl rw_error_$no_ssu_ptr_match fixed bin(35) ext static;
dcl rw_list_format_options entry (ptr, ptr);
dcl rw_restore_format_options entry (ptr, ptr);
dcl rw_save_format_options entry (ptr, ptr);
dcl rw_set_format_options entry (ptr, ptr);
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$get_area entry (ptr, ptr, char(*), ptr);
dcl ssu_$release_area entry (ptr, ptr);
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%skip(3);
     end rw_requests;




		    rw_restore_format_options.pl1   11/16/84  1356.2rew 11/16/84  1354.5       34317



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the main level procedure called by ssu_ to implement the
     report_writer_ restore_format_options request. Description and usage
     follows.

     Description:

     This request takes the pathname given as input and calls the
     ssu_$execute_string entrypoint to do a subsystem exec_com
     on the user specified file.
     
     Usage: "restore_format_options path"

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_restore_format_options: proc (

	sci_ptr_parm,    /* ptr to the subsystem control info structure */
	report_cip_parm  /* points to report_control_info */
			  );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
/*
          Mainline Processing Overview.

          (1) Get and expand/suffix the pathname arg.

	(2) Make sure the file exists.

          (3) Get ssu_ to do a subsystem ec on the file.
*/
%page;
%skip(3);
	report_cip = report_cip_parm;
	sci_ptr = sci_ptr_parm;
%skip(1);
          /* The first and only arg must be pathname. */
%skip(1);
	call ssu_$arg_count (sci_ptr, number_of_args_supplied);
%skip(1);
	if number_of_args_supplied ^= 1 
	then do;
	     if number_of_args_supplied = 0
	     then code = error_table_$noarg;
	     else code = error_table_$inconsistent;
	     call ssu_$abort_line (sci_ptr, code,
		"^/Usage: restore_format_options path");
	end;
%skip(1);
          call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length);
	pathname = arg;
          call expand_pathname_$add_suffix (pathname,
	     "fo." || rtrim (ltrim (report_control_info.subsystems_ec_suffix)),
	     dir_name, entry_name, code);
	if code ^= 0 
	then call ssu_$abort_line (sci_ptr, code,
	     "^/The pathname ^a couldn't be expanded.", pathname);
%skip(1);
	call hcs_$status_minf (dir_name, entry_name, 1, file_type, 
	     bit_count, code);
	if code = error_table_$noentry
	then call ssu_$abort_line (sci_ptr, code,
	     "^/The file ^a doesn't exist.",
	     rtrim (dir_name) || ">" || rtrim (entry_name));
%skip(1);
	call ssu_$execute_string (sci_ptr, "ec " || rtrim (dir_name) 
	     || ">" || rtrim (entry_name), code);
%skip(1);
          return;
%page;
%skip(1);
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl bit_count fixed bin (24);
%skip(1);
dcl code fixed bin (35);
%skip(1);
dcl dir_name char (168);
%skip(1);
dcl entry_name char (32);
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$noarg fixed bin(35) ext static;
dcl error_table_$noentry fixed bin(35) ext static;
dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
%skip(1);
dcl file_type fixed bin (2);
%skip(1);
dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
%skip(1);
dcl ltrim builtin;
%skip(1);
dcl null builtin;
dcl number_of_args_supplied fixed bin;
%skip(1);
dcl pathname char (168);
%skip(1);
dcl rtrim builtin;
%skip(1);
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_count entry (ptr, fixed bin);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl ssu_$execute_string entry (ptr, char(*), fixed bin(35));
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%skip(3);
     end rw_restore_format_options;




		    rw_save_format_options.pl1      11/16/84  1356.2rew 11/16/84  1354.5      222408



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*   This is the main level procedure called by ssu_ to implement the
     report_writer_ save_format_options request. Description and usage follows.

     Description:

     This request does EITHER 1, 2 or 3 listed below.
     
     1) Saves the ACTIVE option names and values.

     2) Saves ALL the option names and values.

     3) Saves USER SPECIFIED option names and values.
     
     Usage (1): "svfo path {-query}" or
                "svfo path {-query} -active"

     Only the active option names and values are saved to the
     file specifed by path. The query is optionally saved
     also.

     Usage (2): "svfo path {-query} -all"

     All of the formatting option names and values are saved to
     the file specifed by path. The query is optionally saved
     also.

     Usage (3): "svfo path {-query} -format_option_args"

     Where -format_option_args are the names of the formatting options whose
     values are to be saved to the file specifed by path. The query
     is optionally saved also.

     The formatting option names and values are saved to the file as an
     exec_com. The counterpart to this request, restore_format_options, does a
     subsystem exec_com on this file to accomplish the restoring.

     The old control argument of -selection_expression | -se is still accepted
     but not documented.

     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_save_format_options: proc (

	sci_ptr_parm,    /* ptr to the subsystem control info structure */
	report_cip_parm  /* points to report_control_info */
		         );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
/*
          Mainline Processing Overview.

          (1) Determine requested usage.

          (2) Write the exec_com header and optionally the query.

          (3) Get the option names and values. Either all of them, the
	    active ones, or user provided ones.

          (4) Write the option names and values.

          (5) Write the exec_com footer.
*/
%page;
%skip(3);
	file_needs_terminating = OFF;
	query_segment_ptr = null;
	cleanup_signalled = OFF;
%skip(1);
          on cleanup begin;
	     cleanup_signalled = ON;
	     call terminate;
	end;
%skip(1);
	call initialize;
          call write_exec_com_header;
%skip(1);
          if usage_1
	then call rw_options$get_active (report_cip,
	     names_and_values_info_ptr, no_of_names_and_values,
	     names_and_values_ptr, size_of_names_and_values, code);
	else if usage_2
	     then call rw_options$get_all (report_cip,
	          names_and_values_info_ptr, no_of_names_and_values,
	          names_and_values_ptr, size_of_names_and_values, code);
	     else do;
		call get_user_specified_option_names;
		call rw_options$get_named (report_cip, 
		     option_name_table_ptr, no_of_options_in_name_table,
		     names_and_values_info_ptr, no_of_names_and_values,
		     names_and_values_ptr, size_of_names_and_values, code);
	     end;
%skip(1);
	if code ^= 0 
	then call ssu_$abort_line (sci_ptr, code);
%skip(1);
          call write_the_names_and_values;
	call write_exec_com_footer;
	call terminate;
%skip(1);
          return;
%page;
get_user_specified_option_names: proc;
%skip(3);
/*
	Load up the table with format option names and identifiers. The
	variable number_of_format_option_names has been set back in the
	initialize procedure when the first pass through the control args
	was made. If the format option names and identifiers were specified
	correctly then the table will be the exact size needed. If they
	were incorrectly specified it will be diagnosed here before the
	table can overflow.
*/
%skip(1);
          names_and_values_area_ptr = report_control_info.name_value_area_ptr;
	no_of_options_in_name_table = number_of_format_option_names;
%skip(1);
	allocate option_name_table in (names_and_values_area)
	     set (option_name_table_ptr);
%skip(1);
	current_arg = 2;
          call get_next_format_option_arg (code);
          if code = NO_MORE_FORMAT_OPTION_ARGS
          then call ssu_$abort_line (sci_ptr, 0,
	     "Logic error while processing the format option arguments.");
%skip(1);
          still_processing_args = ON;
	loop = 1;
%skip(1);
          do while (still_processing_args);
%skip(1);
	     option_name = arg;
	     call rw_options$check_name (report_cip, option_name,
		long_option_name, identifier_needed, code);
	     if code ^= 0
	     then if code = rw_error_$bad_option_name
		then call ssu_$abort_line (sci_ptr, code,
		     "^/^a is not a valid option name.", option_name);
	          else if code = rw_error_$no_columns_defined
		     then call ssu_$abort_line (sci_ptr, code,
		          "^/There must be columns defined before the value of ^a can be saved.",
		          long_option_name);
		     else call ssu_$abort_line (sci_ptr, code);
	     else;
	     option_name_table.the_name (loop) = long_option_name;
%skip(1);
	     if identifier_needed
	     then do;
		call get_next_format_option_arg (code);
		if code = NO_MORE_FORMAT_OPTION_ARGS
		then call ssu_$abort_line (sci_ptr, 0,
		     "The option name ^a was not followed by an identifier.",
		     option_name);
		else option_name_table.the_identifier (loop) = arg;
		call rw_options$check_identifier (report_cip,
		     option_name_table.the_name (loop), 
		     option_name_table.the_identifier (loop),
		     normalized_option_name, code);
		if code ^= 0
		then if code = rw_error_$bad_option_identifier
		     then call ssu_$abort_line (sci_ptr, code,
		          "^/^a is not a valid column identifier for ^a.",
		          option_name_table.the_identifier (loop),
		          option_name_table.the_name (loop));
		     else if code ^= error_table_$nostars
			then call ssu_$abort_line (sci_ptr, code);
		          else;
		else;
	     end;
	     else option_name_table.the_identifier (loop) = "";
%skip(1);
	     loop = loop + 1;
	     call get_next_format_option_arg (code);
	     if code = NO_MORE_FORMAT_OPTION_ARGS
	     then still_processing_args = OFF;
%skip(1);
	     if still_processing_args
	     then if loop
		> no_of_options_in_name_table
		then call ssu_$abort_line (sci_ptr, 0,
		     "A format option name or column identifier was incorrectly specified.");
	          else;
	     else;
%skip(1);
	end;
%skip(1);
	return;
%page;
get_next_format_option_arg: proc (code_parm);
%skip(3);
/*
	Skip over the control args and get to the format option arg. Set
	code if there isn't any left.
*/
%skip(1);
dcl code_parm fixed bin (35) parm;
%skip(1);
	code_parm = 0;
%skip(1);
	do while (this_is_a_control_arg (current_arg));
	     current_arg = current_arg + 1;
	end;
%skip(1);
	if current_arg > no_of_args_supplied
	then do;
	     code_parm = NO_MORE_FORMAT_OPTION_ARGS;
	     return;
	end;
%skip(1);
          call ssu_$arg_ptr (sci_ptr, current_arg, arg_ptr, arg_length);
	current_arg = current_arg + 1;
%skip(1);
	return;
%skip(1);
     end get_next_format_option_arg;
%skip(1);
     end get_user_specified_option_names;
%page;
initialize: proc;
%skip(3);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
          usage_1 = OFF;
	usage_2 = OFF;
	usage_3 = OFF;
%skip(1);
	query_statement_flag = OFF;
	unspec (this_is_a_control_arg) = OFF;
	number_of_control_args_found = 0;
%skip(1);
/* 

          If no args are given then it is an error.  The first arg must be
          pathname.  If no additional args are given then usage (1) has been
          requested.  If "-active" is given, then usage (1) has been
          requested by explicitely stating the default.  If -active and -all
          are given the last one supplied is used.  -active and -all cannot
          be used with the format_option_args.  If -all is used correctly
          then usage (2) has been requested.  If -active and -all are not
          found, then usage (3) is assumed, and invalid option names are
          reported as they are encountered.

*/
%skip(1);
	call ssu_$arg_count (sci_ptr, no_of_args_supplied);
%skip(1);
	if no_of_args_supplied = 0
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
	     "^/Usage: save_format_options path {-format_options_args} {-control_args}.");
          else;
%skip(1);
          /* Get the mandatory, positional pathname argument. */
%skip(1);
          call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length);
	pathname = arg;
%page;
/* 
	Determine which usage was intended and count the number of
          user supplied format option names so the table 
          to hold them can be allocated. 
*/
%skip(1);
          number_of_format_option_names = 0;
          if no_of_args_supplied = 1
	then usage_1 = ON;
          else do loop = 2 to no_of_args_supplied;
	     call ssu_$arg_ptr (sci_ptr, loop, arg_ptr, arg_length);
	     if arg = "-all" | arg = "-a" 
	     | arg = "-active" | arg = "-act"
	     | arg = "-selection_expression" | arg = "-se" | arg = "-query"
	     then do;
		this_is_a_control_arg (loop) = ON;
		number_of_control_args_found 
		     = number_of_control_args_found + 1;
		if arg = "-all" | arg = "-a"
		then do;
		     usage_2 = ON;
		     usage_1 = OFF;
		end;
		else if arg = "-active" | arg = "-act"
		     then do;
			usage_1 = ON;
			usage_2 = OFF;
		     end;
		     else query_statement_flag = ON;
	     end;
	     else do;
		usage_3 = ON;
		if substr (arg, 1, 1) = "-"
		then number_of_format_option_names
		     = number_of_format_option_names + 1;
		else;
	     end;
	end;
%skip(1);
	if ^usage_1 & ^usage_2 & ^usage_3
	then usage_1 = ON;
%skip(1);
          /* Check for inconsistent combinations of control args. */
%skip(1);
	if (usage_3 & (usage_1 | usage_2))
	| ((usage_1 | usage_2) & (number_of_format_option_names > 0))
	then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	     "^/When ^[-all^;-active^] is used no format option args can be specified.",
	     fixed (usage_1 || usage_2));
	else if usage_3 & number_of_format_option_names ^> 0
               then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	          "^/At least one format option name must be specified.");
	     else;
%skip(1);
          /* Make sure a query statement is available if the user 
             asked for it to be saved with the file. */
%skip(1);
	table_ip = report_control_info.table_information_ptr;
          if query_statement_flag & table_ip = null
	then call ssu_$abort_line (sci_ptr, rw_error_$no_columns_defined,
	     "^/The format was not saved.");
%skip(1);
          /* Ready the file, truncate it if it exists. */
%skip(1);
          call expand_pathname_$add_suffix (pathname,
	     "fo." || rtrim (ltrim (report_control_info.subsystems_ec_suffix)),
	     dir_name, entry_name, code);
	if code ^= 0 
	then call ssu_$abort_line (sci_ptr, code,
	     "^/While trying to expand ^a.", pathname);
%skip(1);
          switch_name = unique_chars_ ("0"b) || ".rw_svfo";
%skip(1);
          call iox_$attach_name (switch_name, iocb_ptr, 
	     "vfile_ " || rtrim (dir_name) || ">" || entry_name, null (), code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^/While trying to attach ^a.", pathname);
	file_needs_terminating = ON;
	call iox_$open (iocb_ptr, Stream_output, "0"b, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^/While trying to open ^a.", pathname);
%skip(1);
	if query_statement_flag
	then call ssu_$get_temp_segment (sci_ptr, "query segment", query_segment_ptr);
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
terminate: proc;
%skip(3);
          if file_needs_terminating
	then do;
	     call iox_$close (iocb_ptr, code);
	     call iox_$detach_iocb (iocb_ptr, code);
	     call iox_$destroy_iocb (iocb_ptr, code);
	     if cleanup_signalled
	     then call delete_$path (dir_name, entry_name, "100111"b,
		ME, code);
	end;
%skip(1);
	if query_segment_ptr ^= null
	then call ssu_$release_temp_segment (sci_ptr, query_segment_ptr);
%skip(1);
          return;
%skip(1);
     end terminate;
%page;
write_exec_com_footer: proc;
%skip(3);
          call ioa_$ioa_switch (iocb_ptr, "&detach^/&quit");
%skip(1);
	return;
%skip(1);
     end write_exec_com_footer;
%page;
write_exec_com_header: proc;
%skip(3);
          /* First the necessary exec_com statements. */
%skip(1);
          call ioa_$ioa_switch (iocb_ptr,
	     "&version 2^/&trace off^/&attach");
%skip(1);
          /* Then the query statement if requested. */
%skip(1);
          if ^query_statement_flag
	then return;
%skip(1);
	call rw_table_manager$get_query (report_cip,
	     query_segment_ptr, query_segment_length, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code,
	     "^/Unable to save the query statement.");
%skip(1);
	query_segment_current_position = 1;
	still_processing_query_lines = ON;
%skip(1);
	do while (still_processing_query_lines);
	     query_segment_newline_index = index (substr (query_segment,
		query_segment_current_position), NEWLINE);
	     if query_segment_newline_index = 0
	     then call ssu_$abort_line (sci_ptr, 0,
		"Logic error while trying to save the query statement.");
	     ampersand_position = index (substr (query_segment,
		query_segment_current_position, query_segment_newline_index), AMPERSAND);
	     if ampersand_position = 0
	     then call ioa_$ioa_switch (iocb_ptr, "^a", substr (query_segment,
		query_segment_current_position, query_segment_newline_index - 1));
	     else do;
		line_buffer = substr (query_segment, query_segment_current_position, query_segment_newline_index - 1);
		starting_position = 1;
		still_quoting_ampersands = ON;
		do while (still_quoting_ampersands);
		     line_buffer = substr (line_buffer,
			1, ampersand_position - 1)
			|| AMPERSAND || substr (line_buffer, ampersand_position);
		     starting_position = ampersand_position + 2;
		     if starting_position ^> length (line_buffer)
		     then do;
			ampersand_position = index (substr 
			     (line_buffer, starting_position), AMPERSAND);
			if ampersand_position = 0
			then still_quoting_ampersands = OFF;
			else ampersand_position 
			     = ampersand_position + starting_position - 1;
		     end;
		     else still_quoting_ampersands = OFF;
		end;
		call ioa_$ioa_switch (iocb_ptr, "^a", line_buffer);
	     end;
	     query_segment_current_position = query_segment_current_position
		+ query_segment_newline_index;
	     if query_segment_current_position > query_segment_length
	     then still_processing_query_lines = OFF;
	     else;
	end;
%skip(1);
	return;
%skip(1);
     end write_exec_com_header;
%page;
write_the_names_and_values: proc;
%skip(3);
/*
	If the rw_options$get_active entry was called there may not be
	any format option values to save.
*/ 
%skip(1);
          if no_of_names_and_values = 0
	then call ssu_$abort_line (sci_ptr, 0, "^/^a^/^a",
	     "All of the formatting options are set to their default values.",
	     "There are no column options defined. The format was not saved.");
%skip(1);
/*

	Loop through the names and values writing them out to the exec_com
	file as report writer set_format_options requests.  The values must
	be special cased in the following way.  Version 2 exec_com strips
	leading and trailing whitespace, so it must be protected.  Version 2
	ec also barfs if the value contains an ampersand, so they must be
	protected.  The ssu_ request processor does quote stripping, active
	function evaluation, etc.  so all of these things must be protected.
	The set_format_options request has a number of control args it takes,
	so if the value is the same as any of these control args it must be
	protected.  If the value is a zero length character string then it
	must be translated to the request language zero length string "".
	And finally, single line values do not have a trailing newline
	character, so if it is going to be protected for any of the previous
	reasons, it must have a newline added.

*/
%skip(1);
          do loop = 1 to no_of_names_and_values;
%skip(1);
               normalized_option_name = substr (names_and_values,
		name_value_info.name.index (loop), 
		name_value_info.name.length (loop));
%skip(1);
	     option_value = substr (names_and_values, 
		name_value_info.value.index (loop), 
		name_value_info.value.length (loop));
%skip(1);
               special_characters_in_option_value = OFF;
	     newline_needed = OFF;
	     requoting_needed = OFF;
%skip(1);
	     option_value_length = length (option_value);
	     if option_value_length = 0
	     then do;
		option_value = """""";
		option_value_length = 2;
	     end;
	     else do;
		if substr (option_value, option_value_length) ^= NEWLINE
		then newline_needed = ON;
		else;
		if search (option_value, SPECIAL_CHARACTERS) ^= 0
		then special_characters_in_option_value = ON;
		else;
		if substr (option_value, 1, 1) = "-"
		then if option_value = "-reset" | option_value = "-rs"
		     | option_value = "-no_reset" | option_value = "-nrs"
		     | option_value = "-long" | option_value = "-lg"
		     | option_value = "-brief" | option_value = "-bf"
		     | option_value = "-prompt" | option_value = "-default"
		     then special_characters_in_option_value = ON;
		     else;
		else;
		if search (option_value, AMPERSAND_BLANK_OR_TAB) ^= 0
		then requoting_needed = ON;
		else;
	     end;
%skip(1);
/* 

	Do special exec_com quoting first.  Handle the easiest case first,
	when it is just a one line value that needs a newline character after
	exec_com quotes are added.  Values which are several lines long
	must be quoted separately, as quoted strings that contain a
	newline are not legal exec_com statements.

*/
%skip(1);
               if requoting_needed
	     then do;
		if newline_needed
		then option_value = AMPERSAND || requote_string_
		     (substr (option_value, 1)) || NEWLINE;
		else do;
		     spare_option_value = "";
		     still_creating_lines = ON;
		     starting_position = 1;
		     do while (still_creating_lines);
			newline_position = index (substr (option_value, 
			     starting_position), NEWLINE);
			if newline_position ^= 0
			then do;
			     line_buffer = substr (option_value, 
				starting_position, newline_position - 1);
			     spare_option_value = spare_option_value || AMPERSAND
				|| requote_string_ (substr (line_buffer, 1)) || NEWLINE;
			     starting_position = starting_position + newline_position;
			     if starting_position > option_value_length
			     then still_creating_lines = OFF;
			end;
			else do;
			     spare_option_value = spare_option_value || AMPERSAND
				|| requote_string_ (substr (option_value, 
				starting_position)) || NEWLINE;
			     still_creating_lines = OFF;
			end;
		     end;
		     option_value = spare_option_value;
		end;
	     end;
	     else if newline_needed & special_characters_in_option_value
		then option_value = option_value || NEWLINE;
	          else;
%skip(1);
	     if special_characters_in_option_value
	     then call ioa_$ioa_switch (iocb_ptr, "^a^x^a^x^a^/^a^a", 
		"set_format_options", normalized_option_name, 
		"-prompt -brief", option_value, ".");
	     else call ioa_$ioa_switch (iocb_ptr, "^a^x^a^x^a",
		"set_format_options", normalized_option_name, option_value);
%skip(1);
	end;
%skip(1);
          return;
%skip(1);          
   end write_the_names_and_values;
%page;
dcl AMPERSAND char (1) static int options (constant) init ("&");
dcl AMPERSAND_BLANK_OR_TAB char (3) static int options (constant) init ("& 	");
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
dcl ME char (19) static int options (constant) init ("save_format_options");
dcl NEWLINE char (1) static int options (constant) init ("
");
dcl NO_MORE_FORMAT_OPTION_ARGS fixed bin (35) static int options (constant) init (1);
/* SPECIAL_CHARACTERS are blank, tab, left and right bracket, left and right paraen, ampersand, quote, and newline */
dcl SPECIAL_CHARACTERS char (9) static int options (constant) init (
" 	[]()&""
");
%skip(1);
dcl ampersand_position fixed bin;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl cleanup condition;
dcl cleanup_signalled bit (1) aligned;
dcl code fixed bin (35);
dcl current_arg fixed bin;
%skip(1);
dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35));
dcl dir_name char (168);
%skip(1);
dcl entry_name char (32);
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$noarg fixed bin(35) ext static;
dcl error_table_$nostars fixed bin(35) ext static;
dcl expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
%skip(1);
dcl file_needs_terminating bit (1) aligned;
dcl fixed builtin;
%skip(1);
dcl identifier_needed bit (1) aligned;
dcl index builtin;
dcl ioa_$ioa_switch entry() options(variable);
dcl iocb_ptr ptr;
dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35));
dcl iox_$close entry (ptr, fixed bin(35));
dcl iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl iox_$detach_iocb entry (ptr, fixed bin(35));
dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35));
%skip(1);
dcl length builtin;
dcl line_buffer char (4096) varying;
dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl loop fixed bin;
dcl ltrim builtin;
%skip(1);
dcl names_and_values_area area (sys_info$max_seg_size) based (names_and_values_area_ptr);
dcl names_and_values_area_ptr ptr;
dcl newline_needed bit (1) aligned;
dcl newline_position fixed bin;
dcl no_of_args_supplied fixed bin;
dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
dcl number_of_control_args_found fixed bin;
dcl number_of_format_option_names fixed bin;
dcl null builtin;
%skip(1);
dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl option_value_length fixed bin;
%skip(1);
dcl pathname char (168);
%skip(1);
dcl query_segment char (query_segment_length) based (query_segment_ptr);
dcl query_segment_current_position fixed bin (21);
dcl query_segment_length fixed bin (21);
dcl query_segment_newline_index fixed bin (21);
dcl query_segment_ptr ptr;
dcl query_statement_flag bit (1) aligned;
%skip(1);
dcl requote_string_ entry (char(*)) returns(char(*));
dcl requoting_needed bit (1) aligned;
dcl rtrim builtin;
dcl rw_error_$bad_option_identifier fixed bin(35) ext static;
dcl rw_error_$bad_option_name fixed bin(35) ext static;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl rw_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35));
dcl rw_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35));
dcl rw_options$get_active entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
dcl rw_options$get_all entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
dcl rw_options$get_named entry (ptr, ptr, fixed bin(21), ptr, fixed bin(21), ptr, fixed bin(21),	fixed bin(35));
dcl rw_table_manager$get_query entry (ptr, ptr, fixed bin (21), fixed bin (35));
%skip(1);
dcl sci_ptr ptr;
dcl search builtin;
dcl spare_option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
dcl special_characters_in_option_value bit (1) aligned;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_count entry (ptr, fixed bin);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl ssu_$get_temp_segment entry (ptr, char(*), ptr);
dcl ssu_$release_temp_segment entry (ptr, ptr);
dcl starting_position fixed bin;
dcl still_creating_lines bit (1) aligned;
dcl still_processing_args bit (1) aligned;
dcl still_quoting_ampersands bit (1) aligned;
dcl still_processing_query_lines bit (1) aligned;
dcl substr builtin;
dcl switch_name char (32);
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl this_is_a_control_arg (360) bit (1) unaligned;
%skip(1);
dcl unique_chars_ entry (bit(*)) returns(char(15));
dcl unspec builtin;
dcl usage_1 bit (1) aligned;
dcl usage_2 bit (1) aligned;
dcl usage_3 bit (1) aligned;
%page;
%include arg_descriptor;
%page;
%include arg_list;
%page;
%include iox_modes;
%page;
%include rw_names_and_values;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_table_info;
%page;
     end rw_save_format_options;




		    rw_set_format_options.pl1       11/16/84  1356.3rew 11/16/84  1354.5      149940



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(3);
/*

     This is the main level procedure called to implement the
     report_writer_ set_format_options request.  Description and usage follows.

     Description:

     This request does one or more of the following actions.
     
     1) Sets INDIVIDUAL formatting option values to USER SPECIFIED
     VALUES.

     2) Sets INDIVIDUAL formatting option values to SYSTEM DEFAULTS.

     3) Sets ALL of the formatting option values to SYSTEM DEFAULTS.
     
     Usage:

     set_format_options {-format_option_args} {-control_args}


     Both parameters are passed to this request by ssu_.


     Known Bugs:

     Other Problems:

     History:

     Written - Al Dupuis - August 1983
     Changed - Al Dupuis - October 1984 Became report_writer_.

*/
%page;
rw_set_format_options: proc (

	sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
	report_cip_parm /* input: points to report_control_info */
		        );
%skip(3);
dcl report_cip_parm ptr parm;
dcl sci_ptr_parm ptr parm;
%skip(3);
/*
          Mainline Processing Overview.

     	(1) Go through the control args once setting the long and 
              reset flags.

          (2) Reset all values to system defaults if -reset is in effect.

          (3) Process the format option args, prompting for value if
              requested, then setting the value to user provided or
              system default value.
*/
%page;
%skip(3);
	call initialize;
%skip(1);
          if reset_flag
	then do;
	     call rw_options$set_all_to_system_defaults (report_cip, code);
	     if code ^= 0 
	     then call ssu_$abort_line (sci_ptr, code);
	     if number_of_control_args = number_of_args_supplied
	     then return;
	end;
%skip(1);
	current_arg_number = 1;
          still_processing_format_option_args = ON;
%skip(1);
	do while (still_processing_format_option_args);
               call get_argument_set;
	     call get_and_or_set_the_value;
	end;
%skip(1);
	return;
%page;
get_accumulated_input: proc;
%skip(3);
/*
	Keep picking up pieces of the value concatenating each piece
	to the one before with a blank separating each one. The value is
	complete when we see the next format option name, which is 
	recognizable by the leading hyphen. If the arg before the
	next format option name was -string then conceal the special
	meaning of "-". The value is also complete when we exhaust the
	format option arguments.
*/
%skip(1);
	still_adding_chunks_of_the_value = ON;
%skip(1);
	do while (still_adding_chunks_of_the_value);
%skip(1);
	     call get_next_format_arg (code);
	     if code = NO_MORE_FORMAT_ARGS_LEFT
	     then return;
%skip(1);
	     if substr (arg, 1, 1) = "-" 
	     & ^this_is_a_string_arg (save_arg_number_for_hyphen_string)
	     then do;
		still_adding_chunks_of_the_value = OFF;
		current_arg_number = save_arg_number_for_hyphen_string + 1;
		still_processing_format_option_args = ON;
	     end;
	     else option_value 
		= option_value || " " || substr (arg, 1, arg_length);
%skip(1);
	end;
%skip(1);
	return;
%skip(1);
     end get_accumulated_input;
%page;
get_and_or_set_the_value: proc;
%skip(3);
/*
	Pick up the rest of the value if necessary. If the
	previous argument was -string then conceal the
	special meaning of -prompt and -default. If the value contains
	a trailing newline only then remove it. If the value contains
	imedded newlines then make sure it ends with a newline.
*/
%skip(1);
          if option_value = "-default" 
	& ^this_is_a_string_arg (save_arg_number_for_hyphen_string)
	then call rw_options$set_and_check (report_cip, long_option_name,
	     option_identifier, option_value, SYSTEM_DEFAULT, code);
	else do;
	     if option_value = "-prompt"
	     & ^this_is_a_string_arg (save_arg_number_for_hyphen_string)
	     then call get_prompted_input;
	     else call get_accumulated_input;
	     if length (option_value) > 0
	     then do;
		if index (substr (option_value, 1, length (option_value) - 1), NEWLINE) ^= 0
		then if substr (option_value, length (option_value)) ^= NEWLINE
		     then option_value = option_value || NEWLINE;
		     else;
		else if substr (option_value, length (option_value)) = NEWLINE
		     then option_value = substr (option_value, 1, length (option_value) - 1);
		     else;
	     end;
	     call rw_options$set_and_check (report_cip, long_option_name, 
		option_identifier, option_value, NOT_SYSTEM_DEFAULT, code);
	end;
%skip(1);
          /* Report various errors. */
%skip(1);
	if code ^= 0
          then if code = rw_error_$bad_option_value
	     then if identifier_needed
	          then call ssu_$abort_line (sci_ptr, code,
	               "^/^a is not a valid value for ^a.",
	               option_value, normalized_option_name);
	          else call ssu_$abort_line (sci_ptr, code,
		     "^/^a is not a valid value for ^a.", 
		     option_value, long_option_name);
	     else if code = error_table_$nomatch
		then call ssu_$abort_line (sci_ptr, code,
		     "^/The column identifier ^a did not match any column names.",
		     option_identifier);
	          else call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
          return;
%skip(1);
     end get_and_or_set_the_value;
%page;
get_argument_set: proc;
%skip(3);
	/* Get the option name. */
%skip(1);
	call get_next_format_arg (code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, 0,
	     "Logic error while processing the request arguments.");
%skip(1);
	/* Translate the short or long name into a long name
             and find out if a column identifier is needed. */
%skip(1);
          option_name = arg;
          call rw_options$check_name (report_cip, option_name, 
	     long_option_name, identifier_needed, code);
	if code ^= 0
	then if code = rw_error_$no_columns_defined
	     then call ssu_$abort_line (sci_ptr, code,
	          "^/There must be columns defined before the value of ^a can be set.",
	          long_option_name);
	     else if code = rw_error_$bad_option_name
		then call ssu_$abort_line (sci_ptr, code,
		     "^/^a is not a valid option name.", option_name);
	          else call ssu_$abort_line (sci_ptr, code);
	else;
%skip(1);
	/* Get the identifier if its required and check to make sure it's
             valid so that we never prompt the user for the value when the 
	   option identifier is invalid. */
%skip(1);
	if identifier_needed
	then do;
	     call get_next_format_arg (code);
	     if code = NO_MORE_FORMAT_ARGS_LEFT
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		"The option name ^a was not followed by an identifier.", 
		long_option_name);
	     else;
	     option_identifier = arg;
	     call rw_options$check_identifier (report_cip, long_option_name, 
		option_identifier, normalized_option_name, code);
	     if code ^= 0
	     then if code = rw_error_$bad_option_identifier
		then call ssu_$abort_line (sci_ptr, code,
		     "^/^a is not a valid identifier for ^a.",
		     option_identifier, long_option_name);
	          else if code ^= error_table_$nostars
		     then call ssu_$abort_line (sci_ptr, code);
		     else;
	     else;
	end;
	else;
%skip(1);
/* 
	Get the first part of the option value which might be the complete
	value, part of the value, or the control args -default or -prompt.
*/
%skip(1);
	call get_next_format_arg (code);
          if code = NO_MORE_FORMAT_ARGS_LEFT
	then call ssu_$abort_line (sci_ptr, rw_error_$bad_option_value,
	     "^/The format option ^a did not have a value supplied.", 
	     long_option_name);
%skip(1);
	option_value = arg;
%skip(1);
          return;
%skip(1);
     end get_argument_set;
%page;
get_next_format_arg: proc (code_parm);
%skip(3);
/*
	Ignore control args and get straight to the format option arg.
	Save the number of the arg preceding the format option arg so
	-string processing can be done. Make sure that there is another
	format option arg for the next pass through and set an indicator
	if we've exhausted them.
*/
%skip(1);
dcl code_parm fixed bin (35) parm;
%skip(1);
	code_parm = 0;
%skip(1);
	/* Skip over the control args and get to the format args. */
%skip(1);
	do while (this_is_a_control_arg (current_arg_number));
	     current_arg_number = current_arg_number + 1;
	end;
%skip(1);
	if current_arg_number > number_of_args_supplied
	then do;
	     code = NO_MORE_FORMAT_ARGS_LEFT;
	     still_processing_format_option_args = OFF;
	     return;
	end;
          call ssu_$arg_ptr (sci_ptr, current_arg_number,
	     arg_ptr, arg_length);
	save_arg_number_for_hyphen_string = current_arg_number - 1;
	current_arg_number = current_arg_number + 1;
%skip(1);
	/* Make sure there is another format option arg. */
%skip(1);
	do while (this_is_a_control_arg (current_arg_number));
	     current_arg_number = current_arg_number + 1;
	end;
%skip(1);
	if current_arg_number > number_of_args_supplied
	then still_processing_format_option_args = OFF;
%skip(1);
	return;
%skip(1);
     end get_next_format_arg;
%page;
get_prompted_input: proc;
%skip(3);
/*
	Keep collecting lines from user_input until we hit a line which
	consists of the single character ".". Don't prompt before collecting
	if we are in brief mode. If the value is more than one line then
	leave the newline character after each line. If the value is one
	line then remove the newline from the end.
*/
%skip(1);
	input_buffer = "";
	option_value = "";
%skip(1);
	if ^brief_flag
	then if identifier_needed
	     then call ioa_ ("Enter ^a.", normalized_option_name);
	     else call ioa_ ("Enter ^a.", long_option_name);
	else;
%skip(1);
	number_of_input_lines = 0;
	more_input = ON;
%skip(1);
	do while (more_input);
	     call iox_$get_line (iox_$user_input,
		input_buffer_ptr, input_buffer_length, 
		number_of_chars_read, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code);
	     else;
	     number_of_input_lines = number_of_input_lines + 1;
	     if number_of_chars_read = 2
	     then if substr (input_buffer, 1, 1) = "."
		then more_input = OFF;
	          else;
	     else;
	     if more_input 
	     then option_value = option_value
		|| substr (input_buffer, 1, number_of_chars_read);
	end;
%skip(1);
	if number_of_input_lines = 2
	then option_value = substr (option_value, 1, 
	     length (option_value) - 1);
%skip(1);
	return;
%skip(1);
     end get_prompted_input;
%page;
initialize: proc;
%skip(3);
	sci_ptr = sci_ptr_parm;
	report_cip = report_cip_parm;
%skip(1);
	reset_flag = OFF;
	brief_flag = OFF;
%skip(1);
          /* If no args are given it is an error. */
%skip(1);
	call ssu_$arg_count (sci_ptr, number_of_args_supplied);
	if number_of_args_supplied = 0
	then call ssu_$abort_line (sci_ptr, error_table_$noarg,
	     "^/Usage: set_format_options {-format_option_args} {-control_args}");
%skip(1);
/* 
	Go through the control args once setting the flags and flagging
	the control args we should ignore on our next pass through.
	This is done with a map of bits for the control args
	and another map of bits for the string args. 
*/
%skip(1);
	unspec (this_is_a_control_arg) = OFF;
	unspec (this_is_a_string_arg) = OFF;
	number_of_control_args = 0;
	current_arg_number = 1;
	still_processing_control_args = ON;
%skip(1);
	do while (still_processing_control_args);
%skip(1);
	     call ssu_$arg_ptr (sci_ptr, current_arg_number,
		arg_ptr, arg_length);
%skip(1);
	     if arg = "-string" | arg = "-str"
	     then do;
		this_is_a_control_arg (current_arg_number) = ON;
		this_is_a_string_arg (current_arg_number) = ON;
		number_of_control_args = number_of_control_args + 1;
		current_arg_number = current_arg_number + 1;
		if current_arg_number > number_of_args_supplied
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
		     "^/-string must be followed by a format option value.");
		else;
	     end;
	     else if arg = "-reset" | arg = "-rs" 
		| arg = "-no_reset" | arg = "-nrs"
		then do;
		     this_is_a_control_arg (current_arg_number) = ON;
		     number_of_control_args = number_of_control_args + 1;
		     if arg = "-reset" | arg = "-rs"
		     then reset_flag = ON;
		     else reset_flag = OFF;
		end;
		else if arg = "-brief" | arg = "-bf"
		     | arg = "-long" | arg = "-lg"
		     then do;
			this_is_a_control_arg (current_arg_number) = ON;
			number_of_control_args = number_of_control_args + 1;
			if arg = "-brief" | arg = "-bf"
			then brief_flag = ON;
			else brief_flag = OFF;
		     end;
		     else;
%skip(1);
	     current_arg_number = current_arg_number + 1;
	     if current_arg_number > number_of_args_supplied
	     then still_processing_control_args = OFF;
%skip(1);
	end;
%skip(1);
	/* If no format option args were given (only control args were
             given), then -reset must be in effect or there's nothing to do. */
%skip(1);
	if number_of_control_args = number_of_args_supplied
	then if ^reset_flag
	     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
	          "^/-reset was not specified and there are no format option values to set.");
	     else;
	else;
%skip(1);
	/* Used as the buffer to hold prompted input lines. */
%skip(1);
	input_buffer_ptr = addr (input_buffer);
	input_buffer_length = MAXIMUM_OPTION_VALUE_LENGTH;
	option_identifier = "";
%skip(1);
          return;
%skip(1);
     end initialize;
%page;
dcl NEWLINE char (1) static int options (constant) init ("
");
dcl NO_MORE_FORMAT_ARGS_LEFT fixed bin (35) static int options (constant) init (1);
dcl NOT_SYSTEM_DEFAULT bit (1) aligned static int options (constant) init ("0"b);
dcl OFF bit (1) aligned static int options (constant) init ("0"b);
dcl ON bit (1) aligned static int options (constant) init ("1"b);
dcl SYSTEM_DEFAULT bit (1) aligned static int options (constant) init ("1"b);
%skip(1);
dcl addr builtin;
dcl arg char (arg_length) based (arg_ptr);
dcl arg_length fixed bin (21);
dcl arg_ptr ptr;
%skip(1);
dcl brief_flag bit (1) aligned;
%skip(1);
dcl code fixed bin (35);
dcl current_arg_number fixed bin;
%skip(1);
dcl error_table_$inconsistent fixed bin(35) ext static;
dcl error_table_$noarg fixed bin(35) ext static;
dcl error_table_$nomatch fixed bin(35) ext static;
dcl error_table_$nostars fixed bin(35) ext static;
%skip(1);
dcl identifier_needed bit (1) aligned;
dcl index builtin;
dcl input_buffer char (MAXIMUM_OPTION_VALUE_LENGTH);
dcl input_buffer_length fixed bin (21);
dcl input_buffer_ptr ptr;
dcl ioa_ entry() options(variable);
dcl iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl iox_$user_input ptr ext static;
%skip(1);
dcl length builtin;
dcl long_option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
%skip(1);
dcl more_input bit (1) aligned;
%skip(1);
dcl number_of_chars_read fixed bin (21);
dcl number_of_args_supplied fixed bin;
dcl number_of_control_args fixed bin;
dcl number_of_input_lines fixed bin;
dcl normalized_option_name char (MAXIMUM_NORMALIZED_OPTION_NAME_LENGTH) varying;
%skip(1);
dcl option_identifier char (MAXIMUM_OPTION_IDENTIFIER_LENGTH) varying;
dcl option_name char (MAXIMUM_OPTION_NAME_LENGTH) varying;
dcl option_value char (MAXIMUM_OPTION_VALUE_LENGTH) varying;
%skip(1);
dcl report_cip ptr;
dcl reset_flag bit (1) aligned;
dcl rw_error_$bad_option_identifier fixed bin (35) ext static;
dcl rw_error_$bad_option_name fixed bin(35) ext static;
dcl rw_error_$bad_option_value fixed bin (35) static ext;
dcl rw_error_$no_columns_defined fixed bin(35) ext static;
dcl rw_options$check_name entry (ptr, char(*) var, char(*) var, bit(1) aligned, fixed bin(35));
dcl rw_options$check_identifier entry (ptr, char(*) var, char(*) var, char(*) var, fixed bin(35));
dcl rw_options$set_all_to_system_defaults entry (ptr, fixed bin(35));
dcl rw_options$set_and_check entry (ptr, char(*) var, char(*) var, char(*) var, bit(1) aligned, fixed bin(35));
%skip(1);
dcl save_arg_number_for_hyphen_string fixed bin;
dcl sci_ptr ptr;
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$arg_count entry (ptr, fixed bin);
dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
dcl still_adding_chunks_of_the_value bit (1) aligned;
dcl still_processing_format_option_args bit (1) aligned;
dcl still_processing_control_args bit (1) aligned;
dcl substr builtin;
%skip(1);
dcl this_is_a_control_arg (360) bit (1) unaligned;
dcl this_is_a_string_arg (360) bit (1) unaligned;
%skip(1);
dcl unspec builtin;
%page;
%include rw_options_extents;
%skip(3);
     end rw_set_format_options;




		    rw_table_manager.pl1            04/12/85  1046.7rew 04/12/85  1044.7      260685



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1984 *
   *                                                         *
   *********************************************************** */
/* format: off */
%skip(1);
/*

     This module is called to manage the report_writer_'s standard table
     structure. Data retrieved by the users table_manager procedure is
     placed into this standard table structure, and then report_writer_
     takes data out of the table to produce the report. The table is composed
     of the following:

     (1) An array of pointers to segments.  This array has one pointer for each
     segment referred to as level 1 segments.  The structure that contains the
     array is called table_segments_info and can be found in the include file
     rw_table_control_info.incl.pl1.

     (2) A series of level 1 segments.  These segments contain pointers to the
     row values.  There are as many segments as needed to hold all the
     pointers.  They are packed pointers, so roughly 250,000 rows can be
     pointed at by one segment full of pointers.  The structure row_ptrs is
     used to overlay these segments, and can be found in the include file
     rw_table_control_info.incl.pl1.

     (3) A series of level 2 segments.  These segments contain the row values.
     The row values are stored as a fixed length character string.  If a row
     doesn't quite fit into the last slot of the segment, it is stored in the
     next segment so that rows are never split across segment boundaries.
     These segments are implemented as an MSF, and are pointed at by the
     pointers in the level 1 segments.

     The array of pointers described in (1) above is a structure allocated in
     an area.  When the array is about to overflow, a new larger structure is
     allocated and everything is moved to the new structure, and the old one is
     freed.  The level 1 segments described in (2) above are temp segments.
     The level 2 segments described in (3) above are implemented as one MSF.
     When the table is sorted, the rows themselves aren't moved.  Only the row
     pointers are moved.  This is done by getting a new set of temp segments,
     moving the pointers across into their sorted order, and releasing the
     original temp segments.

*/
%page;
/*

     The following entrypoints are provided:

     initalize_table - called when report_writer_ is creating an invocation.
     terminate_table - called when report_writer_ is destroying an invocation.

     create_table - called when the user has asked for a new retrieve.
     delete_table - called when the retrieval has been completed.

     load_rows - called to retrieve N rows and place them in the table.
     load_table - called to retrieve all the rows and place them in the table.

     sort - called to sort the table.

     get_query - called to get the query statement the user used, to select
     the table, through the subsystem's method of choice.

     set_table_manager - called to set the users table manager procedure.
 
     Known Bugs:
 
     Other Problems:

     This subroutine and sort_seg_ call rw_temp_seg_mgr to get temp segments in
     a specified directory. All references to it should be removed after a
     generalized Multics temp segment manager becomes available, that knows how
     to create temp segments in places other than the process directory and
     knows how to clean them up after a process or system failure.
     rw_temp_seg_mgr knows how to do the former, but can't clean up after
     itself.

     History:

     Written - October 1984 - Al Dupuis

*/
%page;
rw_table_manager: proc;
%skip(1);
	/* These parameters are described at each entry where they are used. */
%skip(1);
dcl code_parm fixed bin (35) parm;
dcl message_parm char (*) varying parm;
dcl query_length_parm fixed bin (21) parm;
dcl query_segment_ptr_parm ptr parm;
dcl report_cip_parm ptr parm;
dcl row_count_actual_parm fixed bin (35) parm;
dcl row_count_specified_parm fixed bin (35) parm;
dcl sort_info_ptr_parm ptr parm;
dcl table_manager_parm char (*) parm;
%skip(3);
	call com_err_ (error_table_$badcall, RW_TABLE_MANAGER);
%skip(1);
	return;
%page;
create_table: entry (

	report_cip_parm,	/* input: points to report_control_info */
	code_parm		/* output: success or failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	table_control_info.msf_directory_name = report_control_info.temp_dir_name;
%skip(1);
	call create_a_new_table;
	call create_a_segment_for_row_ptrs;
	call get_an_msf_component;
%skip(1);
	call report_control_info.table_manager_create_table_entry (
	     report_control_info.subsystems_info_ptr, code_parm);
	if code_parm ^= 0
	then call ssu_$abort_line (sci_ptr, code_parm);
%skip(1);
	call load_a_row_into_the_table;
%skip(1);
	return;
%page;
delete_table: entry (

	report_cip_parm,	/* input: points to report_control_info */
	code_parm		/* output: success or failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	call delete_the_table (code_parm);
%skip(1);
	return;
%page;
get_query: entry (

	report_cip_parm,	       /* input: points to report_control_info */
	query_segment_ptr_parm,    /* input: points to query segment */
	query_length_parm,	       /* output: length of query */
	code_parm		       /* output: success or failure */
	      );
%skip(1);
	report_cip = report_cip_parm;
	sci_ptr = report_control_info.subsystem_control_info_ptr;
%skip(1);
	if report_control_info.table_manager_get_query_entry = report_writer_$create_invocation
	then call ssu_$abort_line (sci_ptr, error_table_$unsupported_operation,
	     "^/^a doesn't support the saving of a query.",
	     ssu_$get_subsystem_name (sci_ptr));
	else call report_control_info.table_manager_get_query_entry (report_control_info.subsystems_info_ptr,
	     query_segment_ptr_parm, query_length_parm, code_parm);
%skip(1);
	return;
%page;
initialize_table: entry (

	report_cip_parm,	/* input: points to report_control_info */
	code_parm		/* output: success or failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
	call initialize_the_table;
%skip(1);
	return;
%page;
load_rows: entry (

	report_cip_parm,	      /* input: points to report_control_info */
	row_count_specified_parm, /* input: number of rows needed */
	row_count_actual_parm,    /* output: number successfully gotten */
	code_parm		      /* output: success or failure */
	      );
%skip(1);
	report_cip = report_cip_parm;
	row_count_specified = row_count_specified_parm;
	row_count_actual_parm = 0;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	row_ptrs_ptr = table_segments_info.segment_ptrs (
	     table_segments_info.current_number_of_segments);
%skip(1);
	do loop = 1 to row_count_specified while (code_parm = 0);
	     call report_control_info.table_manager_get_row_entry (
		report_control_info.subsystems_info_ptr, code_parm);
	     if code_parm = 0
	     then do;
		call load_a_row_into_the_table;
		row_count_actual_parm = row_count_actual_parm + 1;
	     end;
	end;
%skip(1);
	return;
%page;
load_table: entry (

	report_cip_parm,	      /* input: points to report_control_info */
	code_parm		      /* output: success or failure */
	      );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	row_ptrs_ptr = table_segments_info.segment_ptrs (
	     table_segments_info.current_number_of_segments);
	still_loading_the_table = ON;
%skip(1);
	do while (still_loading_the_table);
	     call report_control_info.table_manager_get_row_entry (
		report_control_info.subsystems_info_ptr, code_parm);
	     if code_parm = 0
	     then call load_a_row_into_the_table;
	     else do;
		still_loading_the_table = OFF;
		if code_parm = rw_error_$no_data
		then code_parm = 0;
	     end;
	end;
%skip(1);
	return;
%page;
set_table_manager: entry (

	report_cip_parm,	/* input: points to report_control_info */
	table_manager_parm, /* input: name of table manager procedure */
	code_parm,	/* output: success or failure */
	message_parm	/* output: reason for the failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = set_the_table_manager (table_manager_parm, message_parm);
%skip(1);
	return;
%page;
sort: entry (

	report_cip_parm,	/* input: points to report_control_info */
	sort_info_ptr_parm, /* input: points to sort_info */
	code_parm		/* output: success or failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	sort_info_ptr = sort_info_ptr_parm;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	call sort_the_table (code_parm);
%skip(1);
	return;
%page;
terminate_table: entry (

	report_cip_parm,	/* input: points to report_control_info */
	code_parm		/* output: success or failure */
		    );
%skip(1);
	report_cip = report_cip_parm;
	code_parm = 0;
%skip(1);
	call initialize_automatic_variables;
	if table_control_info.msf_file_control_block_ptr ^= null
	then call delete_the_table (code_parm);
	call terminate_the_table;
%skip(1);
	return;
%page;
create_a_new_table: proc;
%skip(1);
dcl cant_code fixed bin (35);
%skip(1);
	call msf_manager_$open (table_control_info.msf_directory_name,
	     table_control_info.msf_file_name,
	     table_control_info.msf_file_control_block_ptr, cant_code);
	if cant_code ^= error_table_$noentry
	then call ssu_$abort_line (sci_ptr, cant_code,
	     "While trying to create/open the multi-segment file^/^a.",
	     pathname_ (table_control_info.msf_directory_name, 
	     table_control_info.msf_file_name));
%skip(1);
	table_control_info.maximum_number_of_rows_per_segment
	     = divide (sys_info$max_seg_size * 4, table_info.row_value_length, 21);
	table_control_info.current_segment_row_count = 0;
	table_control_info.current_component_ptr = null;
	table_control_info.row_count = 0;
%skip(1);
	return;
%skip(1);
     end create_a_new_table;
%page;
create_a_segment_for_row_ptrs: proc;
%skip(1);
dcl casfrp_code fixed bin (35);
dcl casfrp_loop fixed bin;
dcl casfrp_temporary_ptr ptr;
%skip(1);
	if (table_segments_info.current_number_of_segments
	= table_segments_info.maximum_number_of_segments)
	then do;
	     tsi_init_maximum_number_of_segments
		= table_segments_info.maximum_number_of_segments + STARTING_NUMBER_OF_SEGMENTS;
	     allocate table_segments_info in (work_area)
		set (casfrp_temporary_ptr);
	     casfrp_temporary_ptr -> table_segments_info.current_number_of_segments
		= table_segments_ip -> table_segments_info.current_number_of_segments;
	     do casfrp_loop = 1 to tsi_init_maximum_number_of_segments;
		if casfrp_loop > table_segments_ip -> table_segments_info.maximum_number_of_segments
		then casfrp_temporary_ptr -> table_segments_info.segment_ptrs (casfrp_loop) = null;
		else casfrp_temporary_ptr -> table_segments_info.segment_ptrs (casfrp_loop)
		     = table_segments_ip -> table_segments_info.segment_ptrs (casfrp_loop);
	     end;
	     free table_segments_ip -> table_segments_info;
	     table_segments_ip = casfrp_temporary_ptr;
	     table_control_info.table_segments_info_ptr = table_segments_ip;
	end;
%skip(1);
	call rw_temp_seg_mgr$get_segment (table_control_ip, RW_TABLE_MANAGER,
	     report_control_info.temp_dir_name,
	     table_segments_info.segment_ptrs (
	     table_segments_info.current_number_of_segments + 1), casfrp_code);
	if casfrp_code ^= 0
	then call ssu_$abort_line (sci_ptr, casfrp_code,
	     "^/Unable to get a temp segment in ^/^a.",
	     rtrim (report_control_info.temp_dir_name));
%skip(1);
	table_segments_info.current_number_of_segments
	     = table_segments_info.current_number_of_segments + 1;
	row_ptrs_ptr = table_segments_info.segment_ptrs (
	     table_segments_info.current_number_of_segments);
	row_ptrs.number_of_ptrs_in_this_segment = 0;
%skip(1);
	return;
%skip(1);
     end create_a_segment_for_row_ptrs;
%page;
delete_the_table: proc (

	dtt_code_parm /* output: success or failure */
		    /* only returned from replaceable delete_table proc */
		   );
%skip(1);
dcl dtt_code fixed bin (35);
dcl dtt_code_parm fixed bin (35) parm;
dcl dtt_loop fixed bin;
%skip(1);
	do dtt_loop = 1 to table_segments_info.current_number_of_segments;
	     call rw_temp_seg_mgr$release_segment (table_control_ip, RW_TABLE_MANAGER,
		table_segments_info.segment_ptrs (dtt_loop), dtt_code);
	     if dtt_code ^= 0
	     then call ssu_$print_message (sci_ptr, dtt_code,
		"^/While trying to delete the temp segment pointed to by ^p.",
		table_segments_info.segment_ptrs (dtt_loop));
	end;
%skip(1);
	table_segments_info.current_number_of_segments = 0;
	table_segments_info.segment_ptrs (*) = null;
	table_control_info.current_component_ptr = null;
	table_control_info.current_segment_row_count = 0;
%skip(1);
	call msf_manager_$close (table_control_info.msf_file_control_block_ptr);
	call delete_$path (table_control_info.msf_directory_name,
	     table_control_info.msf_file_name, DELETE_SWITCH,
	     "rw_table_manager", dtt_code);
	if dtt_code ^= 0
	then call ssu_$print_message (sci_ptr, dtt_code,
	     "While trying to delete^/^a.",
	     pathname_ (table_control_info.msf_directory_name,
	     table_control_info.msf_file_name));
	table_control_info.number_of_components = 0;
%skip(1);
	call report_control_info.table_manager_delete_table_entry (
	     report_control_info.subsystems_info_ptr, dtt_code_parm);
%skip(1);
	return;
%skip(1);
     end delete_the_table;
%page;
get_an_msf_component: proc;
%skip(1);
dcl gamc_code fixed bin (35);
%skip(1);
	call msf_manager_$get_ptr (table_control_info.msf_file_control_block_ptr,
	     table_control_info.number_of_components, CREATE_SWITCH,
	     table_control_info.current_component_ptr, (0), gamc_code);
	if gamc_code ^= 0
	then call ssu_$abort_line (sci_ptr, gamc_code,
	     "^/While trying to create component ^d for the MSF ^/pointed to by ^p.",
	     table_control_info.number_of_components, table_control_info.msf_file_control_block_ptr);
%skip(1);
	table_control_info.number_of_components = table_control_info.number_of_components + 1;
	table_control_info.current_segment_row_count = 0;
%skip(1);
	return;
%skip(1);
     end get_an_msf_component;
%page;
initialize_automatic_variables: proc;
%skip(1);
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	table_ip = report_control_info.table_information_ptr;
	table_control_ip = report_control_info.table_control_info_ptr;
	table_segments_ip = table_control_info.table_segments_info_ptr;
	work_area_ptr = table_control_info.general_work_area_ptr;
%skip(1);
	return;
%skip(1);
     end initialize_automatic_variables;
%page;
initialize_the_table: proc;
%skip(1);
	work_area_ptr = report_control_info.general_work_area_ptr;
%skip(1);
	allocate table_control_info in (work_area)
	     set (table_control_ip);
	sci_ptr = report_control_info.subsystem_control_info_ptr;
%skip(1);
	table_control_info.number_of_components = 0;
	table_control_info.maximum_number_of_rows_per_segment = 0;
	table_control_info.current_segment_row_count = 0;
	table_control_info.table_information_ptr = report_control_info.table_information_ptr;
	table_control_info.table_segments_info_ptr = null;
	table_control_info.msf_file_control_block_ptr = null;
	table_control_info.current_component_ptr = null;
	table_control_info.temp_seg_info_ptr = null;
	table_control_info.subsystem_control_info_ptr = sci_ptr;
	table_control_info.msf_file_name = unique_chars_ (""b) || ".rw_.table";
	table_control_info.msf_directory_name = get_pdir_ ();
%skip(1);
	call ssu_$get_area (sci_ptr, null, "table area", work_area_ptr);
	table_control_info.general_work_area_ptr = work_area_ptr;
%skip(1);
	tsi_init_maximum_number_of_segments = STARTING_NUMBER_OF_SEGMENTS;
	allocate table_segments_info in (work_area) set (table_segments_ip);
	table_segments_info.maximum_number_of_ptrs_per_segment = sys_info$max_seg_size - SIZE_OF_ROW_PTRS_HEADER;
	table_segments_info.current_number_of_segments = 0;
	table_segments_info.segment_ptrs (*) = null;
	table_control_info.table_segments_info_ptr = table_segments_ip;
%skip(1);
	report_control_info.table_control_info_ptr = table_control_ip;
%skip(1);
	return;
%skip(1);
     end initialize_the_table;
%page;
load_a_row_into_the_table: proc;
%skip(1);
dcl laritt_row_value char (table_info.row_value_length) based (laritt_row_value_ptr);
dcl laritt_row_value_buffer char (table_info.row_value_length) based (table_info.row_value_ptr);
dcl laritt_row_value_ptr ptr;
%skip(1);
	if row_ptrs.number_of_ptrs_in_this_segment >= table_segments_info.maximum_number_of_ptrs_per_segment
	then call create_a_segment_for_row_ptrs;
%skip(1);
	if table_control_info.current_segment_row_count
	>= table_control_info.maximum_number_of_rows_per_segment
	then call get_an_msf_component;
%skip(1);
	laritt_row_value_ptr = addcharno (table_control_info.current_component_ptr,
	     table_control_info.current_segment_row_count * table_info.row_value_length + 1);
	laritt_row_value = laritt_row_value_buffer;
	table_control_info.current_segment_row_count
	     = table_control_info.current_segment_row_count + 1;
%skip(1);
	table_control_info.row_count = table_control_info.row_count + 1;
%skip(1);
	row_ptrs_ptr = table_segments_info.segment_ptrs (
	     table_segments_info.current_number_of_segments);
	row_ptrs.number_of_ptrs_in_this_segment = row_ptrs.number_of_ptrs_in_this_segment + 1;
	row_ptrs.row_value_ptr (row_ptrs.number_of_ptrs_in_this_segment) = laritt_row_value_ptr;
%skip(1);
	return;
%skip(1);
     end load_a_row_into_the_table;
%page;
set_the_table_manager: proc (

	sttm_table_manager_name_parm, /* input: name of table manager */
	sttm_message_parm)		/* output: reason for the failure */
	returns (fixed bin (35)	/* output: success or failure */
		        );
%skip(1);
dcl sttm_code fixed bin (35);
dcl sttm_loop char (12);
dcl sttm_message_parm char (*) varying parm;
dcl sttm_table_entry_variables (3) variable entry (ptr, fixed bin (35));
dcl sttm_table_manager_name char (32);
dcl sttm_table_manager_name_parm char (*) parm;
dcl sttm_variables_index fixed bin;
%skip(1);
	sttm_table_manager_name = sttm_table_manager_name_parm;
	sttm_message_parm = "";
	sttm_variables_index = 1;
%skip(1);
	do sttm_loop = "create_table", "delete_table", "get_row";
	     call hcs_$make_entry (null, sttm_table_manager_name,
		sttm_loop, sttm_table_entry_variables (
		sttm_variables_index), sttm_code);
	     if sttm_code ^= 0
	     then do;
		sttm_message_parm = "Unable to make an entry to "
		     || rtrim (sttm_loop) || ".";
		return (sttm_code);
	     end;
	     sttm_variables_index = sttm_variables_index + 1;
	end;
%skip(1);
	report_control_info.table_manager_create_table_entry = sttm_table_entry_variables (1);
	report_control_info.table_manager_delete_table_entry = sttm_table_entry_variables (2);
	report_control_info.table_manager_get_row_entry = sttm_table_entry_variables (3);
%skip(1);
	call hcs_$make_entry (null, sttm_table_manager_name, "get_query",
	     report_control_info.table_manager_get_query_entry, sttm_code);
	if sttm_code ^= 0
	then report_control_info.table_manager_get_query_entry = report_writer_$create_invocation;
%skip(1);
	return (0);
%skip(1);
     end set_the_table_manager;
%page;
sort_the_table: proc (

	stt_code_parm /* output: success or failure */
		 );
%skip(1);
dcl stt_code_parm fixed bin (35) parm;
dcl stt_loop fixed bin;
dcl stt_sort_descriptors_array (ss_field_count) ptr based (stt_sort_descriptors_array_ptr);
dcl stt_sort_descriptors_array_ptr ptr;
dcl 1 stt_sort_input aligned based (stt_sort_input_ptr),
      2 number_of_segments fixed bin,
      2 number_of_components fixed bin,
      2 sorted bit (1),
      2 segment_ptrs (stt_sort_input_init_number_of_segments refer (
                      stt_sort_input.number_of_segments)) ptr unaligned,
      2 component_ptrs (stt_sort_input_init_number_of_components refer (
                      stt_sort_input.number_of_components)) ptr unaligned;
dcl stt_sort_input_init_number_of_components fixed bin;
dcl stt_sort_input_init_number_of_segments fixed bin;
dcl stt_sort_input_ptr ptr;
dcl 1 stt_sort_output aligned based (stt_sort_output_ptr),
      2 number_of_segments fixed bin,
      2 segment_ptrs (stt_sort_input_init_number_of_segments refer (
                      stt_sort_output.number_of_segments)) ptr unaligned;
dcl stt_sort_output_ptr ptr;
dcl stt_sort_was_successful bit (1) aligned;
dcl stt_temp_ptr ptr;
%skip(1);
	stt_code_parm = 0;
	ss_info_ptr = null;
	stt_sort_descriptors_array_ptr = null;
	stt_sort_input_ptr = null;
	stt_sort_output_ptr = null;
	stt_sort_was_successful = OFF;
%skip(1);
	on cleanup call cleanup_sort_information;
%skip(1);
	ss_field_count = sort_info.number_of_columns_to_sort;
	allocate ss_info in (work_area) set (ss_info_ptr);
	ss_info.header.version = SS_info_version_1;
	ss_info.header.block_size = 1;
	ss_info.header.duplicate_mode = SS_duplicates;
	ss_info.header.mbz1 (*) = 0;
	ss_info.header.delim.type = SS_length;
	ss_info.header.delim.number = table_info.row_value_length;
	ss_info.header.delim.string = "";
	ss_info.field.from.type (*) = SS_index;
	ss_info.field.from.string (*) = "";
	ss_info.field.to.type (*) = SS_length;
	ss_info.field.to.string (*) = "";
	unspec (ss_info.field.modes (*)) = OFF;
	allocate stt_sort_descriptors_array in (work_area)
	     set (stt_sort_descriptors_array_ptr);
%page;
	do stt_loop = 1 to ss_field_count;
	     ss_info.field.from.number (stt_loop)
		= table_info.columns.column_index (sort_info.columns.number (stt_loop));
	     ss_info.field.to.number (stt_loop)
		= table_info.columns.column_length (sort_info.columns.number (stt_loop));
	     ss_info.field.modes.descending (stt_loop)
		= sort_info.columns.modes.descending (stt_loop);
	     ss_info.field.modes.non_case_sensitive (stt_loop)
		= sort_info.columns.modes.non_case_sensitive (stt_loop);
	     stt_sort_descriptors_array (stt_loop)
		= addr (table_info.columns.column_data_type (sort_info.columns.number (stt_loop)));
	     ss_info.field.modes.numeric (stt_loop)
		= mdbm_util_$number_data_class (stt_sort_descriptors_array (stt_loop));
	end;
%skip(1);
	stt_sort_input_init_number_of_segments = table_segments_info.current_number_of_segments;
	stt_sort_input_init_number_of_components = table_control_info.number_of_components;
	allocate stt_sort_input in (work_area) set (stt_sort_input_ptr);
	stt_sort_input.segment_ptrs (*) = null;
	stt_sort_input.sorted = OFF;
%skip(1);
	do stt_loop = 1 to stt_sort_input_init_number_of_segments;
	     stt_sort_input.segment_ptrs (stt_loop) = table_segments_info.segment_ptrs (stt_loop);
	end;
%skip(1);
	do stt_loop = 1 to stt_sort_input_init_number_of_components;
	     call msf_manager_$get_ptr (table_control_info.msf_file_control_block_ptr,
		stt_loop - 1, DONT_CREATE_SWITCH,
		stt_temp_ptr, (0), stt_code_parm);
	     if stt_code_parm ^= 0
	     then call ssu_$abort_line (sci_ptr, stt_code_parm,
		"^/While trying to obtain a pointer to component # ^d, for the MSF^/pointed to by ^p.",
		stt_loop - 1, table_control_info.msf_file_control_block_ptr);
	     stt_sort_input.component_ptrs (stt_loop) = stt_temp_ptr;
	end;
%skip(1);
	allocate stt_sort_output in (work_area) set (stt_sort_output_ptr);
	stt_sort_output.segment_ptrs (*) = null;
%skip(1);
	do stt_loop = 1 to stt_sort_input_init_number_of_segments;
	     call rw_temp_seg_mgr$get_segment (table_control_ip, RW_TABLE_MANAGER,
		report_control_info.temp_dir_name,
		stt_temp_ptr, stt_code_parm);
	     if stt_code_parm ^= 0
	     then call ssu_$abort_line (sci_ptr, stt_code_parm,
		"^/Unable to get a temp segment in ^/^a.",
		rtrim (report_control_info.temp_dir_name));
	     stt_sort_output.segment_ptrs (stt_loop) = stt_temp_ptr;
	end;
%skip(1);
	call sort_seg_$linus_table (table_control_ip, RW_TABLE_MANAGER, ss_info_ptr,
	     rw_temp_seg_mgr$get_segment, rw_temp_seg_mgr$release_segment,
	     report_control_info.temp_dir_name, stt_sort_input_ptr,
	     stt_sort_descriptors_array, stt_sort_output_ptr, stt_code_parm);
	if stt_code_parm ^= 0
	then call ssu_$abort_line (sci_ptr, stt_code_parm,
	     "^/Unable to sort the table.");
%skip(1);
	stt_sort_was_successful = ON; 
	call cleanup_sort_information;
%skip(1);
	return;
%page;
cleanup_sort_information: proc;
%skip(1);
dcl csi_loop fixed bin;
%skip(1);
	if ss_info_ptr ^= null
	then free ss_info;
	if stt_sort_descriptors_array_ptr ^= null
	then free stt_sort_descriptors_array;
%skip(1);
	if stt_sort_input_ptr = null
	then return;
%skip(1);
	if stt_sort_was_successful
	then do csi_loop = 1 to stt_sort_input_init_number_of_segments;
	     table_segments_info.segment_ptrs (csi_loop)
		= stt_sort_output.segment_ptrs (csi_loop);
	     stt_temp_ptr = stt_sort_input.segment_ptrs (csi_loop);
	     call rw_temp_seg_mgr$release_segment (table_control_ip, RW_TABLE_MANAGER,
		stt_temp_ptr, (0));
	end;
	else if stt_sort_output_ptr ^= null
	     then do csi_loop = 1 to stt_sort_input_init_number_of_segments;
		if stt_sort_output.segment_ptrs (csi_loop) ^= null
		then do;
		     stt_temp_ptr = stt_sort_output.segment_ptrs (csi_loop);
		     call rw_temp_seg_mgr$release_segment (table_control_ip, RW_TABLE_MANAGER,
			stt_temp_ptr, (0));
		end;
		else;
	     end;
	     else;
%skip(1);
	free stt_sort_input;
	if stt_sort_output_ptr ^= null
	then free stt_sort_output;
%skip(1);
	return;
%skip(1);
     end cleanup_sort_information;
%skip(1);
     end sort_the_table;
%page;
terminate_the_table: proc;
%skip(1);
	sci_ptr = report_control_info.subsystem_control_info_ptr;
	table_control_ip = report_control_info.table_control_info_ptr;
	if table_control_ip = null
	then return;
%skip(1);
	call rw_temp_seg_mgr$terminate (table_control_ip, (0));
	work_area_ptr = table_control_info.general_work_area_ptr;
	call ssu_$release_area (sci_ptr, work_area_ptr);
	free table_control_info;
	report_control_info.table_control_info_ptr = null;
%skip(1);
	return;
%skip(1);
     end terminate_the_table;
%page;
dcl CREATE_SWITCH bit (1) internal static options (constant) init ("1"b);
%skip(1);
dcl DELETE_SWITCH bit (6) internal static options (constant) init ("100100"b);
dcl DONT_CREATE_SWITCH bit (1) internal static options (constant) init ("0"b);
%skip(1);
dcl OFF bit (1) aligned internal static options (constant) init ("0"b);
dcl ON bit (1) aligned internal static options (constant) init ("1"b);
%skip(1);
dcl RW_TABLE_MANAGER char (16) internal static options (constant) init ("rw_table_manager");
%skip(1);
dcl SIZE_OF_ROW_PTRS_HEADER fixed bin internal static options (constant) init (1);
dcl STARTING_NUMBER_OF_SEGMENTS fixed bin static internal options (constant) init (10);
%skip(1);
dcl addcharno builtin;
dcl addr builtin;
%skip(1);
dcl cleanup condition;
dcl com_err_ entry() options(variable);
%skip(1);
dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35));
dcl divide builtin;
%skip(1);
dcl error_table_$badcall fixed bin(35) ext static;
dcl error_table_$noentry fixed bin(35) ext static;
dcl error_table_$unsupported_operation fixed bin(35) ext static;
%skip(1);
dcl get_pdir_ entry() returns(char(168));
%skip(1);
dcl hcs_$make_entry entry (ptr, char(*), char(*), entry, fixed bin(35));
%skip(1);
dcl loop fixed bin (35);
%skip(1);
dcl mdbm_util_$number_data_class entry (ptr) returns (bit (1) aligned);
dcl msf_manager_$close entry (ptr);
dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35));
dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35));
%skip(1);
dcl null builtin;
%skip(1);
dcl pathname_ entry (char(*), char(*)) returns(char(168));
%skip(1);
dcl report_writer_$create_invocation entry;
dcl row_count_specified fixed bin (35);
dcl rtrim builtin;
dcl rw_error_$no_data fixed bin(35) ext static;
dcl rw_temp_seg_mgr$get_segment entry (ptr, char(*), char(*), ptr, fixed bin(35));
dcl rw_temp_seg_mgr$release_segment entry (ptr, char(*), ptr, fixed bin(35));
dcl rw_temp_seg_mgr$terminate entry (ptr, fixed bin(35));
%skip(1);
dcl sci_ptr ptr;
dcl sort_seg_$linus_table entry (ptr, char(*), ptr, entry, entry, char(*), ptr, (*) ptr, ptr, fixed bin(35));
dcl ssu_$abort_line entry() options(variable);
dcl ssu_$get_area entry (ptr, ptr, char(*), ptr);
dcl ssu_$get_subsystem_name entry (ptr) returns (char (32));
dcl ssu_$print_message entry() options(variable);
dcl ssu_$release_area entry (ptr, ptr);
dcl still_loading_the_table bit (1) aligned;
dcl sys_info$max_seg_size fixed bin(35) ext static;
%skip(1);
dcl unique_chars_ entry (bit(*)) returns(char(15));
dcl unspec builtin;
%skip(1);
dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
%page;
%include rw_options_extents;
%page;
%include rw_report_info;
%page;
%include rw_sort_info;
%page;
%include rw_table_control_info;
%page;
%include rw_table_info;
%page;
%include sort_seg_info;
%skip(3);
     end rw_table_manager;




		    rw_temp_seg_mgr.pl1             11/16/84  1356.4rew 11/16/84  1354.5      100332



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


/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
rw_temp_seg_mgr:
	proc ();

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
	/*								        */
	/*    This program implements the temporary segment management features	        */
	/*    as used by the report writer (and possibly other modules later).	        */
	/*								        */
	/*    Last Modified: (date and reason):					        */
	/*    04/06/83         original coding by Dave Schimke			        */
	/*                     taken from get_temporary_segments_.pl1, but modified to add      */
	/*                     directory specification.				        */
	/*    03/09/84 Al Dupuis - Changed when the LINUS report writer was broken out 	        */
	/*    to be free-standing.						        */
	/*								        */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/* Parameters */

dcl  a_table_info_ptr ptr;
dcl  a_caller char (*);
dcl  a_dir char (*);
dcl  a_ptrs (*) ptr;
dcl  a_ptr ptr;
dcl  a_code fixed bin (35);

/**/

get_segments:
	entry (a_table_info_ptr, a_caller, a_dir, a_ptr, a_code);

	n_segs = dim (a_ptrs, 1);			/* get number of segments wanted */
	array_ptr = addr (a_ptrs);			/* get ptr to the array of ptrs */

gts_join:
	call initialize;
	a_code = 0;
	n_found = 0;				/* initialize indicating we've found no free entries */
 	if a_dir = ""
	     then dir_name = get_pdir_ ();
	else dir_name = a_dir;	     
	status_ip = addr(status_info);
	call expand_pathname_ (dir_name, containing_dir, dir_entryname, code);
	if code ^= 0 then do;
	     a_code = code;
	     return;
	     end;
	call hcs_$status_long (containing_dir, dir_entryname, 1, status_ip, null(), code);
	if code ^= 0 & code ^= error_table_$no_s_permission then do;
	     a_code = code;
	     return;
	     end;
	
	dir_uid = status_info.long.uid;
	
	if block_ptr = null then do;			/* we haven't yet gotten any segments */
	     temp_seg_info.number_of_temp_segs,
		n_blocks = n_segs;			/* so get the exact amount requested */ 
	     allocate block in (area) set (block_ptr);	/* get the needed storage */
	     temp_seg_info.seg_block_ptr = block_ptr;
	     old_blocks = 0;			/* needed by get_new_segments routine */
	     call get_new_segments;			/* do the work in this subr */
	     return;
	     end;

	do i = 1 to n_blocks while (n_found < n_segs);	/* search for the necessary free segments */
	     if (^block (i).used & block(i).uid = dir_uid)
		then do;				/* we found another free one */
		block (i).used = "1"b;		/* mark entry as being used */
		block (i).caller = a_caller;		/* save name of whose using it */
		n_found = n_found + 1;
		ptrs (n_found) = block (i).segptr;
		end;
	end;
	if n_found < n_segs then do;			/* there weren't enough free ones */
	     new_blocks = n_blocks + n_segs - n_found;	/* get more storage, just large enough */
	     old_blocks = n_blocks;

	     allocate new_block in (area) set (new_block_ptr);
						/* get the needed storage */
	     new_block_ptr -> block = block;		/* copy the current structure */
	     free block in (area);
	     temp_seg_info.number_of_temp_segs,
		n_blocks = new_blocks;
	     temp_seg_info.seg_block_ptr,
		block_ptr = new_block_ptr;
	     call get_new_segments;			/* get the needed segments */
	     end;

	return;

get_new_segments:
     proc;

dcl  (i, j) fixed bin;

	do i = old_blocks + 1 to n_blocks;		/* initialize the new entries */
	     block (i).used = "1"b;			/* the caller will use these blocks */
	     block (i).caller = a_caller;		/* ditto */
	     block (i).uid = dir_uid;		          /* save the dir_uid */
	     ename2 = unique_chars_ (unique_bits_ ()) || ".temp.";
	     ename = substr(ename2, 1, 20);
	     call hcs_$make_seg (dir_name, ename, "", 01110b, block (i).segptr, code);
	     if code ^= 0 then do;
		call undo;
		return;
		end;
	     segment_number = bin (baseno (block (i).segptr), 18);
	     do j = 1 to 4;
		segno (j) = substr ("01234567", bin (digit (j), 3) + 1, 1);
	     end;
	     call hcs_$chname_seg (block (i).segptr, ename, ename2, code);
	     if code ^= 0 then do;
		call undo;
		return;
		end;

	     call hcs_$set_safety_sw_seg (block (i).segptr, "1"b, code);

	     block (i).name = substr(ename2, 1, 25);
	     n_found = n_found + 1;
	     ptrs (n_found) = block (i).segptr;
	end;

undo:
	proc;

	     a_code = code;
	     temp_seg_info.number_of_temp_segs,
		n_blocks = old_blocks;		/* reset to the way things were */
	     do j = old_blocks + 1 to i - 1;		/* clean up the segments we already got */
		call delete_$ptr (block (j).segptr, "100100"b, "", code);
	     end;

	end;
     end;						/*						*/
get_segment:
     entry (a_table_info_ptr, a_caller, a_dir, a_ptr, a_code);

	n_segs = 1;				/* only 1 segment is being processed */
	array_ptr = addr (a_ptr);
	go to gts_join;				/*						*/
release_segments:
     entry (a_table_info_ptr, a_caller, a_ptrs, a_code);

          n_segs = dim (a_ptrs, 1);			/* get number of segments wanted */
	array_ptr = addr (a_ptrs);			/* get ptr to the array of ptrs */

rts_join:
          call initialize;
	a_code = 0;
	do i = 1 to n_segs;				/* release each segment passed in */
	     if ptrs (i) ^= null then do;
		found_it = "0"b;			/* flag says we've not yet found this segment */
		do j = 1 to n_blocks while (^found_it); /* search for segment in array */
		     if block (j).used then do;	/* candidate, see if right one */
			if ptrs (i) = block (j).segptr then do;
						/* we found the given segment */
			     if block (j).caller ^= substr(a_caller, 1, min (length (a_caller),32))
			     then a_code = error_table_$argerr;
			     else do;		/* the right guy (as far as we care) */
				call hcs_$truncate_seg (block (j).segptr, 0, code);
						/* truncate now */
				if code ^= 0 then a_code = code;
						/* accumulate error */
				block (j).used = "0"b;
						/* ditto */
				block (j).caller = "";
				ptrs (i) = null;
				found_it = "1"b;
				end;
			     end;
			end;
		end;
		if ^found_it then a_code = error_table_$argerr;
		end;
	end;
	return;

/**/
release_segment:
     entry (a_table_info_ptr, a_caller, a_ptr, a_code);

          n_segs = 1;				/* only 1 segment is being processed */
	array_ptr = addr (a_ptr);
	goto rts_join;

/**/
terminate:
	entry (a_table_info_ptr, a_code);

	call initialize;
	a_code = 0;
	do i = 1 to n_blocks;			/* delete all */
	     if block(i).used then call com_err_ (0, "rw_temp_seg_mgr", "Warning. An unreleased temp seg has been found. (^a)", block(i).caller);
	     call delete_$ptr (block(i).segptr, "100100"b, "rw_temp_seg_mgr", a_code);
	     end;
	call release_temp_segment_ ("rw_temp_seg_mgr", temp_seg_info.work_area_ptr, a_code);
	table_control_info.temp_seg_info_ptr = null;
	return;
/**/
initialize:
	proc;

	table_control_ip = a_table_info_ptr;
	sci_ptr = table_control_info.subsystem_control_info_ptr;
	info_ptr = table_control_info.temp_seg_info_ptr;
	work_area_ptr = table_control_info.general_work_area_ptr;
	if info_ptr = null then do;
	     allocate temp_seg_info in (work_area) set (info_ptr);
	     table_control_info.temp_seg_info_ptr = info_ptr;
	     end;
	area_p = temp_seg_info.work_area_ptr;
	if area_p = null then do;
	     call get_temp_segment_ ("rw_temp_seg_mgr", temp_seg_info.work_area_ptr, a_code);
	     allocate area_info set (area_infop);
	     area_info.version = 1;
	     area_info.control.extend = "0"b;
	     area_info.control.zero_on_alloc = "0"b;
	     area_info.control.zero_on_free = "0"b;
	     area_info.control.no_freeing = "0"b;
	     area_info.control.system = "0"b;
	     area_info.owner = a_caller;
	     area_info.pad = "0"b;
	     area_info.size = sys_info$max_seg_size;
	     area_info.areap = temp_seg_info.work_area_ptr;
	     call define_area_ (area_infop, a_code);
	     area_p = temp_seg_info.work_area_ptr;
	     free area_info;
	     end;
	block_ptr = temp_seg_info.seg_block_ptr;
	n_blocks = temp_seg_info.number_of_temp_segs;
end initialize;
/* Areas */

dcl work_area area (sys_info$max_seg_size) based (work_area_ptr);
dcl work_area_ptr ptr;
/* Automatic */

dcl  area_p ptr init (null);
dcl  array_ptr ptr;
dcl  block_ptr ptr init (null);
dcl  code fixed bin (35);
dcl  containing_dir char(168);
dcl  dir_entryname char(32);
dcl  dir_name char(168);
dcl  dir_uid bit(36) unal;
dcl  ename char (20);
dcl  ename2 char (32);
dcl  found_it bit (1);
dcl  i fixed bin;
dcl  info_ptr ptr;
dcl  j fixed bin;
dcl  n_blocks fixed bin init (0);
dcl  n_found fixed bin;
dcl  n_segs fixed bin;
dcl  new_block_ptr ptr;
dcl  new_blocks fixed bin;
dcl  old_blocks fixed bin;
dcl  sci_ptr ptr;
dcl  segment_number fixed bin;
dcl  segno (4) char (1) defined (ename2) pos (22);
dcl  status_ip ptr;

/* Based */

dcl  area area based (area_p);
dcl  1 block (n_blocks) aligned based (block_ptr),
       2 caller char (32),
       2 segptr ptr,
       2 name char (25),
       2 uid bit(36) unal,
       2 used bit (1);
dcl  1 temp_seg_info based (info_ptr),
       2 number_of_temp_segs fixed bin init (0),
       2 seg_block_ptr ptr init(null),
       2 work_area_ptr ptr init(null);
dcl  1 new_block (new_blocks) aligned based (new_block_ptr) like block;
dcl  1 octal_digits aligned based (addr (segment_number)),
       2 filler bit (24) unal,
       2 digit (4) bit (3) unal;
dcl  ptrs (n_segs) ptr based (array_ptr);
dcl 1 status_info like status_branch;

/* Builtin */

dcl  (addr, baseno, bin, dim, length, min, null, substr) builtin;

/* Entries */

dcl  com_err_ entry() options(variable);
dcl  define_area_ entry (ptr, fixed bin(35));
dcl  delete_$ptr entry (ptr, bit(6), char(*), fixed bin(35));
dcl  expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl  get_pdir_ entry() returns(char(168));
dcl  get_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  hcs_$chname_seg entry (ptr, char (*), char (*), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl  hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  release_temp_segment_ entry (char(*), ptr, fixed bin(35));
dcl  unique_bits_ entry returns (bit (70));
dcl  unique_chars_ entry (bit (*)) returns (char (15));

/* External */

dcl  error_table_$argerr fixed bin (35) ext;
dcl  error_table_$no_s_permission fixed bin(35) ext static;
dcl  sys_info$max_seg_size fixed bin(35) ext static;

%page;
%include area_info;
%include rw_table_info;
%include rw_table_control_info;
%include status_structures;

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