


		    PNOTICE_lister.alm              11/05/84  1335.4r w 11/05/84  1335.3        3555


	dec	1			"version 1 structure
	dec	2			"no. of pnotices
	dec	3			"no. of STIs
	dec	156			"lgth of all pnotices + no. of pnotices
          acc       "Copyright, (C) Honeywell Information Systems Inc., 1981"
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1LSTM0B0000"
	aci	"C2LSTM0B0000"
	aci	"C3LSTM0B0000"
	end
 



		    lister_.pl1                     11/05/84  1154.9r w 11/05/84  1151.4       90855


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

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

/* LISTER_ - Subroutine interface to create & fill in a Lister file.
   Written 770825 by PG
   Modified 770919 by PG to add get_fieldnames entry.
   Modified 791218 by PG to free old field_identifiers in in open_file.
   Modified 800826 by PB for uid implementation.
   Modified 801202 by PB to fix bug in get_fieldnames.
   Modified 801205 by PB to fix bug when fieldname specified twice.
   Modified 830907 by PB to use non-freeing areas.
*/

/* format: style3 */
lister_$open_file:
     procedure (bv_dname, bv_ename, bv_open_info_ptr, bv_file_info_ptr, bv_code) options (packed_decimal);

/* parameters */

declare (
         bv_area_ptr ptr,
         bv_code fixed bin (35),
         bv_dname char (*),
         bv_ename char (*),
         bv_fieldname_info_ptr
         ptr,
         bv_file_info_ptr ptr,
         bv_open_info_ptr ptr,
         bv_record_info_ptr ptr
         ) parameter;

/* automatic */

declare  bitcount fixed bin (24),
         code fixed bin (35),
         fieldx fixed bin,
         field_len fixed bin (21),
         field_ptr ptr,
         file_info_ptr ptr,
         open_info_ptr ptr,
         out_recordp ptr,
         record_info_ptr ptr,
         selected_records_ptr
         ptr;

/* based */

declare  field_value char (field_len) based (field_ptr);

declare 1 fieldname_info aligned based (open_info.fieldname_info_ptr),
        2 version fixed bin,
        2 n_fieldnames fixed bin,
        2 name (n refer (fieldname_info.n_fieldnames)) char (32);

declare 1 file_info aligned based (file_info_ptr),
        2 file_ptr ptr,
        2 dname char (168) unal,
        2 ename char (32) unal;

declare 1 local_open_info aligned like open_info;
declare 1 open_info aligned based (open_info_ptr),
        2 version fixed bin,
        2 flags aligned,
	3 create bit (1) unal,
	3 discard_records
         bit (1) unal,
	3 assign_fieldnames
         bit (1) unal,
	3 mbz bit (33) unal,
        2 fieldname_info_ptr
         ptr;

declare 1 record_info aligned based (record_info_ptr),
        2 version fixed bin,
        2 n_fields fixed bin,
        2 field (n refer (record_info.n_fields)) aligned,
	3 field_ptr ptr,
	3 field_len fixed bin (21);

/* builtins */

declare (dim, empty, hbound, lbound, null, offset, pointer, rtrim)
         builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare  adjust_bit_count_ entry (char (*), char (*), bit (1) aligned, fixed bin (24), fixed bin (35)),
         get_system_free_area_
         entry (ptr),
         hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)),
         hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$terminate_noname
         entry (ptr, fixed bin (35));

/* external static */

declare (
         lister_codes_$cant_assign_fieldnames,
         lister_codes_$dup_fieldname,
         lister_codes_$fieldname_info_ptr_null,
         lister_codes_$file_info_ptr_null,
         lister_codes_$open_info_mbz_bad,
         lister_codes_$open_info_wrong_version,
         lister_codes_$record_info_wrong_version,
         lister_codes_$wrong_no_of_fields
         ) external static;

/* internal static */

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	selected_records_ptr = null;
	file_info_ptr = null;
	on cleanup
	     call clean_up;

	open_info_ptr = bv_open_info_ptr;

	if open_info.version ^= 1
	then do;
	     bv_code = lister_codes_$open_info_wrong_version;
	     return;
	end;

	if open_info.mbz ^= ""b
	then do;
	     bv_code = lister_codes_$open_info_mbz_bad;
	     return;
	end;

	if open_info.create
	then call hcs_$make_seg (bv_dname, bv_ename, "", 1010b, out_file_ptr, code);
	else call hcs_$initiate (bv_dname, bv_ename, "", 0, 1, out_file_ptr, code);

	if out_file_ptr = null
	then do;
	     bv_code = code;
	     return;
	end;

	call get_system_free_area_ (area_ptr);

	allocate file_info in (system_area) set (file_info_ptr);
	file_info.file_ptr = out_file_ptr;
	file_info.dname = bv_dname;
	file_info.ename = bv_ename;

	if output_file.version = -1			/* Old file version */
	     | output_file.version = 1
	then output_file.version = lister_file_version_2;

	if output_file.version = 0			/* Newly created file */
	then do;
	     output_file.area = empty ();
	     output_file.field_table_offset = null;
	     output_file.record_head = null;
	     output_file.record_tail = null;
	     output_file.unused (1) = null;
	     output_file.unused (2) = null;
	     output_file.next_uid = 1;
	     output_file.version = lister_file_version_2;
	     output_file.n_records = 0;
	end;

	if open_info.discard_records
	then do;
	     n = lister_select_ (out_file_ptr, null, area_ptr, selected_records_ptr);
	     call lister_delete_ (out_file_ptr, selected_records_ptr);
	end;

	if open_info.assign_fieldnames
	then if output_file.n_records ^= 0
	     then do;
		bv_code = lister_codes_$cant_assign_fieldnames;
		call clean_up;
		return;
	     end;
	     else do;

		if open_info.fieldname_info_ptr = null
		then do;
		     bv_code = lister_codes_$fieldname_info_ptr_null;
		     call clean_up;
		     return;
		end;

		field_table_ptr = output_file.field_table_offset;

		if field_table_ptr ^= null
		then do;
		     do fieldx = lbound (field_table.index_to_field_id, 1)
			     to hbound (field_table.index_to_field_id, 1);
			fidp = pointer (field_table.index_to_field_id (fieldx), output_file.area);
			free fidp -> field_identifier in (output_file.area);
		     end;
		     free field_table_ptr -> field_table in (output_file.area);
		end;

		n = fieldname_info.n_fieldnames - 1;

		allocate field_table in (output_file.area) set (field_table_ptr);
		output_file.field_table_offset = field_table_ptr;
		field_table.record_delimiter = "$";
		field_table.field_delimiter = "=";
		field_table.hash_field_id_to_index (*) = null;

		do fieldx = lbound (fieldname_info.name, 1) to hbound (fieldname_info.name, 1);
		     fidp = lister_hash_fid_$enter (out_file_ptr, rtrim (fieldname_info.name (fieldx)));
		     if fidp = null
			then do;
			bv_code = lister_codes_$dup_fieldname;
			call clean_up;
			return;
		     end;
		     field_table.index_to_field_id (fieldx - 1) = offset (fidp, output_file.area);
		     fidp -> field_identifier.field_index = fieldx - 1;
		end;
	     end;

	bv_file_info_ptr = file_info_ptr;
	file_info_ptr = null;			/* don't clean this up now! */
	call clean_up;
	bv_code = 0;
	return;

lister_$add_record:
	entry (bv_file_info_ptr, bv_record_info_ptr, bv_code);

	file_info_ptr = bv_file_info_ptr;
	record_info_ptr = bv_record_info_ptr;

	if record_info.version ^= 1
	then do;
	     bv_code = lister_codes_$record_info_wrong_version;
	     return;
	end;

	if file_info_ptr = null
	then do;
	     bv_code = lister_codes_$file_info_ptr_null;
	     return;
	end;

	out_file_ptr = file_info.file_ptr;
	field_table_ptr = output_file.field_table_offset;

	if field_table.max_field_index + 1 ^= record_info.n_fields
	then do;
	     bv_code = lister_codes_$wrong_no_of_fields;
	     return;
	end;

	out_recordp = lister_create_record_ (out_file_ptr);

	do fieldx = 1 to record_info.n_fields;
	     field_ptr = record_info.field (fieldx).field_ptr;
	     atom_length, field_len = record_info.field (fieldx).field_len;

	     allocate atom in (output_file.area) set (atomp);
	     out_recordp -> output_record.field (fieldx - 1) = atomp;
	     atom = field_value;
	end;

	bv_code = 0;
	return;

lister_$get_fieldnames:
	entry (bv_file_info_ptr, bv_area_ptr, bv_fieldname_info_ptr, bv_code);

	file_info_ptr = bv_file_info_ptr;
	area_ptr = bv_area_ptr;
	bv_fieldname_info_ptr = null;

	if file_info_ptr = null
	then do;
	     bv_code = lister_codes_$file_info_ptr_null;
	     return;
	end;

	open_info_ptr = addr (local_open_info);
		
	open_info.fieldname_info_ptr = null;

	on cleanup
	     begin;
	     if open_info.fieldname_info_ptr ^= null
		then free open_info.fieldname_info_ptr -> fieldname_info in (system_area);
	end;

	out_file_ptr = file_info.file_ptr;
	field_table_ptr = output_file.field_table_offset;

	n = dim (field_table.index_to_field_id, 1);

	allocate fieldname_info in (system_area) set (open_info.fieldname_info_ptr);
	fieldname_info.version = 1;
	fieldname_info.n_fieldnames = n;

	do fieldx = 1 to n;
	     fieldname_info.name (fieldx) =
		pointer (field_table.index_to_field_id (fieldx - 1), output_file.area) -> field_identifier.string;
	end;

	bv_fieldname_info_ptr = open_info.fieldname_info_ptr;
	bv_code = 0;
	return;

lister_$close_file:
	entry (bv_file_info_ptr, bv_code);

	selected_records_ptr = null;
	file_info_ptr = bv_file_info_ptr;
	on cleanup
	     call clean_up;

	call adjust_bit_count_ (file_info.dname, file_info.ename, "0"b, bitcount, code);
	call hcs_$terminate_noname (file_info.file_ptr, code);
	call clean_up;
	bv_code = 0;
	return;

clean_up:
	procedure ();

	     if selected_records_ptr ^= null
	     then do;
		free selected_records_ptr -> list_node;
		selected_records_ptr = null;
	     end;

	     if file_info_ptr ^= null
	     then do;
		free file_info_ptr -> file_info;
		file_info_ptr = null;
	     end;

	end clean_up;

     end;
 



		    lister_assign_.pl1              11/05/84  1154.9r w 11/05/84  1151.4       32355


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

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

/* Program to assign specific value to specified field(s) in lister record(s).

   Written by Paul W. Benjamin, August 13, 1980.
   Modified 811022 by PB to not allocate null fields.
*/

lister_assign_:
     procedure (bv_in_file_ptr, bv_select_all, bv_selected_records_ptr, bv_assign_info_ptr) options (packed_decimal);

/* parameters */

declare (
         bv_in_file_ptr ptr,
         bv_select_all bit (1) aligned,
         bv_selected_records_ptr ptr,
         bv_assign_info_ptr ptr
         ) parameter;

						/* automatic */

declare (
         assign_info_ptr ptr,
         i fixed bin,
         j fixed bin,
         select_all bit (1) aligned,
         selected_records_ptr ptr
         );

						/* based */

declare  assign_string char (assign_length (j)) based (assign_ptr (j));

declare 1 assign_info (0:field_table.max_field_index) aligned based (assign_info_ptr),
        2 assign_ptr ptr,
        2 assign_length fixed bin (21);

						/* builtin */

declare (hbound, lbound, null)
         builtin;

						/* include file */

%include lister_structures;

/* main program */

	in_file_ptr = bv_in_file_ptr;			/* Copy arguments */
	select_all = bv_select_all;
	selected_records_ptr = bv_selected_records_ptr;
	assign_info_ptr = bv_assign_info_ptr;

	field_table_ptr = input_file.field_table_offset;

	if select_all
	then do recordp = input_file.record_head repeat input_record.next while (recordp ^= null);
	     do j = 0 to field_table.max_field_index;	/* modify all records */
		if assign_ptr (j) ^= null
		then do;
		     if input_record.field (j) ^= null	/* free old field */
		     then do;
			free input_record.field (j) -> atom;
			input_record.field (j) = null;
		     end;
		     atom_length = assign_length (j);
		     if atom_length ^= 0		/* allocate if non-null */
			then do;
			allocate atom in (input_file.area) set (atomp);
			input_record.field (j) = atomp;
			atom = assign_string;
		     end;
		end;
	     end;
	end;
	else if selected_records_ptr ^= null
	then do i = lbound (selected_records_ptr -> list_node.list (*), 1)
		to hbound (selected_records_ptr -> list_node.list (*), 1);
	     do j = 0 to field_table.max_field_index;	/* modify selected records */
		if assign_ptr (j) ^= null ()
		then do;
		     recordp = selected_records_ptr -> list_node.list (i);
		     if input_record.field (j) ^= null
		     then do;
			free input_record.field (j) -> atom;
			input_record.field (j) = null;
		     end;
		     atom_length = assign_length (j);
		     if atom_length ^= 0
			then do;
			allocate atom in (input_file.area) set (atomp);
			input_record.field (j) = atomp;
			atom = assign_string;
		     end;
		end;
	     end;
	end;
     end;

 



		    lister_codes_.alm               11/05/86  1614.9r w 11/04/86  1038.8       62064


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

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

" LISTER_CODES_ - Status code table for Lister subsystem
" Written 770719 by PG
" Modified 770818 by PG
" Modified 770826 by PG for lister_ codes
" Modified 770916 by PG for lister_format_parse_ codes
" Modified 770921 by PG for merge_list codes
" Modified 771005 by PG for lister_compile_listin_ codes
" Modified 780407 by PG to add listform_bad_arg_number.
" Modified 780505 by PG to stop listing bleeping object code.
" Modified 780909 by PG to add listin_invalid_char.
" Modified 791128 by PG to add null_select_expr.
" Modified 800513 by PB to add listin_missing_rdelim.
" Modified 800522 by PB to add master_not_like_update.	
" Modified 800814 by PB to add display_unknown_fieldname
" Modified 800904 by PB to add bad_cdelim, fdelim_eq_cdelim, cdelim_eq_rdelim, listin_misplaced_fieldname.
" Modified 801024 by PB to add cant_convert.
" Modified 840626 by PB to add no_current_lister

	maclist	off
	macro	maclist
	&end

	include	et_macros


	et	lister_codes_


ec  bad_cdelim,badcdelm,
	(Invalid comment delimiter.)
ec  bad_fdelim,badfdelm,
	(Invalid field delimiter.)
ec  bad_rdelim,badrdelm,
	(Invalid record delimiter.)
ec  cant_assign_fieldnames,cantasgn,
	(Cannot assign field names because file is not empty.)
ec  cant_convert,cantconv,
	(Write access needed to convert old version file while processing reference to "":uid"".)
ec  cdelim_eq_rdelim,dupdlmcr,
	(Comment delimiter equals record delimiter.)
ec  display_unknown_fieldname,dspunkfn,
	(Unknown field_name specification.)
ec  dup_fieldname,dupfname,
	(Field name is specified more than once.)
ec  dup_format,dupformt,
	(Format is specified more than once.)
ec  expression_too_complicated,compexpr,
	(Select expression is too complicated.)
ec  fdelim_eq_cdelim,dupdlmfc,
	(Field delimiter equals comment delimiter.)
ec  fdelim_eq_rdelim,dupdelim,
	(Field delimiter equals record delimiter.)
ec  fieldname_info_ptr_null,nullfldp,
	(The fieldname_info_ptr is null.)
ec  fieldname_not_alpha_start,fnnotalp,
	(Specified field name does not start with an alphabetic character.)
ec  fieldname_not_alphanumeric,fnnotaln,
	(Specified field name contains non-alphanumeric characters.)
ec  file_info_ptr_null,nullfilp,
	(The file_info_ptr is null.)
ec  incomplete_select_expression,badselct,
	(Select expression ends prematurely.)
ec  invalid_op_null,bad:null,
	(:null can only be used with equal or nequal in select expression.)
ec  invalid_op_numeric,bad:num,
	(:numeric can only be used with equal or nequal in select expression.)
ec  listform_bad_arg_number,badargno,
	(Invalid argument number after :arg in listform segment.)
ec  listform_bad_justify,badjustf,
	(Invalid justification field in listform segment.)
ec  listform_bad_width,badwidth,
	(Invalid field width in listform segment.)
ec  listform_misplaced_fieldname,misplfn,
	(Field names cannot be specified in the Before or After section of the listform segment.)
ec  listform_missing_begin,missbegn,
	(No <Begin xxx:> string found in listform segment.)
ec  listform_missing_gt,missing>,
	("">"" is missing from listform segment.)
ec  listform_missing_lt,missing<,
	(""<"" is missing from listform segment.)
ec  listform_unknown_fieldname,lfmunkfn,
	(Unknown fieldname in listform segment.)
ec  listform_unknown_keyword,lfunkkey,
	(Unknown keyword in listform segment.)
ec  listin_dup_field,dupfield,
	(Field is specified more than once in same record.)
ec  listin_fn_missing_comma,nocomma,
	(No comma follows field name in Field_names statement.)
ec  listin_invalid_char,badchar,
	(Non-printing or non-ASCII character in listin segment.)
ec  listin_misplaced_fieldname,misplfn,
	(Fieldname must immediately follow field delimiter.)
ec  listin_missing_colon,nocolon,
	(No colon follows keyword in listin segment.)
ec  listin_missing_fdelim,nofdelim,
	(Field delimiter not found where expected in listin segment.)
ec  listin_missing_fieldnames,nofnames,
	(No Field_names statement in listin segment.)
ec  listin_missing_rdelim,nordelim,
	(Record delimiter not found where expected in listin segment.)	
ec  listin_missing_semicolon,nosemicn,
	(No semicolon at end of statement in listin segment.)
ec  listin_premature_eof,lstineof,
	(Premature end-of-file in listin segment.)
ec  listin_unknown_fieldname,unkfname,
	(Unknown field name in listin segment.)
ec  listin_unknown_keyword,unkkeywd,
	(Unknown keyword in listin segment.)
ec  long_fdelim,lgfdelim,
	(Specified field delimiter is longer than one character.)
ec  long_fieldname,lgfname,
	(Specified field name is longer than 32 characters.)
ec  long_rdelim,lgrdelim,
	(Specified record delimiter is longer than one character.)
ec  master_eq_output,ms_eq_ot,
	(Master file and output file are same segment.)
ec  master_eq_update,ms_eq_up,
	(Master file and update file are same segment.)
ec  master_not_like_update,msntlkup,
	(Master file and update file are not in the same format.)	
ec  misplaced_control_arg,misplctl,
	(Control argument is out of place.)
ec  missing_right_paren,no_rparn,
	(Right parenthesis missing.)
ec  no_current_lister,nocurls,
	(There is no current lister file.  Use the 'use' request.)
ec  null_select_expr,nullsel,
	(Argument to -select is null.)
ec  null_sort_string,nullsort,
	(Argument to -sort is null.)
ec  open_info_mbz_bad,bad_mbz,
	(A field in open_info that must be zero is not zero.)
ec  open_info_wrong_version,badovers,
	(The version number of open_info is incorrect.)
ec  record_info_wrong_version,badrvers,
	(The version number of record_info is incorrect.)
ec  select_syntax_error,selsyner,
	(Syntax error in select expression.)
ec  too_many_literals,>>literl,
	(Too many literals in select expression.)
ec  undefined_fieldname,nofldnme,
	(Fieldname not known.)
ec  unknown_comparison_op,unkcompa,
	(Unknown comparison operator.)
ec  unknown_keyword,nokeywrd,
	(Keyword not known.)
ec  update_eq_output,ud_eq_ot,
	(Update file and output file are same segment.)
ec  wrong_no_of_fields,badnofld,
	(The record does not contain the correct number of fields.)


	end



		    lister_compile_listin_.pl1      11/05/84  1154.9r w 11/05/84  1151.4      304344


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

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

/* LISTER_COMPILE_LISTIN_ - Program to convert a Lister listin segment into a compiled lister segment.
   Written 771011 by PG
   Modified 780407 by PG to fix bug 17 (wrong line number for duplicate fieldnames)
   Modified 780504 by PG to fix bug 22 (bug in removing doubled quotes)
   Modified 780909 by PG to keep going after errors in main loop (bug 018), and to fix bug
   23 (error msg says line 0 if listin seg begins with delimiter).
   Modified 800513 by PB to detect missing rdelim after "Records:"
   Modified 800825 by PB to handle addition of unique ids.
   Modified 800904 by PB to implement listin comment feature.
   Modified 801028 by PB to fix bug where infinite loop occurs in reporting error of file ending in 2 rdelims.
   Modified 801201 by PB to allow non-quoted string to begin with a quote character.
   Modified 801222 by PB to fix bug where no records causes program to loop.
   Modified 810213 by PB to fix bug where no colon following Records causes
			fatal process error or storage condition.
   Modified 810407 by PB to fix bug where no record_delimiter can cause fatal
                              process error or storage condition.
   Modified 810501 by PB to fix bug where / character gets lost when using 
			pl1-style comments.
   Modified 810710 by PB to fix another bug where no record_delimiter can cause 
			fatal process error or storage condition.
   Modified 811109 by PB to change the calling sequences of comment_scan and
                              comment_end_scan to make them more efficient.
   Modified 830907 by PB to initialize temp_field_ptr to null.
   Modified 830907 by PB to fix bug (phx12793) where a file that ends in a
			fdelim causes an endless loop.
*/

/* format: style3 */
lister_compile_listin_:
     procedure (bv_out_file_ptr, bv_input_ptr, bv_input_length, bv_area_ptr, bv_n_records, bv_error_token, bv_code)
	     options (packed_decimal);

/* parameters */

declare (
         bv_out_file_ptr ptr,
         bv_input_ptr ptr,				/* Input - ptr to listin segment. */
         bv_input_length fixed bin (21),		/* Input - length in chars of listin segment. */
         bv_area_ptr ptr,				/* Input - ptr to system free area */
         bv_n_records fixed bin,
         bv_error_token char (*),
         bv_code fixed bin (35)
         ) parameter;

/* automatic */

declare  cdelim char (1),
         ce_pos fixed bin,
         comment_start char (20) varying,
         commenting bit (1) aligned,
         cs_len fixed bin,
         cs_start fixed bin,
         fatal_error bit (1) aligned,
         fdelim char (1),
         fdelim_or_rdelim char (2),
         field_index fixed bin,
         field_len fixed bin (21),
         field_ptr ptr,
         fieldname_start fixed bin (21),
         in_comment bit (1) aligned,
         input_length fixed bin (21),
         input_ptr ptr,
         keyx fixed bin,
         more_fields bit (1) aligned,
         n_fieldnames fixed bin,
         rdelim char (1),
         saved_source_index fixed bin (21),
         scan_index fixed bin (21),
         source_index fixed bin (21),
         temp_char char (1),
         temp_field_len fixed bin (21),
         temp_field_ptr ptr,
         temp_temp_field_len fixed bin (21),
         temp_temp_field_ptr ptr,
         token char (256) varying,
         token_start fixed bin (21);

/* based */

declare  field_value char (field_len) based (field_ptr),
         source_string char (input_length) based (input_ptr),
         source_string_array (input_length) char (1) based (input_ptr),
         static_buffer char (static_buffer_len) varying based (static_buffer_ptr),
         temp_field_value char (temp_field_len) based (temp_field_ptr),
         temp_temp_field_value
         char (temp_temp_field_len) based (temp_temp_field_ptr);

/* builtins */

declare (addr, addrel, binary, empty, hbound, index, lbound, length, ltrim, maxlength, min, null, offset, pointer, rtrim,
         search, substr, verify)
         builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));

/* external static */

declare (
         error_table_$translation_failed,
         lister_codes_$bad_cdelim,
         lister_codes_$bad_fdelim,
         lister_codes_$bad_rdelim,
         lister_codes_$cdelim_eq_rdelim,
         lister_codes_$dup_fieldname,
         lister_codes_$fdelim_eq_cdelim,
         lister_codes_$fdelim_eq_rdelim,
         lister_codes_$fieldname_not_alpha_start,
         lister_codes_$fieldname_not_alphanumeric,
         lister_codes_$listin_dup_field,
         lister_codes_$listin_fn_missing_comma,
         lister_codes_$listin_invalid_char,
         lister_codes_$listin_misplaced_fieldname,
         lister_codes_$listin_missing_colon,
         lister_codes_$listin_missing_fdelim,
         lister_codes_$listin_missing_fieldnames,
         lister_codes_$listin_missing_rdelim,
         lister_codes_$listin_missing_semicolon,
         lister_codes_$listin_premature_eof,
         lister_codes_$listin_unknown_fieldname,
         lister_codes_$listin_unknown_keyword,
         lister_codes_$long_fdelim,
         lister_codes_$long_fieldname,
         lister_codes_$long_rdelim
         ) fixed bin (35) external static;

/* internal static */

declare (
         keywords (9) char (17) varying
         initial ("Fd", "Field_delimiter", "Rd", "Record_delimiter", "Fn", "Field_names", "Records", "Comment_delimiter", "Cd"),
         NL_HT_SP_VT_NP char (5) initial ("
	 "),
         permissible_delimiters
         char (12) initial ("=%*&!$|^?~#@"),
         QUOTE char (1) initial (""""),
         static_buffer_len fixed bin (21) initial (0),
         static_buffer_ptr ptr initial (null)
         ) internal static;

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

          temp_field_ptr = null ();
	out_file_ptr = bv_out_file_ptr;
	input_ptr = bv_input_ptr;
	input_length = bv_input_length;
	area_ptr = bv_area_ptr;
	bv_n_records = 0;
	bv_code = 0;

	on cleanup
	     call clean_up;

	source_index = 1;
	fatal_error = "0"b;
	rdelim = "$";				/* defaults */
	fdelim = "=";				/* .. */
	field_table_ptr = null;			/* .. */
	commenting = "0"b;				/* .. */
	in_comment = "0"b;

/* Initialize output segment */

	call hcs_$truncate_seg (out_file_ptr, 0, bv_code);
	if bv_code ^= 0
	then do;
	     bv_error_token = "Unable to truncate output segment.";
	     go to cleanup_and_return;
	end;

	output_file.field_table_offset = null;
	output_file.record_head = null;
	output_file.record_tail = null;
	output_file.unused (1) = null;
	output_file.unused (2) = null;
	output_file.next_uid = 1;
	output_file.n_records = 0;
	output_file.area = empty ();
	output_file.version = lister_file_version_2;

op_end:
	call get_token;

	do keyx = lbound (keywords, 1) to hbound (keywords, 1) while (token ^= keywords (keyx));
	end;

	if keyx > hbound (keywords, 1)
	then do;
	     bv_code = lister_codes_$listin_unknown_keyword;
	     bv_error_token = token || cv_index_to_line (token_start);
	     go to cleanup_and_return;
	end;

	go to op (keyx);

op (1):						/* Fd */
op (2):						/* Field_delimiter */
	call get_token;

	if token ^= ":"
	then go to missing_colon;

	call get_token;

	if length (token) ^= 1
	then do;
	     bv_code = lister_codes_$long_fdelim;
	     bv_error_token = token || cv_index_to_line (token_start);
	     go to cleanup_and_return;
	end;

	if verify (token, permissible_delimiters) ^= 0
	then do;
	     bv_code = lister_codes_$bad_fdelim;
	     bv_error_token = token || cv_index_to_line (token_start);
	     go to cleanup_and_return;
	end;

	fdelim = token;

	call get_token;
	if token ^= ";"
	then go to missing_semicolon;

	go to op_end;

op (3):						/* Rd */
op (4):						/* Record_delimiter */
	call get_token;

	if token ^= ":"
	then go to missing_colon;

	call get_token;

	if length (token) ^= 1
	then do;
	     bv_code = lister_codes_$long_rdelim;
	     bv_error_token = token || cv_index_to_line (token_start);
	     go to cleanup_and_return;
	end;

	if verify (token, permissible_delimiters) ^= 0
	then do;
	     bv_code = lister_codes_$bad_rdelim;
	     bv_error_token = token || cv_index_to_line (token_start);
	     go to cleanup_and_return;
	end;

	rdelim = token;

	call get_token;
	if token ^= ";"
	then go to missing_semicolon;

	go to op_end;

op (8):						/* Comment_delimiter */
op (9):						/* Cd */
	call get_token;

	if token ^= ":"
	then goto missing_colon;

	call get_token;

	if token = "pl1"
	then cdelim = "/";
	else do;
	     if length (token) ^= 1 | verify (token, permissible_delimiters) ^= 0
	     then do;
		bv_code = lister_codes_$bad_cdelim;
		bv_error_token = token || cv_index_to_line (token_start);
		goto cleanup_and_return;
	     end;
	     cdelim = token;
	end;

	commenting = "1"b;

	call get_token;
	if token ^= ";"
	then goto missing_semicolon;

	goto op_end;

op (5):						/* Fn */
op (6):						/* Field_names */
	call get_token;

	if token ^= ":"
	then go to missing_colon;

	saved_source_index = source_index;		/* Save so we can process twice */
	n_fieldnames = 0;

	call get_token;

	do while (token ^= ";");
	     n_fieldnames = n_fieldnames + 1;

	     if length (token) > 32
	     then do;
		bv_code = lister_codes_$long_fieldname;
		bv_error_token = token || cv_index_to_line (token_start);
		go to cleanup_and_return;
	     end;

	     if verify (substr (token, 1, 1), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") > 0
	     then do;
		bv_code = lister_codes_$fieldname_not_alpha_start;
		bv_error_token = token || cv_index_to_line (token_start);
		go to cleanup_and_return;
	     end;

	     if verify (token, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") > 0
	     then do;
		bv_code = lister_codes_$fieldname_not_alphanumeric;
		bv_error_token = token || cv_index_to_line (token_start);
		go to cleanup_and_return;
	     end;

	     call get_token;
	     if token ^= ";"
	     then if token ^= ","
		then do;
		     bv_code = lister_codes_$listin_fn_missing_comma;
		     bv_error_token = token || cv_index_to_line (token_start);
		     go to cleanup_and_return;
		end;
		else call get_token;
	end;

	source_index = saved_source_index;

/* Allocate fieldname table */

	n = n_fieldnames - 1;
	allocate field_table in (output_file.area) set (field_table_ptr);
	output_file.field_table_offset = field_table_ptr;
	field_table.hash_field_id_to_index (*) = null;
	field_table.index_to_field_id (*) = null;

	n = 0;
	call get_token;

	do while (token ^= ";");
	     fidp = lister_hash_fid_$enter (out_file_ptr, (token));
	     if fidp = null
	     then do;
		bv_code = lister_codes_$dup_fieldname;
		bv_error_token = token || cv_index_to_line (token_start);
		go to cleanup_and_return;
	     end;
	     else do;
		field_table.index_to_field_id (n) = offset (fidp, output_file.area);
		fidp -> field_identifier.field_index = n;
		n = n + 1;
	     end;

	     call get_token;			/* skip comma */

	     if token = ","
	     then call get_token;			/* get next fieldname */
	end;

	go to op_end;

op (7):						/* Records */
						/* Do some validity checks on data so far */
	if rdelim = fdelim
	then do;
	     bv_code = lister_codes_$fdelim_eq_rdelim;
	     bv_error_token = rdelim;
	     go to cleanup_and_return;
	end;

	if commenting
	then if cdelim = fdelim
	     then do;
		bv_code = lister_codes_$fdelim_eq_cdelim;
		bv_error_token = cdelim;
		go to cleanup_and_return;
	     end;

	if commenting
	then if rdelim = cdelim
	     then do;
		bv_code = lister_codes_$cdelim_eq_rdelim;
		bv_error_token = rdelim;
		go to cleanup_and_return;
	     end;

	if field_table_ptr = null
	then do;
	     bv_code = lister_codes_$listin_missing_fieldnames;
	     bv_error_token = "";
	     go to cleanup_and_return;
	end;

	fdelim_or_rdelim = fdelim || rdelim;
	field_table.record_delimiter = rdelim;
	field_table.field_delimiter = fdelim;

find_colon:
	scan_index = index (substr (source_string, source_index), ":");
	if scan_index = 0
	     then goto missing_colon;
	if verify (substr (source_string, source_index, scan_index - 1), NL_HT_SP_VT_NP) ^= 0
	then do;
	     if commenting
	     then do;
		call comment_scan (addr (source_string_array (source_index)), (scan_index - 1));
		if cs_start ^= 0			/* found comment */
		then if verify (substr (source_string, source_index, cs_start - 1), NL_HT_SP_VT_NP) ^= 0
		     then goto missing_colon;
		     else if in_comment		/* no end to comment */
		     then do;
			call comment_end_scan (addr (source_string_array (source_index + cs_start)), 
			     input_length - (source_index + cs_start - 1));
			if ce_pos = 0
			then do;
			     comment_start = cv_index_to_line (source_index + cs_start);
			     goto premature_eof;
			end;
			source_index = source_index + ce_pos + cs_start;
			goto find_colon;
		     end;
		     else do;
			source_index = source_index + cs_start + cs_len - 1;
			goto find_colon;
		     end;
	     end;
	     else goto missing_colon;
	end;

	source_index = source_index + scan_index;
	call skip_over_blanks;
	if source_index >= length (source_string)	/* file with no records. */
	     then goto no_more_data;

find_rdelim:
	scan_index = index (substr (source_string, source_index), rdelim);
	if scan_index = 0
	     then goto no_rdelim;
	if verify (substr (source_string, source_index, scan_index - 1), NL_HT_SP_VT_NP) ^= 0
	then do;
	     if commenting
	     then do;
		call comment_scan (addr (source_string_array (source_index)), (scan_index - 1));
		if cs_start ^= 0			/* found comment */
		then if verify (substr (source_string, source_index, cs_start - 1), NL_HT_SP_VT_NP) ^= 0
		     then goto missing_colon;
		     else if in_comment		/* no end to comment */
		     then do;
			call comment_end_scan (addr (source_string_array (source_index + cs_start)),
			     input_length - (source_index + cs_start - 1));
			if ce_pos = 0
			then do;
			     comment_start = cv_index_to_line (source_index + cs_start);
			     goto premature_eof;
			end;
			source_index = source_index + ce_pos + cs_start;
			goto find_rdelim;
		     end;
		     else do;
			source_index = source_index + cs_start + cs_len - 1;
			goto find_rdelim;
		     end;
	     end;
	     else do;
no_rdelim:	bv_code = lister_codes_$listin_missing_rdelim;
		bv_error_token = cv_index_to_line (source_index + 2);
		goto cleanup_and_return;
	     end;
	end;

	source_index = source_index + scan_index;

	do while (source_index <= length (source_string)); /* while there are more records... */
	     recordp = null;
	     call skip_over_blanks;

	     if source_index > length (source_string)
	     then more_fields = "0"b;
	     else more_fields = "1"b;

	     do while (more_fields);			/* while there are fields... */
find_fdelim:	if substr (source_string, source_index, 1) ^= fdelim
		then do;
		     if substr (source_string, source_index, 1) = rdelim
		     then do;			/* to accommodate emacs lister-mode kluge. */
			source_index = source_index + 1;
			call skip_over_blanks;
			if source_index > length (source_string)
			then goto no_more_data;
			goto find_fdelim;
		     end;
		     else if commenting
		     then do;
			if substr (source_string, source_index, 1) = cdelim
			then do;
			     call comment_scan (addr (source_string_array (source_index)), input_length - (source_index - 1));
			     if in_comment
			     then do;
				comment_start = cv_index_to_line (source_index + cs_start);
				goto premature_eof;
			     end;
			     source_index = source_index + cs_start + cs_len - 1;
			     call skip_over_blanks;
			     goto find_fdelim;
			end;
		     end;
		     else do;
			bv_code = lister_codes_$listin_missing_fdelim;
			bv_error_token = substr (source_string, source_index, 1) || cv_index_to_line (source_index);
			goto cleanup_and_return;
		     end;
		end;


		fieldname_start, source_index = source_index + 1;
						/* step over fdelim */
		if source_index > length (source_string)
		     then do;			/* stepped past EOF */
		     source_index = source_index - 1;
		     scan_index = 0;
		end;

		else scan_index = search (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1;

		if scan_index = 0			/* Fieldname followed by whitespace or eof */
		then do;
		     bv_code = lister_codes_$listin_misplaced_fieldname;
		     bv_error_token = cv_index_to_line (source_index);
		     goto cleanup_and_return;
		end;

		if scan_index = -1			/* The remainder of the file is the field name */
		then scan_index = length (source_string) - source_index + 1;

		field_index = lister_hash_fid_ (out_file_ptr, substr (source_string, source_index, scan_index));
		if field_index = -1
		then do;
		     fatal_error = "1"b;
		     call error (lister_codes_$listin_unknown_fieldname,
			substr (source_string, source_index, scan_index) || cv_index_to_line (source_index));
		end;

		source_index = source_index + scan_index;
						/* step over field name */
		call skip_over_blanks;

		if source_index > length (source_string)
		then field_len = 0;
		else if substr (source_string, source_index, 1) = QUOTE
		then do;
		     saved_source_index = source_index;
		     call scan_quoted_string (field_ptr, field_len);
resume_qs_checking:	     if source_index <= length (source_string)
		     then if substr (source_string, source_index, 1) ^= rdelim & substr (source_string, source_index, 1) ^= fdelim
			then do;
			     if ^commenting
			     then do;
				source_index = saved_source_index;
				goto not_a_quoted_string;
			     end;
			     if substr (source_string, source_index, 1) ^= cdelim
			     then do;
				source_index = saved_source_index;
				goto not_a_quoted_string;
			     end;
			     if cdelim = "/"
			     then do;
				if index (substr (source_string, source_index), "*/") ^= 0
				then source_index = source_index + index (substr (source_string, source_index), "*/") + 2;
				else do;
				     in_comment = "1"b;
				     comment_start = cv_index_to_line (source_index);
				     goto premature_eof;
				end;
			     end;
			     else do;
				if index (substr (source_string, source_index + 1), cdelim) ^= 0
				then source_index = source_index + index (substr (source_string, source_index + 1), cdelim) + 2;
				else do;
				     in_comment = "1"b;
				     comment_start = cv_index_to_line (source_index);
				     goto premature_eof;
				end;
			     end;
			     call skip_over_blanks;
			     goto resume_qs_checking;
			end;
		end;
		else do;
not_a_quoted_string:     field_ptr = addr (source_string_array (source_index));
		     scan_index = search (substr (source_string, source_index), fdelim_or_rdelim) - 1;
		     if scan_index = -1
		     then scan_index = length (source_string) - source_index + 1;

		     field_len = scan_index;
		     field_len = length (rtrim (field_value, NL_HT_SP_VT_NP));
		     source_index = source_index + scan_index;
		     temp_field_ptr = null ();
		     if commenting
		     then do;
			call comment_scan (field_ptr, field_len);
			do while (cs_start ^= 0);
			     if temp_field_ptr = null () /* just entered loop. */
			     then do;
				temp_field_len = field_len;
				allocate temp_field_value;
				temp_field_value = field_value;
				comment_start = "";
			     end;
			     if ^in_comment
			     then do;
				temp_field_value = substr (temp_field_value, 1, cs_start - 1) || substr (temp_field_value, cs_start + cs_len);
				temp_field_len = temp_field_len - cs_len;
				call comment_scan (temp_field_ptr, temp_field_len);
				comment_start = "";
			     end;
			     else do;
				if comment_start = ""
				then comment_start = cv_index_to_line (source_index + cs_start - scan_index);
				temp_char = substr (source_string, source_index, 1);
				source_index = source_index + 1;
				scan_index = search (substr (source_string, source_index), fdelim_or_rdelim) - 1;
				if scan_index = -1
				then goto premature_eof;
				temp_temp_field_len = temp_field_len + scan_index + 1;
				allocate temp_temp_field_value;
				temp_temp_field_value = temp_field_value || temp_char || substr (source_string, source_index, scan_index);
				free temp_field_value;
				temp_field_len = temp_temp_field_len;
				allocate temp_field_value;
				temp_field_value = temp_temp_field_value;
				free temp_temp_field_value;
				call comment_scan (temp_field_ptr, temp_field_len);
				source_index = source_index + scan_index;
			     end;
			end;
		     end;
		end;

		if field_len > 0 & field_index ^= -1 & (temp_field_ptr = null () | (temp_field_ptr ^= null () & temp_field_len ^= 0))
		then do;
		     if recordp = null
		     then recordp = lister_create_record_ (out_file_ptr);

		     if recordp -> output_record.field (field_index) ^= null
		     then do;
			call error (lister_codes_$listin_dup_field,
			     pointer (field_table.index_to_field_id (field_index), output_file.area)
			     -> field_identifier.string || cv_index_to_line (fieldname_start));
		     end;
		     else do;
			if temp_field_ptr ^= null
			then atom_length = length (rtrim (temp_field_value, NL_HT_SP_VT_NP));
			else atom_length = field_len;
			allocate atom in (output_file.area) set (atomp);
			if temp_field_ptr ^= null
			then atom = temp_field_value;
			else atom = field_value;
			recordp -> output_record.field (field_index) = atomp;
		     end;
		end;

		if temp_field_ptr ^= null ()
		then free temp_field_value;

		if source_index <= length (source_string)
		then if substr (source_string, source_index, 1) = rdelim
		     then do;
			more_fields = "0"b;
			source_index = source_index + 1;
						/* step over record delimiter */
		     end;
		     else ;
		else more_fields = "0"b;
	     end;
no_more_data:
	end;

	bv_n_records = output_file.n_records;

cleanup_and_return:
	if fatal_error
	then do;
	     bv_code = error_table_$translation_failed;
	     bv_error_token = "";
	end;

	call clean_up;
	return;

missing_colon:
	bv_code = lister_codes_$listin_missing_colon;
	bv_error_token = token || cv_index_to_line (source_index);
	go to cleanup_and_return;

missing_semicolon:
	bv_code = lister_codes_$listin_missing_semicolon;
	bv_error_token = token || cv_index_to_line (source_index);
	go to cleanup_and_return;

premature_eof:
	bv_code = lister_codes_$listin_premature_eof;
	if in_comment
	then bv_error_token = "While processing comment beginning" || comment_start;
	else bv_error_token = "";
	go to cleanup_and_return;

invalid_char:
	bv_code = lister_codes_$listin_invalid_char;
	bv_error_token = substr (source_string, source_index, 1) || cv_index_to_line (source_index);
	go to cleanup_and_return;

clean_up:
	procedure ();

/* program */

	     if static_buffer_ptr ^= null
	     then do;
		free static_buffer in (system_area);
		static_buffer_ptr = null;
		static_buffer_len = 0;
	     end;

	end clean_up;

cv_index_to_line:
	procedure (bv_source_index) returns (char (20) varying);

/* parameters */

declare  bv_source_index fixed bin (21) parameter;

/* automatic */

declare  line_number fixed bin (21),
         line_string char (20) varying,
         nl_index fixed bin (21),
         src_index fixed bin (21);

/* internal static 				     */

declare  NL char (1) initial ("
") internal static;

/* pictures */

declare  seven_digits picture "zzzzzz9";

/* program */

	     line_number = 1;

	     do src_index = 1 repeat (src_index + nl_index) while (src_index <= bv_source_index);
		nl_index = index (substr (source_string, src_index), NL);
		if nl_index = 0			/* No final newline */
		then nl_index = length (source_string) - src_index + 1;

		line_number = line_number + 1;
	     end;

	     seven_digits = line_number - 1;
	     line_string = " on line " || ltrim (seven_digits);
	     return (line_string);

	end cv_index_to_line;

comment_end_scan:
	procedure (bv_ces_ptr, bv_ces_len);

/*  parameters */

dcl  bv_ces_ptr ptr parameter;
dcl  bv_ces_len fixed bin (21);
	
/* automatic */

dcl  cei fixed bin;

/* based */

dcl  ces_string char (bv_ces_len) based (bv_ces_ptr);
	
/* program */

	     if index (ces_string, cdelim) = 0
	     then do;
		ce_pos = 0;
		return;
	     end;
	     else do cei = 1 to length (ces_string) while (in_comment);
		if substr (ces_string, cei, 1) = cdelim
		then do;
		     in_comment = "0"b;
		     ce_pos = cei;
		     if cdelim = "/"
		     then if substr (ces_string, cei - 1, 1) = "*"
			then in_comment = "1"b;
		end;
	     end;
	end comment_end_scan;

comment_scan:
	procedure (bv_cs_ptr, bv_cs_len);

/* parameters */

declare  bv_cs_ptr ptr parameter;
declare  bv_cs_len fixed bin (21) parameter;
	
/* automatic */

declare  ci fixed bin;

/* based */

declare  cs_string char (bv_cs_len) based (bv_cs_ptr);
	
/* program */

	     if cdelim = "/"
		then do;
		if index (cs_string, "/*") = 0
		     then do;
		     cs_start = 0;
		     cs_len = 0;
		     return;
		end;
	     end;
	     else do;
		if index (cs_string, cdelim) = 0
		then do;
		     cs_start = 0;
		     cs_len = 0;
		     return;
		end;
	     end;

	     do ci = 1 to length (cs_string) while (^in_comment);
		if substr (cs_string, ci, 1) = cdelim
		     then do;
		     in_comment = "1"b;
		     cs_start = ci;
		     if cdelim = "/"
		          then if substr (cs_string, ci + 1, 1) ^= "*"
			then in_comment = "0"b;
		end;
	     end;
	     if cdelim = "/"
		then cs_len = index (substr (cs_string, cs_start), "*/") + 1;
	     else cs_len = index (substr (cs_string, cs_start + 1), cdelim) + 1;
	     if cs_len > 1
		then in_comment = "0"b;
	end comment_scan;

error:
	procedure (bv_status_code, bv_message);

/* parameters */

declare (
         bv_status_code fixed bin (35),
         bv_message char (*)
         ) parameter;

/* automatic */

declare  long_msg char (100),
         short_msg char (8);

/* entries */

declare  convert_status_code_
         entry (fixed bin (35), char (8), char (100)),
         ioa_$ioa_switch entry options (variable);


/* external static */

declare  iox_$error_output ptr external static;

/* program */

	     call convert_status_code_ (bv_status_code, short_msg, long_msg);
	     call ioa_$ioa_switch (iox_$error_output, "^a  ^a", long_msg, bv_message);
	     return;

	end error;

get_token:
	procedure;

/* program */

/* Skip leading white space */

try_again:
	     scan_index = verify (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1;
	     if scan_index = -1			/* rest of segment is blank */
	     then go to premature_eof;

	     source_index = source_index + scan_index;	/* step over blanks */
	     token_start = source_index;		/* remember in case of errors */

/* Check for simple delimiter tokens */

	     scan_index = index ("!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~", substr (source_string, source_index, 1));
	     if scan_index > 0
	     then do;
		if commenting
		then if substr (source_string, source_index, 1) = cdelim
		     then do;
			comment_start = cv_index_to_line (token_start);
			if cdelim = "/"
			then do;
			     if substr (source_string, source_index + 1, 1) = "*"
			     then do;
				in_comment = "1"b;
				scan_index = index (substr (source_string, source_index + 2), "*/");
				if scan_index = 0
				then goto premature_eof;
				source_index = source_index + scan_index + 3;
				in_comment = "0"b;
				goto try_again;
			     end;
			end;			/* slash w/o asterisk--pass as token. */
			else do;
			     in_comment = "1"b;
			     scan_index = index (substr (source_string, source_index + 1), cdelim);
			     if scan_index = 0
			     then goto premature_eof;
			     source_index = source_index + scan_index + 1;
			     in_comment = "0"b;
			     goto try_again;
			end;
		     end;
		token = substr (source_string, source_index, 1);
		source_index = source_index + 1;
		return;
	     end;

/* See if it is a non-printing char. */

	     if substr (source_string, source_index, 1) < " " | substr (source_string, source_index, 1) > "~"
	     then go to invalid_char;

/* It is an alphanumeric token. Find the end of it. */

	     scan_index =
		verify (substr (source_string, source_index),
		"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz") - 1;
	     if scan_index = -1			/* rest of segment is alphanumerics */
	     then scan_index = length (source_string) - source_index;

	     token = substr (source_string, source_index, scan_index);
	     source_index = source_index + scan_index;	/* step over it */
	     return;

	end get_token;

/* Internal procedure to scan a quoted field value, removing doubled quotes.
   Implicit input arguments: source_string, source_index.
*/

scan_quoted_string:
	procedure (bv_field_ptr, bv_field_len);

/* parameters */

declare (
         bv_field_ptr ptr,				/* Output - ptr to dequoted string */
         bv_field_len fixed bin (21)			/* Output - length of dequoted string */
         ) parameter;

/* automatic */

declare  buffer_len fixed bin (21),
         buffer_ptr ptr,
         string_len fixed bin (21),
         string_start fixed bin (21),
         using_automatic_buffer
         bit (1) aligned;

/* based */

declare  buffer char (buffer_len) varying based (buffer_ptr);

/* program */

	     source_index = source_index + 1;		/* step over opening quote */
	     string_start = source_index;
	     string_len = 0;
	     using_automatic_buffer = "1"b;		/* The default... */
	     buffer_ptr = addr (token);
	     buffer_len = maxlength (token);

rescan:
	     scan_index = index (substr (source_string, source_index), QUOTE) - 1;
	     if scan_index = -1			/* No closing quote */
	     then go to premature_eof;

	     if string_start = 0
	     then do;
		call check_buffer_len (scan_index);
		buffer = buffer || substr (source_string, source_index, scan_index);
	     end;
	     else string_len = string_len + scan_index;

	     source_index = source_index + scan_index + 1; /* step over chars scanned and quote */

	     if source_index <= length (source_string)
	     then if substr (source_string, source_index, 1) = QUOTE
		then do;
		     if string_start > 0		/* if not copied, do it now */
		     then do;
			call check_buffer_len (string_len);
			buffer = substr (source_string, string_start, string_len);
			string_start = 0;
		     end;

		     call check_buffer_len (1);
		     buffer = buffer || QUOTE;
		     source_index = source_index + 1;	/* step over quote */
		     go to rescan;
		end;

	     call skip_over_blanks;

	     if string_start > 0
	     then do;
		bv_field_ptr = addr (source_string_array (string_start));
		bv_field_len = string_len;
		return;
	     end;

	     bv_field_ptr = addrel (buffer_ptr, 1);
	     bv_field_len = length (buffer);
	     return;

check_buffer_len:
	     procedure (bv_additional_chars);

/* parameters */

declare  bv_additional_chars fixed bin (21) parameter;	/* Input - number of chars being concatenated on */

/* automatic */

declare  new_buffer_len fixed bin (21),
         new_buffer_ptr ptr;

/* based */

declare  new_buffer char (new_buffer_len) varying based (new_buffer_ptr);

/* program */

		if length (buffer) + bv_additional_chars <= maxlength (buffer)
		then return;

/* Buffer too small. Switch to a bigger one. */

		if using_automatic_buffer
		then do;
		     if static_buffer_ptr ^= null	/* Have we already allocated a buffer? */
		     then if length (buffer) + bv_additional_chars <= static_buffer_len
			then do;
			     using_automatic_buffer = "0"b;
			     static_buffer = buffer;
			     buffer_ptr = static_buffer_ptr;
			     buffer_len = static_buffer_len;
			     return;
			end;
		end;

/* Calculate new buffer length. It can be as big as a 255K segment, minus the area header size. */

		new_buffer_len = min (1044480 - 96, binary (1.5e0 * (length (buffer) + bv_additional_chars), 35));
		allocate new_buffer in (system_area) set (new_buffer_ptr);

		new_buffer = buffer;

		if ^using_automatic_buffer
		then if static_buffer_ptr ^= null
		     then free static_buffer in (system_area);
		     else ;
		else using_automatic_buffer = "0"b;

		static_buffer_ptr, buffer_ptr = new_buffer_ptr;
		static_buffer_len, buffer_len = new_buffer_len;
		return;

	     end check_buffer_len;

	end scan_quoted_string;

/* Internal procedure to skip over "white space" characters */

skip_over_blanks:
	procedure;

skip_again:
	scan_index = verify (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1;
	     if scan_index = -1
	     then scan_index = length (source_string) - source_index + 1;

	     source_index = source_index + scan_index;
	     if commenting
		then if (substr (source_string, source_index, 1) = cdelim & cdelim ^= "/")
		| (substr (source_string, source_index, 2) = "/*" & cdelim = "/")
		then do;
		call comment_scan (addr (source_string_array (source_index)), input_length - (source_index - 1));
		if in_comment 
		     then do;
		     comment_start = cv_index_to_line (source_index + cs_start);
		     goto premature_eof;
		end;
		source_index = source_index + cs_start + cs_len - 1;
		goto skip_again;
	     end;
	     return;

	end skip_over_blanks;

     end						/* lister_compile_listin_ */;



		    lister_compile_select_.pl1      11/05/84  1154.9rew 11/02/84  1204.7      118413


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

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

/* LISTER_COMPILE_SELECT_ - Program to parse a select expression into a structure that drives
   lister_select_.

   Written 761104 by PG
   Modified 770818 by PG to cleanup error handling (bugs 1 and 9)
   Modified 770921 by PG to make implementation agree with revised documentation
   Modified 791210 by PG to implement sugg 37 (numeric selection), and to fix bugs 10 (null select expr
   gets wrong error msg) and 19 (must accept singular and plural comparison ops).
   Modified 800813 by PB to recognize :uid.
   Modified 840523 by PB to add begins and ends operators.
*/

/* format: style3 */
lister_compile_select_:
     procedure (bv_select_string, bv_input_ptr, bv_area_ptr, bv_select_ptr, bv_error_token, bv_code) options (packed_decimal);

/* parameters */

dcl (
     bv_area_ptr ptr,
     bv_code fixed bin (35),
     bv_error_token char (*),
     bv_input_ptr ptr,
     bv_select_ptr ptr,
     bv_select_string char (*)
     ) parameter;

/* automatic */

dcl  op_table (3) bit (9) aligned initial (SELECT_AND, SELECT_OR, SELECT_NOT);

dcl  comparison_opcode (14) bit (9) aligned
     initial (SELECT_EQ, SELECT_EQ, SELECT_LT, SELECT_GT, SELECT_FIND, SELECT_FIND, SELECT_NEQ,
     SELECT_NEQ, SELECT_NLT, SELECT_NGT, SELECT_BEG, SELECT_BEG, SELECT_END, SELECT_END);

dcl  code fixed bin (35),
     i fixed bin,
     ltx fixed bin,
     selx fixed bin,
     token_temp_seg_ptr ptr;

/* builtins */

dcl (addr, collate, convert, hbound, lbound, length, null, substr, translate)
     builtin;

/* conditions */

dcl  conversion condition;

/* entries */

dcl  lex_string_$init_lex_delims
     entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) varying aligned,
     char (*) varying aligned, char (*) varying aligned, char (*) varying aligned),
     lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*),
     char (*), char (*), char (*) varying aligned, char (*) varying aligned,
     char (*) varying aligned, char (*) varying aligned, ptr, ptr, fixed bin (35)),
     translator_temp_$get_segment
     entry (char (*), ptr, fixed bin (35)),
     translator_temp_$release_all_segments
     entry (ptr, fixed bin (35));

/* external static */

declare (
         error_table_$zero_length_seg,
         lister_codes_$expression_too_complicated,
         lister_codes_$incomplete_select_expression,
         lister_codes_$invalid_op_null,
         lister_codes_$invalid_op_numeric,
         lister_codes_$missing_right_paren,
         lister_codes_$null_select_expr,
         lister_codes_$select_syntax_error,
         lister_codes_$too_many_literals,
         lister_codes_$undefined_fieldname,
         lister_codes_$unknown_comparison_op
         ) fixed bin (35) external static;

/* internal static */

dcl  comparison_op (14) char (8) varying internal static
     initial ("equal", "equals", "less", "greater", "contain", "contains", "nequal", "nequals",
     "nless", "ngreater", "begins", "begin", "ends", "end");

dcl (
    (BREAKS, IGBREAKS, LEXCTL, LEXDLM)
     char (128) varying aligned,
     first_time bit (1) aligned initial ("1"b),
     lower_case char (26) initial ("abcdefghijklmnopqrstuvwxyz"),
     upper_case char (26) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     ) internal static;

/* include files */

%include lister_entries;
%include lister_structures;
%include lex_descriptors_;

/* program */

/* The syntax of the select string is:

   {<fieldname>|anyfield} [not] {<literal>|null}
*/

	area_ptr = bv_area_ptr;
	select_ptr = null;
	in_file_ptr = bv_input_ptr;
	bv_code = 0;
	selx = 0;
	ltx = 0;

	n = 100;
	allocate literal_table in (system_area) set (ltp);

	n = 100;
	allocate select_expression in (system_area) set (select_ptr);
	select_expression.literal_table_ptr = ltp;
	select_expression.last_element = 0;

	if first_time
	then do;
	     IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24);
	     BREAKS = IGBREAKS || "()";
	     call lex_string_$init_lex_delims ("""", """", "", "", "", "11"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);
	     first_time = "0"b;
	end;

	call translator_temp_$get_segment ("lister", token_temp_seg_ptr, code);
	if token_temp_seg_ptr = null
	then do;
	     bv_error_token = "Making temporary segment in process directory.";
	     bv_code = code;
	     return;
	end;

	call lex_string_$lex (addr (bv_select_string), length (bv_select_string), 0, token_temp_seg_ptr, "0000"b, """",
	     """", "", "", "", BREAKS, IGBREAKS, LEXDLM, LEXCTL, Pstmt, Ptoken, code);
	if code ^= 0
	then do;
	     if code = error_table_$zero_length_seg
	     then code = lister_codes_$null_select_expr;

	     bv_error_token = "";
	     bv_code = code;
	     return;
	end;

	on conversion
	     go to recover_from_bad_literal;

	n = expression_parse (code);			/* parse the expression */
	select_expression.last_element = selx;
	if (code = 0) & (Ptoken ^= null)		/* Make sure we have scanned all input */
	then do;
	     bv_error_token = "At """ || token_value || """";
	     code = lister_codes_$select_syntax_error;
	end;

finish:
	if code ^= 0
	then do;
	     free literal_table in (system_area);
	     ltp = null;
	     free select_expression in (system_area);
	     select_ptr = null;
	end;

	bv_select_ptr = select_ptr;
	call translator_temp_$release_all_segments (token_temp_seg_ptr, (0));
	bv_code = code;
	return;

recover_from_bad_literal:
	bv_error_token = token_value || " is not a number.";
	code = lister_codes_$select_syntax_error;
	go to finish;

expression_parse:
	procedure (bv_code) returns (fixed bin);	/* parameters */

dcl  bv_code fixed bin (35) parameter;

/* automatic */

dcl (i, si) fixed bin,
     opindex fixed bin (5),
     stack (0:12) fixed bin;

/* internal static */

dcl  precedence (3) fixed bin internal static initial (2,
						/* and */
     1,						/* or */
     4);						/* not */

dcl  op_names (3) char (4) varying internal static initial ("and", "or", "not");

/*	This procedure parses expressions using a simple operator
   precedence technique.  The syntax parsed is

   <expression> ::= <primitive> [<operator> <primitive>]...

   where the nth operator and its operands are stacked if the
   n+1st operator has higher precedence.  The primitive is parsed by
   the internal entry called "primitive".  The primitives include
   parenthesized expressions, prefix operators, and exponentiation. */

	     bv_code = 0;
	     si = 0;
	     stack (0) = primitive ();

fetchop:
	     if Ptoken ^= null
	     then do;
		do i = lbound (op_names, 1) to hbound (op_names, 1) while (token_value ^= op_names (i));
		end;

		if i <= hbound (op_names, 1)
		then do;
		     if si ^= 0			/* If past first op then check prec. */
		     then do;
			opindex = stack (si - 1);
			if precedence (opindex) >= precedence (i)
			then go to unstack;
		     end;

		     si = si + 1;
		     stack (si) = i;
		     si = si + 1;
		     Ptoken = token.Pnext;
		     stack (si) = primitive ();
		     go to fetchop;
		end;
	     end;

	     if si = 0
	     then return (selx);

	     opindex = stack (si - 1);

unstack:
	     selx = selx + 1;
	     if selx > hbound (select_expression.element, 1)
	     then do;
		bv_code = lister_codes_$expression_too_complicated;
		go to fail;
	     end;

	     select_expression.element (selx).opcode = op_table (opindex);
	     select_expression.element (selx).field_index = stack (si - 2);
	     select_expression.element (selx).literal_index = stack (si);
	     si = si - 2;
	     stack (si) = selx;
	     go to fetchop;

fail:
	     bv_error_token = "";
	     return (0);

fail_with_token:
	     return (0);

/*	Primitive parses prefix expressions and parenthesized expressions. */

primitive:
	     procedure () returns (fixed bin);

/* automatic */

dcl (hashx, i) fixed bin;
dcl  code fixed bin (35);
dcl  cx fixed bin;

/* program */

		if Ptoken = null
		then go to not_enough_input;

		if token_value = "not"
		then do;
		     Ptoken = token.Pnext;
		     i = primitive ();
		     selx = selx + 1;
		     if selx > hbound (select_expression.element, 1)
		     then do;
			bv_code = lister_codes_$expression_too_complicated;
			go to fail;
		     end;

		     select_expression.element (selx).opcode = SELECT_NOT;
		     select_expression.element (selx).field_index = i;
		     return (selx);
		end;
		else if token_value = "("
		then do;
		     Ptoken = token.Pnext;
		     i = expression_parse (code);
		     if code ^= 0
		     then do;
			bv_code = code;
			if code = lister_codes_$undefined_fieldname
			then go to fail_with_token;
			else goto fail;
		     end;

		     if Ptoken = null
		     then do;
			bv_error_token = "At end of select expression.";
			bv_code = lister_codes_$missing_right_paren;
			go to fail_with_token;
		     end;

		     if token_value ^= ")"
		     then do;
			bv_error_token = "At """ || token_value || """";
			bv_code = lister_codes_$missing_right_paren;
			go to fail_with_token;
		     end;

		     Ptoken = token.Pnext;
		     return (i);
		end;
		else do;
		     selx = selx + 1;

		     if token_value = ":any"
		     then select_expression.element (selx).field_index = ANY_FIELD;
		     else if token_value = ":uid"
		     then select_expression.element (selx).field_index = UID;
		     else do;

/* token_value must be passed by value since it gets modified by the hash subroutine. */

			hashx = lister_hash_fid_ (in_file_ptr, (token_value));
			if hashx = -1
			then do;
			     bv_error_token = token_value;
			     bv_code = lister_codes_$undefined_fieldname;
			     go to fail_with_token;
			end;

			select_expression.element (selx).field_index = hashx;
		     end;

		     Ptoken = token.Pnext;
		     if Ptoken = null
		     then go to not_enough_input;

		     if token_value = "not"
		     then do;
			select_expression.element (selx).not = "1"b;

			Ptoken = token.Pnext;
			if Ptoken = null
			then go to not_enough_input;
		     end;
		     else select_expression.element (selx).not = "0"b;

		     do cx = lbound (comparison_op, 1) to hbound (comparison_op, 1) while (comparison_op (cx) ^= token_value);
		     end;

		     if cx > hbound (comparison_op, 1)
		     then do;
			bv_code = lister_codes_$unknown_comparison_op;
			bv_error_token = token_value;
			go to fail_with_token;
		     end;

		     select_expression.element (selx).opcode = comparison_opcode (cx);

		     Ptoken = token.Pnext;
		     if Ptoken = null
		     then go to not_enough_input;

		     if (token_value = ":null") | (token_value = ":numeric")
		     then if (comparison_opcode (cx) ^= SELECT_EQ) & (comparison_opcode (cx) ^= SELECT_NEQ)
			then do;
			     if token_value = ":null"
			     then bv_code = lister_codes_$invalid_op_null;
			     else bv_code = lister_codes_$invalid_op_numeric;
			     go to fail;
			end;
			else if token_value = ":null"
			then select_expression.element (selx).literal_index = NULL_FIELD;
			else select_expression.element (selx).literal_index = NUMERIC_FIELD;
		     else select_expression.element (selx).literal_index = allocate_literal (cx > 6 & cx < 11);

		     select_expression.element (selx).top = "0"b;
		     select_expression.element (selx).unused = ""b;
		     Ptoken = token.Pnext;
		     return (selx);
		end;

not_enough_input:
		bv_code = lister_codes_$incomplete_select_expression;
		go to fail;

allocate_literal:
		procedure (P_numeric_literal) returns (fixed bin);

/* parameters */

declare  P_numeric_literal bit (1) aligned parameter;

/* program */

		     ltx = ltx + 1;
		     if ltx > hbound (literal_table.literal, 1)
		     then do;
			bv_code = lister_codes_$too_many_literals;
			go to fail;
		     end;

		     if P_numeric_literal
		     then do;
			allocate numeric_atom in (system_area) set (atomp);
			numeric_atom.flag = numeric_flag;

(conversion):
			numeric_atom.value = convert (numeric_atom.value, token_value);
		     end;
		     else do;
			atom_length = length (token_value);
			allocate atom in (system_area) set (atomp);
			atom = token_value;
		     end;

		     literal_table.literal (ltx) = atomp;
		     literal_table.n_literals = literal_table.n_literals + 1;
		     return (ltx);

		end allocate_literal;

	     end					/* primitive */;

	end					/* expression_parse */;

     end						/* lister_compile_select_ */;
   



		    lister_compile_sort_.pl1        11/05/84  1154.9r w 11/05/84  1151.5       50409


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

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

/* LISTER_COMPILE_SORT_ - Program to convert a character string representation of
   a sort description into the compiled form.

   Written 770718 by PG
   Modified 770817 by PG to fix bug in scanning sort string
   Modified 790702 by PG to add numeric sorting.
*/

/* format: style3 */
lister_compile_sort_:
     procedure (bv_arg_string, bv_in_file_ptr, bv_area_ptr, bv_sort_list_ptr, bv_error_token, bv_code)
	     options (packed_decimal);

/* parameters */

declare (
         bv_arg_string char (*),
         bv_in_file_ptr ptr,
         bv_area_ptr ptr,
         bv_sort_list_ptr ptr,
         bv_error_token char (*),
         bv_code fixed bin (35)
         ) parameter;

/* automatic */

declare  code fixed bin (35),
         sortx fixed bin,
         strx fixed bin (21),
         token char (32) varying;

/* builtins */

declare (length, null, search, substr, verify)
         builtin;

/* conditions */

declare  cleanup condition;

/* external static */

declare (
         error_table_$badopt,
         lister_codes_$misplaced_control_arg,
         lister_codes_$null_sort_string,
         lister_codes_$undefined_fieldname
         ) fixed bin (35) external static;

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	area_ptr = bv_area_ptr;
	sort_list_ptr = null;

	on cleanup
	     call cleanup_handler;

	n_items_to_sort = 0;			/* count number of fieldnames */
	strx = 1;

	call get_next_argument;
	if code ^= 0
	then do;
	     bv_code = lister_codes_$null_sort_string;
	     bv_error_token = "";
	     return;
	end;

	do while (code = 0);
	     if substr (token, 1, 1) ^= "-"
	     then n_items_to_sort = n_items_to_sort + 1;

	     call get_next_argument;
	end;
	strx = 1;

	allocate sort_list in (system_area);

	sortx = n_items_to_sort;			/* fill sort array backwards */

/* Rescan the string placing the information into the sort_list */

	call get_next_argument;

	if substr (token, 1, 1) = "-"
	then do;
	     call cleanup_handler;
	     bv_error_token = token;
	     bv_code = lister_codes_$misplaced_control_arg;
	     return;
	end;

	sort_list.key (sortx).field_index = lister_hash_fid_ (in_file_ptr, (token));

	if sort_list.key (sortx).field_index = -1
	then do;
	     call cleanup_handler;
	     bv_error_token = token;
	     bv_code = lister_codes_$undefined_fieldname;
	     return;
	end;

	sort_list.key (sortx).ascending = "1"b;
	sort_list.key (sortx).numeric = "0"b;

	call get_next_argument;

	do while (code = 0);
	     if token = "-asc" | token = "-ascending"
	     then sort_list (sortx).ascending = "1"b;
	     else if token = "-dsc" | token = "-descending"
	     then sort_list (sortx).ascending = "0"b;
	     else if token = "-num" | token = "-numeric"
	     then sort_list (sortx).numeric = "1"b;
	     else if token = "-alp" | token = "-alphabetic"
	     then sort_list (sortx).numeric = "0"b;
	     else if substr (token, 1, 1) = "-"
	     then do;
		bv_error_token = token;
		bv_code = error_table_$badopt;
		call cleanup_handler;
		return;
	     end;
	     else do;
		sortx = sortx - 1;
		sort_list.key (sortx).field_index = lister_hash_fid_ (in_file_ptr, (token));

		if sort_list.key (sortx).field_index = -1
		then do;
		     call cleanup_handler;
		     bv_error_token = token;
		     bv_code = lister_codes_$undefined_fieldname;
		     return;
		end;

		sort_list.key (sortx).ascending = "1"b;
						/* default */
		sort_list.key (sortx).numeric = "0"b;
						/* .. */
	     end;

	     call get_next_argument;
	end;

	bv_sort_list_ptr = sort_list_ptr;
	bv_code = 0;
	return;

cleanup_handler:
	procedure ();

	     if sort_list_ptr ^= null
	     then do;
		free sort_list in (system_area);
		sort_list_ptr = null;
	     end;
	     return;

	end cleanup_handler;

get_next_argument:
	procedure ();

/* automatic */

declare  scanx fixed bin (21);

/* internal static */

declare  TAB_SP char (2) init ("	 ") internal static;

/* program */

/* If all of input string has been scanned, return eof code */

	     if strx > length (bv_arg_string)
	     then do;
		code = 1;
		return;
	     end;

/* Strip leading blanks and tabs */

	     scanx = verify (substr (bv_arg_string, strx), TAB_SP) - 1;

	     if scanx = -1
	     then do;
		code = 1;
		return;
	     end;

	     strx = strx + scanx;

/* Gobble all chars until next tab or space */

	     scanx = search (substr (bv_arg_string, strx), TAB_SP) - 1;

	     if scanx = -1
	     then scanx = length (bv_arg_string) - strx + 1;

	     token = substr (bv_arg_string, strx, scanx);
	     strx = strx + scanx;
	     code = 0;
	     return;

	end get_next_argument;

     end						/* lister_compile_sort_ */;
   



		    lister_convert_.pl1             11/05/84  1154.9r w 11/05/84  1151.5       19863


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

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

/* Program to convert version 1 lister file to version 2 lister file.

   Written by Paul W. Benjamin, October 22, 1980.
*/

lister_convert_:
     procedure (bv_in_file_ptr, bv_code) options (packed_decimal);

						/* parameters */

declare (
         bv_in_file_ptr ptr,
         bv_code fixed bin (35)
         );

						/* automatic */

declare (
         temp_uid fixed bin (24) unsigned
         );

/* builtin */

declare (
         null
         ) builtin;

/* conditions */

declare (
         no_write_permission,
         not_in_write_bracket
         ) condition;

/* external static */

declare (
         error_table_$bad_ring_brackets,
         error_table_$moderr
         ) fixed bin (35) external static;

/* include */

%include lister_structures;

/* program */

	on no_write_permission goto nowrite;
	on not_in_write_bracket goto badring;

	in_file_ptr = bv_in_file_ptr;
	input_file.version = lister_file_version_2;

	temp_uid = 1;

	do recordp = input_file.record_head repeat input_record.next while (recordp ^= null);
	     input_record.uid = temp_uid;
	     temp_uid = temp_uid + 1;
	end;

	input_file.next_uid = temp_uid;

	bv_code = 0;
	return;

nowrite:	bv_code = error_table_$moderr;
	return;

badring:	bv_code = error_table_$bad_ring_brackets;
	return;

     end;

 



		    lister_copy_file_head_.pl1      11/05/84  1154.9r w 11/05/84  1151.5       26658


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

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

/* LISTER_COPY_FILE_HEAD_ - Program to copy the "header" of a Lister file.

   Written 750712 by PG
   Modified 761115 by PG to rename from assist_copy_file_head_ to lister_copy_file_head_
   Modified 800825 by PB to change to lister file version 2 and assign value to next_uid.
*/

/* format: style3 */
lister_copy_file_head_:
     procedure (bv_in_file_ptr, bv_out_file_ptr) options (packed_decimal);

/* parameters */

dcl (bv_in_file_ptr, bv_out_file_ptr)
     ptr parameter;

/* automatic */

dcl (out_fidp, in_ftp, in_fidp)
     ptr,
     fieldx fixed bin,
     code fixed bin (35);

/* builtins */

dcl (empty, hbound, null, nullo, offset, pointer)
     builtin;

/* entries */

dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	out_file_ptr = bv_out_file_ptr;

	call hcs_$truncate_seg (out_file_ptr, 0, code);

	output_file.area = empty ();
	output_file.record_head = null;
	output_file.record_tail = null;
	output_file.unused (1) = null;
	output_file.unused (2) = null;
	output_file.next_uid = 1;
	output_file.version = lister_file_version_2;
	output_file.n_records = 0;

	in_ftp = input_file.field_table_offset;
	n = hbound (in_ftp -> field_table.index_to_field_id, 1);
	allocate field_table in (output_file.area) set (field_table_ptr);
	output_file.field_table_offset = field_table_ptr;

	field_table.record_delimiter = in_ftp -> field_table.record_delimiter;
	field_table.field_delimiter = in_ftp -> field_table.field_delimiter;
	field_table.hash_field_id_to_index (*) = nullo;

	do fieldx = MIN_FIELD_INDEX to field_table.max_field_index;
	     in_fidp = pointer (in_ftp -> field_table.index_to_field_id (fieldx), input_file.area);
	     out_fidp = lister_hash_fid_$enter (out_file_ptr, (in_fidp -> field_identifier.string));
	     field_table.index_to_field_id (fieldx) = offset (out_fidp, output_file.area);
	     out_fidp -> field_identifier.field_index = fieldx;
	end;

	return;

     end;
  



		    lister_copy_records_.pl1        11/05/84  1154.9r w 11/05/84  1151.5       25317


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

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

/* LISTER_COPY_RECORDS_ - Program to copy records from one Lister file to another.
   Written 750316 by PG
   Modified 761115 by PG to rename from assist_copy_records_ to lister_copy_records_
*/

/* format: style3 */
lister_copy_records_:
     procedure (bv_in_file_ptr, bv_out_file_ptr, bv_list_ptr) options (packed_decimal);

/* parameters */

dcl (bv_in_file_ptr, bv_out_file_ptr, bv_list_ptr)
     ptr parameter;

/* automatic */

dcl  listp ptr,
     listx fixed bin;

/* builtins */

dcl (hbound, lbound, length, null)
     builtin;

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	out_file_ptr = bv_out_file_ptr;
	listp = bv_list_ptr;

/* If no list is given, copy whole input file to output file.
   Otherwise, just copy records specified in list */

	if listp = null
	then do recordp = input_file.record_head repeat (input_record.next) while (recordp ^= null);
	     call copy_record;
	end;
	else do listx = lbound (listp -> list_node.list, 1) to hbound (listp -> list_node.list, 1);
	     recordp = listp -> list_node.list (listx);
	     call copy_record;
	end;

	return;

/* Internal procedure to copy the record pointed to by "recordp" from
   the input file to the output file. */

copy_record:
	procedure;

/* automatic */

dcl (to_recordp, to_atomp)
     ptr,
     fieldx fixed bin;

	     to_recordp = lister_create_record_ (out_file_ptr);

	     do fieldx = lbound (input_record.field, 1) to hbound (input_record.field, 1);
		atomp = input_record.field (fieldx);	/* pick up old field value */
		if atomp ^= null
		then do;
		     atom_length = length (atom);	/* get length of old field */
		     allocate atom in (output_file.area) set (to_atomp);
		     to_atomp -> atom = atom;		/* copy field */
		     to_recordp -> output_record.field (fieldx) = to_atomp;
		end;
	     end;

	end copy_record;

     end;
   



		    lister_create_record_.pl1       11/05/84  1154.9r w 11/05/84  1151.5       32445


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

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

/* LISTER_CREATE_RECORD_ - Program to create a new, empty record in a specified file.
   Written by PG.
   Modified 760427 by PG to add $after entry.
   Modified 770707 by PG to keep output_file.n_records accurate, and to rename
   from assist_create_record_ to lister_create_record_.
   Modified 800825 by PB to assign uid.
*/

/* format: style3 */
lister_create_record_:
     procedure (bv_in_file_ptr) returns (ptr) options (packed_decimal);

/* parameters */

declare (bv_in_file_ptr, bv_previous_record_ptr)
         ptr parameter,
         bv_retained_uid fixed bin (24) unsigned unaligned parameter;

/* builtins */

declare (hbound, null) builtin;

/* automatic */

declare  flx fixed bin,
         previous_record_ptr ptr,
         retained_uid fixed bin (24) unsigned unaligned;

/* include files */

%include lister_structures;

/* program */

	retained_uid = 0;
main:
	call allocate_record;

	if input_file.record_tail = null
	then input_file.record_head = recordp;
	else input_file.record_tail -> input_record.next = recordp;

	input_file.record_tail = recordp;
	input_record.next = null;
	return (recordp);

retain_uid:
	entry (bv_in_file_ptr, bv_retained_uid) returns (ptr);

	retained_uid = bv_retained_uid;
	goto main;

						/* LISTER_CREATE_RECORD_$AFTER: - Entry to create a new, empty record that is
						   threaded into a specific place in the output file.  Used by lister_merge_.
						   Written 760427 by PG.
						*/

assist_create_record_$after:
	entry (bv_in_file_ptr, bv_previous_record_ptr) returns (ptr);

	previous_record_ptr = bv_previous_record_ptr;
	retained_uid = 0;
	call allocate_record;

	if previous_record_ptr = null			/* make new record 1st in file */
	then do;
	     input_record.next = input_file.record_head;
	     input_file.record_head = recordp;

	     if input_file.record_tail = null
	     then input_file.record_tail = recordp;
	end;
	else do;					/* put new record before "previous_record" */
	     input_record.next = previous_record_ptr -> input_record.next;
	     previous_record_ptr -> input_record.next = recordp;
	end;

	return (recordp);

allocate_record:
	procedure;

	     in_file_ptr = bv_in_file_ptr;
	     field_table_ptr = input_file.field_table_offset;

	     allocate input_record in (input_file.area) set (recordp);
	     input_file.n_records = input_file.n_records + 1;

	     if retained_uid = 0
	     then do;
		input_record.uid = input_file.next_uid;
		input_file.next_uid = input_file.next_uid + 1;
	     end;
	     else input_record.uid = retained_uid;

	     do flx = MIN_FIELD_INDEX to hbound (input_record.field, 1);
		input_record.field (flx) = null;
	     end;

	     return;

	end allocate_record;

     end;
   



		    lister_delete_.pl1              11/05/84  1154.9r w 11/05/84  1151.5       33579


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

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

/* Program to delete a list of records from an ASSIST input_file.
   Written 750316 by PG
   Modified 750711 by PG to be able to delete first record in input_file.
   Modified 760916 by PG to be able to delete first record in file (previous fix assumed that freed
   storage was not immediately overwritten...an assumption that turned into a bug with the new area package).
   Modified 761111 by PG to rename from assist_delete_ to lister_delete_.
   Modified 770707 by PG to keep input_file.n_records accurate.
*/

/* format: style3 */
lister_delete_:
     procedure (bv_in_file_ptr, bv_selected_records_ptr) options (packed_decimal);

/* parameters */

dcl (
     bv_in_file_ptr ptr,
     bv_selected_records_ptr
     ptr
     ) parameter;

/* automatic */

dcl (fieldx, listx) fixed bin;
dcl (selected_records_ptr, parentp)
     ptr;

/* builtins */

dcl (dimension, hbound, lbound, length, null)
     builtin;

/* include files */

%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	selected_records_ptr = bv_selected_records_ptr;

	if selected_records_ptr = null
	then return;				/* nothing to do */

	parentp = input_file.record_head;

	do listx = lbound (selected_records_ptr -> list, 1) to hbound (selected_records_ptr -> list, 1);
	     recordp = selected_records_ptr -> list (listx);

/* First find the record before the record to be deleted.  The list
   of records to be deleted is assumed to be in the same relative
   order as the file itself.

   Next, unthread the record to be deleted from the
   file's record list.  There are three cases:

   case 1: the record is the first record on the list.
   case 2: the record is neither the first nor the last on the list.
   case 3: the record is the last record on the list.
*/

	     if input_file.record_head ^= recordp	/* if not first record */
	     then do;
		do parentp = parentp repeat parentp -> input_record.next
			while (parentp -> input_record.next ^= recordp);
		end;

		parentp -> input_record.next = input_record.next;
						/* case 2 */
	     end;
	     else parentp, input_file.record_head = input_record.next;
						/* case 1 */

	     if input_file.record_tail = recordp
	     then input_file.record_tail = parentp;	/* case 3 */

/* Free all storage assigned to this record */

	     do fieldx = lbound (input_record.field, 1) to hbound (input_record.field, 1);
		atomp = input_record.field (fieldx);

		if atomp ^= null			/* Is there a data item there? */
		then do;
		     atom_length = length (atom);	/* set varying string max length */
		     free atom in (input_file.area);
		end;
	     end;

	     free input_record in (input_file.area);
	end;					/* do listx = */

	input_file.n_records = input_file.n_records - dimension (selected_records_ptr -> list_node.list, 1);

     end						/* lister_delete_ */;
 



		    lister_expand_.pl1              11/05/84  1154.9r w 11/05/84  1151.5       66303


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

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

/* This program converts a Lister file into a Lister ASCII input segment. */

/* Written by Paul A. Green on September 2, 1974. */
/* Modified 770923 by PG to rename from assist_expand_ to lister_expand_.
   Modified 791128 by PG to requote fields if necessary. (sugg 003)
   Modified 800318 by PG to add output_all_fieldnames control for MJG.
*/

/* format: style3 */
lister_expand_:
     procedure (P_in_file_ptr, P_output_ptr, P_output_index, P_width, P_output_all_fieldnames) returns (fixed bin)
	     options (packed_decimal);

/* parameters */

declare (
         P_in_file_ptr ptr,				/* (input) ptr to ASSIST file */
         P_output_ptr ptr,				/* (input) ptr to output segment */
         P_output_index fixed bin (21),			/* (in/out) 1-origin character index of next free char. */
         P_width fixed bin,				/* (input) line width to use */
         P_output_all_fieldnames
         bit (1) aligned				/* (input) ON if we should always put out =fieldname */
         ) parameter;

/* automatic */

declare  atomx fixed bin (21),
         fd char (1),
         n_chars fixed bin (21),
         out_ptr ptr,
         output_all_fieldnames
         bit (1) aligned,				/* ON if we should always put out =fieldname */
         quote bit (1) aligned,			/* ON if atom needs to be quoted */
         rd char (1),
         sp_fd char (2) aligned,
        (fi, line_index, line_length, out)
         fixed bin (21),
         n_records fixed bin;

/* based */

declare  out_string char (1044480) based (out_ptr) unaligned;

/* builtin */

declare (hbound, index, lbound, length, null, pointer, substr)
         builtin;

/* internal static */

declare (
         NL char (1) init ("
"),
         QUOTE char (1) init (""""),
         QUOTE_QUOTE char (2) init (""""""),
         NL_HT_SP_VT_NP char (5) init ("
	 "),
         SEMI_NL char (2) init (";
")
         ) internal static options (constant);

/* include files */

%include lister_structures;

/* program */

	in_file_ptr = P_in_file_ptr;
	out_ptr = P_output_ptr;
	out = P_output_index;
	output_all_fieldnames = P_output_all_fieldnames;

	field_table_ptr = input_file.field_table_offset;

	if P_width <= 0
	then line_length = 0;			/* will put one field per line... */
	else line_length = P_width;

	rd = field_table.record_delimiter;
	fd = field_table.field_delimiter;
	sp_fd = "  ";
	substr (sp_fd, 2, 1) = fd;

/* initialize some variables */

	n_records = 0;
	line_index = 0;

/* Put out the field & record delimiters */

	call put ("Record_delimiter: ");
	call put (rd);
	call put (SEMI_NL);

	call put ("Field_delimiter: ");
	call put (fd);
	call put (SEMI_NL);

/* put out the names of the fields */

	line_index = 0;
	call put ("Field_names: ");

	fidp = pointer (field_table.index_to_field_id (0), input_file.area);
	call put (field_identifier.string);

	do fi = 1 to hbound (field_table.index_to_field_id (*), 1);
	     fidp = pointer (field_table.index_to_field_id (fi), input_file.area);
	     call put (",");

	     if (line_length = 0 & line_index > 132) | (line_length > 0 & line_index > line_length)
	     then do;
		call put (NL);
		line_index = 0;
	     end;
	     else call put (" ");

	     call put (field_identifier.string);
	end;

/* end the list of names with a semi-colon, and put in a blank line. */

	call put (";

Records:
");

/* now copy each record into the output segment */

	do recordp = input_file.record_head repeat input_record.next while (recordp ^= null);

/* we assume that there are no null records */

	     n_records = n_records + 1;		/* count up number of records */

	     substr (out_string, out, 1) = rd;
	     out = out + 1;
	     line_index = 1;

	     do fi = lbound (field_table.index_to_field_id (*), 1) to hbound (field_table.index_to_field_id (*), 1);
		atomp = input_record.field (fi);

		if atomp ^= null | output_all_fieldnames
		then do;
		     if atomp = null
		     then atom_length = 0;
		     else atom_length = length (atom);

		     fidp = pointer (field_table.index_to_field_id (fi), input_file.area);
		     n = length (field_identifier.string);

/* See if length(chars_to_far) + length(fid)+1 + length (atom) + length(sp_fd) + length(two_quotes) > line_length */

		     if line_index + n + atom_length + 5 > line_length
		     then do;
			substr (out_string, out, 1) = NL;
			out = out + 1;
			line_index = 0;
		     end;

		     substr (out_string, out, 2) = sp_fd;
		     out = out + 2;

		     substr (out_string, out, n + 1) = field_identifier.string;
						/* pad with a space */
		     out = out + n + 1;
		end;

		if atomp ^= null
		then do;
		     n_chars = index (atom, QUOTE) - 1;
		     if n_chars = -1
		     then do;
			n_chars = length (atom);
			quote = "0"b;
		     end;
		     else quote = "1"b;

		     if ^quote
		     then if index (atom, rd) ^= 0 | index (atom, fd) ^= 0
			then quote = "1"b;

		     if ^quote
		     then if length (atom) > 0
			then if index (NL_HT_SP_VT_NP, substr (atom, 1, 1)) ^= 0
			     | index (NL_HT_SP_VT_NP, substr (atom, length (atom), 1)) ^= 0
			     then quote = "1"b;
			     else ;
			else quote = "1"b;		/* zero-length token */

		     if quote
		     then do;
			substr (out_string, out, 1) = QUOTE;
			out = out + 1;
			line_index = line_index + 1;
		     end;

		     atomx = 1;
		     do while (atomx <= length (atom));
			substr (out_string, out, n_chars) = substr (atom, atomx, n_chars);
			out = out + n_chars;
			atomx = atomx + n_chars;
			line_index = line_index + n_chars;

			if atomx <= length (atom)
			then do;			/* must have stopped on QUOTE */
			     atomx = atomx + 1;
						/* step over quote */
			     substr (out_string, out, 2) = QUOTE_QUOTE;
			     out = out + 2;
			     line_index = line_index + 2;
			     n_chars = index (substr (atom, atomx), QUOTE) - 1;
			     if n_chars = -1
			     then n_chars = length (substr (atom, atomx));
			end;
		     end;

		     if quote
		     then do;
			substr (out_string, out, 1) = QUOTE;
			out = out + 1;
			line_index = line_index + 1;
		     end;
		end;
	     end;

	     substr (out_string, out, 1) = NL;
	     out = out + 1;
	end;

	P_output_index = out;
	return (n_records);

put:
	procedure (P_string);

/* parameters */

declare  P_string char (*) parameter;

/* program */

	     substr (out_string, out, length (P_string)) = P_string;
	     out = out + length (P_string);
	     line_index = line_index + length (P_string);
	     return;

	end put;

     end						/* lister_expand_ */;
 



		    lister_format_parse_.pl1        11/05/84  1154.9r w 11/02/84  1204.7      150579


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

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

/* Modified 780407 by PG to implement :argN and suggestion 20 (map << to <)
   Modified 781010 by PG to get :argN to parse correctly.
   Modified 791217 by PG to fix 027 (pls dies if fieldname used in Before or After section).
   Modified 800414 by PB to put line numbers in listform error messages.
   Modified 800813 by PB to recognize :uid.
   Modified 840521 by PB to allow :argumentN as alternate for :argN.
*/

/* format: style3 */
lister_format_parse_:
     procedure (bv_in_file_ptr, bv_area_ptr, bv_input, bv_format_table_ptr, bv_error_token, bv_code) options (packed_decimal);

/* parameters */

declare (
         bv_in_file_ptr ptr,
         bv_area_ptr ptr,
         bv_input char (*),
         bv_format_table_ptr ptr,
         bv_error_token char (*),
         bv_code fixed bin (35)
         ) parameter;

/* automatic */

declare  c char (1) aligned,
         code fixed bin (35),
         comma_seen bit (1) aligned,
         commax fixed bin (21),
         done bit (1) aligned,
         eof bit (1) aligned,
         field_arg_number fixed bin,
         field_index fixed bin,
         field_justification bit (2) aligned,
         field_width fixed bin (21),
         fmt_length fixed bin (21),
         fmtx fixed bin,
         format_begin fixed bin,
         keyword_type fixed bin,
         line_no fixed bin,
         literals_done bit (1) aligned,
         litx fixed bin,
         scan_index fixed bin (21),
         scan_start fixed bin (21),
         token_len fixed bin (21);

/* builtin */

declare (char, hbound, index, length, ltrim, null, substr, verify)
         builtin;

/* entries */

declare  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);

/* external static */

declare (
         lister_codes_$dup_format,
         lister_codes_$listform_bad_arg_number,
         lister_codes_$listform_bad_justify,
         lister_codes_$listform_bad_width,
         lister_codes_$listform_misplaced_fieldname,
         lister_codes_$listform_missing_begin,
         lister_codes_$listform_missing_gt,
         lister_codes_$listform_missing_lt,
         lister_codes_$listform_unknown_fieldname,
         lister_codes_$listform_unknown_keyword
         ) fixed bin (35) external static;

/* internal static */

declare (
         NL char (1) initial ("
"),
         NL_HT_SP_VT_NP char (5) initial ("
	 "),
         format_type (3) char (6) varying initial ("before", "record", "after"),
         BEFORE fixed bin initial (1),
         RECORD fixed bin initial (2),
         AFTER fixed bin initial (3)
         ) internal static;

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	area_ptr = bv_area_ptr;
	bv_format_table_ptr = null;
	bv_code = 0;

/* Allocate initial format table and literal table. */

	n = 50;
	allocate format_table in (system_area) set (format_table_ptr);
	format_table.size = n;
	format_table.before = 0;
	format_table.after = 0;
	format_table.record = 0;

	n = 50;
	allocate literal_table in (system_area) set (ltp);
	format_table.literal_table = ltp;
	literal_table.size = n;
	literal_table.n_literals = 0;

	fmtx = 0;					/* no formats so far */
	litx = 0;					/* no literals so far */

/* Now parse the listform segment. */

	scan_start = 1;
	line_no = 1;
	eof = "0"b;
	do while (^eof);

/* Skip white space */

	     scan_index = verify (substr (bv_input, scan_start), NL_HT_SP_VT_NP) - 1;

	     if scan_index ^= -1
	     then do;
		call bump_line_no (scan_start, scan_index);
		scan_start = scan_start + scan_index;

		call parse_block ();
		if bv_code ^= 0
		then return;
	     end;
	     else eof = "1"b;
	end;

/* All done, wrap things up... */

	bv_format_table_ptr = format_table_ptr;
	return;

parse_block:
	procedure ();

/* program */

	     if substr (bv_input, scan_start, 1) ^= "<"
	     then do;
		bv_code = lister_codes_$listform_missing_lt;
		bv_error_token = NL||"Error in line "||ltrim (char (line_no))||".";
		return;
	     end;

	     scan_start = scan_start + 1;

	     if substr (bv_input, scan_start, 6) ^= "Begin "
	     then do;
		bv_code = lister_codes_$listform_missing_begin;
		bv_error_token = NL||"Error in line "||ltrim (char (line_no))||".";
		return;
	     end;

	     scan_start = scan_start + 6;

	     if substr (bv_input, scan_start, 8) = "before:>"
	     then keyword_type = BEFORE;
	     else if substr (bv_input, scan_start, 8) = "record:>"
	     then keyword_type = RECORD;
	     else if substr (bv_input, scan_start, 7) = "after:>"
	     then keyword_type = AFTER;
	     else do;
		bv_code = lister_codes_$listform_unknown_keyword;
		bv_error_token = substr (bv_input, scan_start, index (substr (bv_input, scan_start), ">") - 1)||NL||"Error in line "||ltrim (char (line_no))||".";
		return;
	     end;

	     if keyword_type = AFTER
	     then scan_start = scan_start + 7;
	     else scan_start = scan_start + 8;

	     format_begin = fmtx + 1;
	     done = "0"b;
	     do while (^done);

/* Scan literal field */

		literals_done = "0"b;
		do while (^literals_done);
		     scan_index = index (substr (bv_input, scan_start), "<") - 1;
		     if scan_index = -1
		     then do;
			bv_code = lister_codes_$listform_missing_lt;
			bv_error_token = NL||"Error in line "||ltrim (char (line_no))||".";
			return;
		     end;

/* Check for "<<" ... gets mapped into "<" */

		     if scan_start + scan_index < length (bv_input)
		     then if substr (bv_input, scan_start + scan_index + 1, 1) = "<"
			then scan_index = scan_index + 1; /* include first < in current literal */
			else literals_done = "1"b;
		     else literals_done = "1"b;

		     if scan_index > 0
		     then do;			/* We have a literal, save it */
			fmtx = fmtx + 1;
			if fmtx > hbound (format_table.item, 1)
			then call reallocate_format_table;

			if substr (bv_input, scan_start, scan_index) = ""
			then do;
			     format_table.item (fmtx).action = PUT_SPACES;
			     format_table.item (fmtx).width = scan_index;
			end;
			else do;
			     format_table.item (fmtx).action = PUT_LITERAL;
			     format_table.item (fmtx).width = save_literal (scan_start, scan_index);
			end;

			call bump_line_no (scan_start, scan_index);
			scan_start = scan_start + scan_index;
						/* step over literal */

		     end;

/* Current char = "<". Step over it. */

		     scan_start = scan_start + 1;
		end;

/* Scan format field. */

		fmt_length = index (substr (bv_input, scan_start), ">");
		if fmt_length = 0
		then do;
		     bv_code = lister_codes_$listform_missing_gt;
		     bv_error_token = NL||"Error in line "||ltrim (char (line_no))||".";
		     return;
		end;

		if substr (bv_input, scan_start, fmt_length) = "end;>"
		then do;
		     scan_start = scan_start + 5;	/* step over "end;>" */

		     if keyword_type = BEFORE
		     then do;
			if format_table.before ^= 0
			then go to duplicate_keyword;

			format_table.before = format_begin;
		     end;
		     else if keyword_type = RECORD
		     then do;
			if format_table.record ^= 0
			then go to duplicate_keyword;

			format_table.record = format_begin;
		     end;
		     else do;
			if format_table.after ^= 0
			then do;

duplicate_keyword:
			     bv_code = lister_codes_$dup_format;
			     bv_error_token = format_type (keyword_type)||NL||"Error in line "||ltrim (char (line_no))||".";
			     return;
			end;

			format_table.after = format_begin;
		     end;

		     fmtx = fmtx + 1;
		     if fmtx > hbound (format_table.item, 1)
		     then call reallocate_format_table;

		     format_table.item (fmtx).action = PUT_END;
		     done = "1"b;
		end;
		else do;

/* Scanning regular format. Syntax is: <fieldname [,fieldlen [,justify]]> */

		     commax = index (substr (bv_input, scan_start, fmt_length), ",");
		     if commax = 0
		     then do;
			comma_seen = "0"b;
			token_len = fmt_length - 1;
		     end;
		     else do;
			comma_seen = "1"b;
			token_len = commax - 1;
		     end;

		     field_index = lister_hash_fid_ (in_file_ptr, substr (bv_input, scan_start, token_len));
		     if field_index = -1
		     then if substr (bv_input, scan_start, token_len) = ":date"
			then field_index = PUT_DATE;
			else if substr (bv_input, scan_start, token_len) = ":time"
			then field_index = PUT_TIME;
			else if substr (bv_input, scan_start, token_len) = ":record_count"
			then field_index = PUT_RECORD_COUNT;
			else if substr (bv_input, scan_start, token_len) = ":uid"
			then field_index = PUT_UID;
			else do;
			     call check_for_arg;
			     if bv_code ^= 0 
				then return;
			end;
		     else field_arg_number = 0;

		     if (field_index >= 0) & (keyword_type ^= RECORD)
		     then do;
			bv_code = lister_codes_$listform_misplaced_fieldname;
			bv_error_token = substr (bv_input, scan_start, token_len)||NL||"Error in line "||ltrim (char (line_no))||".";
			return;
		     end;

		     call bump_line_no (scan_start, token_len);
		     scan_start = scan_start + token_len;
						/* step over fieldname */
		     fmt_length = fmt_length - token_len;
						/* reduce format length */

		     if comma_seen
		     then do;
			scan_start = scan_start + 1;
			fmt_length = fmt_length - 1;
		     end;

/* Fieldname scanned, check for field width */

		     commax = index (substr (bv_input, scan_start, fmt_length), ",");
		     if commax = 0
		     then do;
			comma_seen = "0"b;
			token_len = fmt_length - 1;
		     end;
		     else do;
			comma_seen = "1"b;
			token_len = commax - 1;
		     end;

		     if token_len > 0
		     then do;
			field_width = cv_dec_check_ (substr (bv_input, scan_start, token_len), code);
			if code ^= 0 | field_width < 0
			then do;
			     bv_code = lister_codes_$listform_bad_width;
			     bv_error_token = substr (bv_input, scan_start, token_len)||NL||"Error in line "||ltrim (char (line_no))||".";
			     return;
			end;
		     end;
		     else field_width = 0;

		     call bump_line_no (scan_start, token_len);
		     scan_start = scan_start + token_len;
		     fmt_length = fmt_length - token_len;

		     if comma_seen
		     then do;
			scan_start = scan_start + 1;
			fmt_length = fmt_length - 1;
		     end;

/* Width scanned, check for justification */

		     token_len = fmt_length - 1;

		     if token_len > 0
		     then do;
			c = substr (bv_input, scan_start, 1);

			if ((c = "l") | (c = "L")) & token_len = 1
			then field_justification = flush_left;
			else if ((c = "r") | (c = "R")) & token_len = 1
			then field_justification = flush_right;
			else if ((c = "c") | (c = "C")) & token_len = 1
			then field_justification = center;
			else do;
			     bv_code = lister_codes_$listform_bad_justify;
			     bv_error_token = substr (bv_input, scan_start, token_len)||NL||"Error in line "||ltrim (char (line_no))||".";
			     return;
			end;
		     end;
		     else field_justification = flush_left;

		     call bump_line_no (scan_start, fmt_length);
		     scan_start = scan_start + fmt_length;
						/* step over rest of format */

		     fmtx = fmtx + 1;
		     if fmtx > hbound (format_table.item, 1)
		     then call reallocate_format_table;

		     format_table.item (fmtx).action = field_index;
		     format_table.item (fmtx).width = field_width;
		     format_table.item (fmtx).justification = field_justification;
		     format_table.item (fmtx).argument_number = field_arg_number;
		end;
	     end;					/* do while (^done) */

reallocate_format_table:
	     procedure ();

/* automatic */

declare  fmx fixed bin,
         new_format_table_ptr
         ptr;

/* program */

		n = format_table.size + 50;
		allocate format_table in (system_area) set (new_format_table_ptr);

		new_format_table_ptr -> format_table.size = n;
		new_format_table_ptr -> format_table.before = format_table.before;
		new_format_table_ptr -> format_table.after = format_table.after;
		new_format_table_ptr -> format_table.record = format_table.record;
		new_format_table_ptr -> format_table.literal_table = format_table.literal_table;

		do fmx = 1 to format_table.size;
		     new_format_table_ptr -> format_table.item (fmx) = format_table.item (fmx);
		end;

		n = format_table.size;
		free format_table in (system_area);
		format_table_ptr = new_format_table_ptr;
		return;

	     end reallocate_format_table;

reallocate_literal_table:
	     procedure ();

/* automatic */

declare  ltx fixed bin,
         new_ltp ptr;

/* program */

		n = literal_table.size + 50;
		allocate literal_table in (system_area) set (new_ltp);

		new_ltp -> literal_table.size = n;
		new_ltp -> literal_table.n_literals = literal_table.n_literals;

		do ltx = 1 to literal_table.size;
		     new_ltp -> literal_table.literal (ltx) = literal_table.literal (ltx);
		end;

		n = literal_table.size;
		free literal_table in (system_area);

		ltp = new_ltp;
		format_table.literal_table = ltp;
		return;

	     end reallocate_literal_table;


save_literal:
	     procedure (bv_lit_start, bv_lit_length) returns (fixed bin);

/* parameters */

declare (
         bv_lit_start fixed bin (21),
         bv_lit_length fixed bin (21)
         ) parameter;

/* automatic */

declare  found bit (1) aligned,
         new_litx fixed bin;

/* program */

		found = "0"b;
		do new_litx = 1 to litx while (^found);
		     if length (literal_table.literal (new_litx) -> atom) = bv_lit_length
		     then if literal_table.literal (new_litx) -> atom = substr (bv_input, bv_lit_start, bv_lit_length)
			then found = "1"b;
		end;

		if ^found
		then do;
		     atom_length = bv_lit_length;
		     allocate atom in (system_area) set (atomp);
		     atom = substr (bv_input, bv_lit_start, bv_lit_length);
		     new_litx, litx = litx + 1;
		     if litx > hbound (literal_table.literal, 1)
		     then call reallocate_literal_table;

		     literal_table.literal (new_litx) = atomp;
		     literal_table.n_literals = literal_table.n_literals + 1;
		end;
		else new_litx = new_litx - 1;

		return (new_litx);

	     end save_literal;

	end					/* parse_block */;


bump_line_no:
	procedure (bv_scan_start, bv_bump_amt);

						/* parameters */

declare (
         bv_scan_start fixed bin (21),
         bv_bump_amt fixed bin (21)
         ) parameter;

						/* automatic */

declare  offset fixed bin,
         index_cnt fixed bin;

						/* program */

	     offset = 0;
	     index_cnt = index (substr (bv_input, bv_scan_start + offset, bv_bump_amt - offset), NL);
	     do while (index_cnt ^= 0);
		line_no = line_no + 1;
		offset = offset + index_cnt;
		index_cnt = index (substr (bv_input, bv_scan_start + offset, bv_bump_amt - offset), NL);
	     end;

	end bump_line_no;

check_for_arg:
	     proc;

               if token_len > 4 & token_len < 10
		then if substr (bv_input, scan_start, 4) = ":arg" & token_len < 10
		then do;
		field_index = PUT_ARGUMENT;
		field_arg_number =
		     cv_dec_check_ (substr (bv_input, scan_start + 4, token_len - 4), code);
		if code ^= 0 | field_arg_number < 0
		     then do;
		     bv_code = lister_codes_$listform_bad_arg_number;
		     bv_error_token = substr (bv_input, scan_start + 4, token_len - 4)
			||NL||"Error in line "||ltrim (char (line_no))||".";
		end;
		return;
	     end;
	     if token_len > 9 
		then if substr (bv_input, scan_start, 9) = ":argument"
		then do;
		field_index = PUT_ARGUMENT;
		field_arg_number =
		     cv_dec_check_ (substr (bv_input, scan_start + 9, token_len - 9), code);
		if code ^= 0 | field_arg_number < 0
		     then do;
		     bv_code = lister_codes_$listform_bad_arg_number;
		     bv_error_token = substr (bv_input, scan_start + 9, token_len - 9)||NL||"Error in line "||ltrim (char (line_no))||".";
		end;
		return;
	     end;
	     bv_code = lister_codes_$listform_unknown_fieldname;
	     bv_error_token = substr (bv_input, scan_start, token_len)||NL||"Error in line "||ltrim (char (line_no))||".";

	end check_for_arg;

     end						/* lister_format_parse_ */;
 



		    lister_hash_fid_.pl1            11/05/84  1154.9r w 11/05/84  1151.5       32976


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

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

/* format: style3 */
lister_hash_fid_:
     procedure (bv_in_file_ptr, field_id, return_field_index) options (packed_decimal);

/* Modified 791221 by PG to use rank builtin */

/* parameters */

dcl (
     bv_in_file_ptr ptr,
     field_id char (*),
     return_field_index fixed bin,
     return_field_ptr ptr
     ) parameter;

/* automatic */

dcl  main_entry bit (1) aligned;
dcl (i, j, k) fixed bin;
dcl  mod_2_sum bit (36) aligned;
dcl  hash_index fixed bin;
dcl (p, old_fidp) ptr;

/* builtins */

dcl (addr, binary, bool, dim, divide, length, mod, null, offset, pointer, rank, substr)
     builtin;

/* based */

dcl  string_bit_array dim (0:65536) bit (36) unal based (p);

/* internal static */

dcl  mask dim (3) bit (36) aligned int static init ((9)"1"b, (18)"1"b, (27)"1"b);

/* include files */

%include lister_structures;

/* program */

	main_entry = "1"b;
	go to begin;

lister_hash_fid_$enter:
	entry (bv_in_file_ptr, field_id, return_field_ptr);

	main_entry = "0"b;
begin:
	in_file_ptr = bv_in_file_ptr;
	n = length (field_id);
	if n = 1
	then hash_index = mod (rank (substr (field_id, 1, 1)), dim (hash_field_id_to_index, 1));
	else do;
	     p = addr (field_id);
	     mod_2_sum = "0"b;
	     j = divide (n - 1, 4, 17, 0);
	     k = n - 4 * j;
	     if k ^= 4
	     then string_bit_array (j) = string_bit_array (j) & mask (k);
	     do i = 0 to j;
		mod_2_sum = bool (mod_2_sum, string_bit_array (i), "0110"b);
	     end;
	     hash_index = mod (binary (mod_2_sum, 35), dim (hash_field_id_to_index, 1));
	end;

	old_fidp = null;
	field_table_ptr = input_file.field_table_offset;
	do fidp = pointer (field_table.hash_field_id_to_index (hash_index), input_file.area)
		repeat pointer (fidp -> field_identifier.next, input_file.area) while (fidp ^= null);

	     if n < fidp -> field_identifier.size
	     then go to not_found;
	     if n = fidp -> field_identifier.size
	     then if field_id = fidp -> field_identifier.string
		then do;
		     if main_entry
		     then return_field_index = fidp -> field_identifier.field_index;
		     else return_field_ptr = null;	/* it already exists */
		     return;
		end;
	     old_fidp = fidp;
	end;

not_found:
	if main_entry
	then do;
	     return_field_index = -1;			/* not found */
	     return;
	end;

	p = fidp;
	allocate field_identifier in (input_file.area) set (fidp);
	fidp -> field_identifier.next = offset (p, input_file.area);
	fidp -> field_identifier.field_index = -1;
	fidp -> field_identifier.string = field_id;

	if old_fidp = null
	then field_table.hash_field_id_to_index (hash_index) = offset (fidp, input_file.area);
	else old_fidp -> field_identifier.next = offset (fidp, input_file.area);

	return_field_ptr = fidp;
	return;

     end						/* lister_hash_fid_ */;



		    lister_merge_.pl1               11/05/84  1154.9r w 11/05/84  1151.5       74322


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

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

/* Procedure to merge two Lister files into a new Lister file.
   Written 760415 by PG after several false starts.
   Modified 761116 by PG to rename from assist_merge_ to lister_merge_.
   Modified 800522 by PB to abort processing when 2 files don't have same fields
   in the same order.  This is an interim fix, future
   implementation will resolve differences.
   Modified 800523 by PB to make field comparison case-insensitive.
   Modified 800825 by PB to handle unique ids.
   Modified 800923 by PB to allow update file to have a subset of master file's
   fields and to have fields in different order.
*/

/* format: style3 */
lister_merge_:
     procedure (bv_input_file_ptr, bv_update_file_ptr, bv_output_file_ptr, bv_field_list, bv_n_fields, bv_merge_type, bv_code)
	     returns ((3) fixed bin) options (packed_decimal);

/* external static */

dcl  lister_codes_$master_not_like_update ext static fixed bin (35);

						/* parameters */

dcl (
    (bv_input_file_ptr, bv_output_file_ptr, bv_update_file_ptr)
     ptr,
     bv_field_list fixed bin dim (*),
     bv_n_fields fixed bin,
     bv_merge_type fixed bin,
     bv_code fixed bin (35)
     ) parameter;

/* automatic */

dcl (ifp, inftptr, irp, equiv_table_ptr, previous_irp, ufp, upftptr, urp)
     ptr,
     counts (3) fixed bin,
    (flx, fx, i, j, equiv, merge_type, n_fields, rel)
     fixed bin;

/* based */

dcl  equiv_table (0:inftptr -> field_table.max_field_index)
     fixed bin based (equiv_table_ptr);

/* builtin */

dcl (hbound, lbound, length, null, pointer, translate)
     builtin;

/* internal static */

dcl (
    (
     LESS_THAN initial (1),
     EQUAL initial (2),
     GREATER_THAN initial (3)
     ) fixed bin,
    (
     lower_case initial ("abcdefghijklmnopqrstuvwxyz"),
     upper_case initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     ) char (26) aligned
     ) internal static options (constant);

/* include files */

%include lister_entries;
%include lister_structures;

/* program */

	in_file_ptr = bv_input_file_ptr;
	up_file_ptr = bv_update_file_ptr;
	out_file_ptr = bv_output_file_ptr;
	merge_type = bv_merge_type;
	n_fields = bv_n_fields;
	bv_code = 0;

	counts (1) = 0;
	counts (2) = 0;
	counts (3) = 0;
	previous_irp = null;			/* old value of irp */
	inftptr = input_file.field_table_offset;
	upftptr = update_file.field_table_offset;
	allocate equiv_table;
	do i = 0 to inftptr -> field_table.max_field_index;
	     equiv_table (i) = -1;
	end;
	call compare_field_tables;
	if bv_code ^= 0 then do;
	     free equiv_table;
	     return (counts);
	end;

	call lister_copy_file_head_ (in_file_ptr, out_file_ptr);

	output_file.next_uid = input_file.next_uid;

	irp = input_file.record_head;
	urp = update_file.record_head;

merge_loop:
	if irp ^= null
	then if urp ^= null
	     then do;
		do flx = lbound (bv_field_list, 1) to n_fields;
		     fx = bv_field_list (flx);
		     ifp = irp -> input_record.field (fx);
		     if equiv_table (fx) = -1
		     then ufp = null;
		     else ufp = urp -> update_record.field (equiv_table (fx));

		     if ifp = null
		     then if ufp = null
			then ;
			else do;
			     rel = LESS_THAN;
			     go to no_match (merge_type);
			end;
		     else if ufp = null
		     then do;
			rel = GREATER_THAN;
			go to no_match (merge_type);
		     end;
		     else do;
			rel = compare (ifp, ufp);
			if rel ^= EQUAL
			then go to no_match (merge_type);
		     end;
		end;

		rel = EQUAL;
		go to match (merge_type);
	     end;
	     else rel = LESS_THAN;			/* irp ^= null, urp = null */
	else if urp = null				/* irp = null, urp = null */
	then do;
	     free equiv_table;
	     return (counts);			/* ALL DONE. */
	end;
	else rel = GREATER_THAN;			/* irp = null, urp ^= null */

	go to no_match (merge_type);

match (0):					/* ADD */
match (1):					/* AND */
write_input:
	call copy_record (in_file_ptr, irp, "1"b);

match (2):					/* OR  */
match (3):					/* SUBTRACT */
discard_input:
	previous_irp = irp;				/* save old value */
	irp = irp -> input_record.next;		/* step to next input record */
	counts (1) = counts (1) + 1;			/* one more input record processed. */
	go to merge_loop;

no_match (0):					/* ADD */
no_match (2):					/* OR  */
	if rel = LESS_THAN
	then go to write_input;

	call copy_record (up_file_ptr, urp, "0"b);	/* write_update */
	go to discard_update;

no_match (1):					/* AND */
	if rel = LESS_THAN
	then go to discard_input;

	go to discard_update;

no_match (3):					/* SUBTRACT */
	if rel = LESS_THAN
	then go to write_input;

discard_update:
	urp = urp -> update_record.next;
	counts (2) = counts (2) + 1;			/* one more update record processed. */
	go to merge_loop;

compare_field_tables:
	proc;
dcl (infidp, upfidp) ptr;
	     if inftptr -> field_table.max_field_index < upftptr -> field_table.max_field_index
	     then bv_code = lister_codes_$master_not_like_update;
	     else do i = 0 to upftptr -> field_table.max_field_index;
		upfidp = pointer (upftptr -> field_table.index_to_field_id (i), update_file.area);
		equiv = -1;
		do j = 0 to inftptr -> field_table.max_field_index;
		     infidp = pointer (inftptr -> field_table.index_to_field_id (j), input_file.area);
		     if infidp -> field_identifier.string = upfidp -> field_identifier.string
		     then do;
			equiv = j;
			j = inftptr -> field_table.max_field_index;
		     end;
		end;
		if equiv = -1
		then do;
		     bv_code = lister_codes_$master_not_like_update;
		     return;
		end;
		equiv_table (equiv) = i;
	     end;
	end;


compare:
	procedure (p1, p2) returns (fixed bin);

/* parameters */

dcl (p1, p2) ptr parameter;

/* automatic adjustable */

dcl  s1 char (length (p1 -> atom)) aligned,
     s2 char (length (p2 -> atom)) aligned;

/* program */

	     s1 = translate (p1 -> atom, lower_case, upper_case);
	     s2 = translate (p2 -> atom, lower_case, upper_case);

	     if s1 = s2
	     then return (EQUAL);
	     else if s1 < s2
	     then return (LESS_THAN);
	     else return (GREATER_THAN);

	end compare;

copy_record:
	procedure (bv_file_ptr, bv_record_ptr, bv_retain_uid);

/* parameters */

dcl (bv_file_ptr, bv_record_ptr)
     ptr parameter,
     bv_retain_uid bit (1) aligned parameter;

/* automatic */

dcl (filep, out_rp, out_atomp)
     ptr,
     fieldx fixed bin;

/* program */

	     recordp = bv_record_ptr;
	     filep = bv_file_ptr;

	     if bv_retain_uid
	     then out_rp = lister_create_record_$retain_uid (out_file_ptr, input_record.uid);
	     else out_rp = lister_create_record_ (out_file_ptr);

/* The following reference to input_record should really to be to a declaration of
   a record that references "filep" , not input_file. */

	     do fieldx = lbound (input_record.field, 1) to hbound (input_record.field, 1);
		if bv_file_ptr = up_file_ptr
		then do;
		     if equiv_table (fieldx) = -1
		     then atomp = null;
		     else atomp = pointer (input_record.field (equiv_table (fieldx)), filep -> input_file.area);
		end;
		else atomp = pointer (input_record.field (fieldx), filep -> input_file.area);
		if atomp ^= null
		then do;
		     atom_length = length (atom);
		     allocate atom in (output_file.area) set (out_atomp);
		     out_atomp -> atom = atom;
		     out_rp -> output_record.field (fieldx) = out_atomp;
		end;
	     end;

	     counts (3) = counts (3) + 1;		/* one more output record */
	     return;

	end copy_record;

     end;
  



		    lister_print_.pl1               11/05/84  1154.9r w 11/05/84  1151.5      112158


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

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

/* This program prints a Lister file using a format table */

/* Modified 740605 by PG to be able to print found_list.
   Modified 741110 by PG for center format item.
   Modified 761105 by PG to rename from assist_print_ to lister_print_.
   Modified 770923 by PG to always truncate field values on right.
   Modified 781010 by PG to get :argN to work.
   Modified 790329 by PG to get <:record_count,N> to work (bug 24).
   Modified 791128 by PG to fix 039 (pls counted chars, not print positions).
   Modified 800411 by PB to make <:arg> honor justification request.
   Modified 800813 by PB to print <:uid>.
   Modified 800923 by PB to fix bug where no args given in command line but
   asked for in listform.
   Modified 801008 by PB to requote strings for display_list.
   Modified 810128 by PB to fix bug when requoting null field.
   Modified 810226 by PB to report pathname with missing arg.
*/

/* format: style3 */
lister_print_:
     procedure (bv_in_file_ptr, bv_format_table_ptr, bv_output_ptr, bv_outx, bv_select_all, bv_selected_records_ptr,
	     bv_arg_list_ptr, bv_arg_position, bv_brief_errors, bv_display, bv_listform_path) options (packed_decimal);

/* parameters */

declare (
         bv_arg_list_ptr ptr,
         bv_arg_position fixed bin,
         bv_brief_errors bit (1) aligned,
         bv_display bit (1) aligned,
         bv_format_table_ptr ptr,
         bv_in_file_ptr ptr,
         bv_listform_path char (*),
         bv_output_ptr ptr,
         bv_outx fixed bin (21),
         bv_select_all bit (1) aligned,
         bv_selected_records_ptr
         ptr
         ) parameter;

/* automatic */

declare (i, left_padding, outx, right_padding)
         fixed bin (21);
declare (n_records, start) fixed bin;
declare (output_ptr, selected_records_ptr)
         ptr;
declare  uid_chars char (6) varying;

/* entries */

declare  com_err_ entry options (variable);
declare  convert_binary_integer_$decimal_string
         entry (fixed) returns (char (13) varying);
declare  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
declare  date_time_ entry (fixed bin (71), char (*) aligned);
declare  requote_string_ entry (char (*)) returns (char (*));

/* based */

dcl  outstring char (1044480) based (output_ptr);
dcl  q_outstring char (outx - 1) based (output_ptr);

/* builtins */

dcl (bin, char, clock, copy, divide, hbound, index, lbound, length, ltrim, max, min, null, substr, rel)
     builtin;

/* include files */

%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	format_table_ptr = bv_format_table_ptr;
	output_ptr = bv_output_ptr;
	outx = bv_outx;
	selected_records_ptr = bv_selected_records_ptr;

	ltp = format_table.literal_table;
	n_records = 0;

	start = format_table.before;
	call interpret_format;

	start = format_table.record;

	if bv_select_all				/* Select all records */
	then do;
	     do recordp = input_file.record_head repeat input_record.next while (recordp ^= null);
		n_records = n_records + 1;
		call interpret_format;
	     end;
	end;
	else if selected_records_ptr ^= null		/* Otherwise, if there are any records to print */
	then do;
	     do i = lbound (selected_records_ptr -> list_node.list (*), 1)
		     to hbound (selected_records_ptr -> list_node.list (*), 1);
		recordp = selected_records_ptr -> list_node.list (i);
		n_records = n_records + 1;
		call interpret_format;
	     end;
	end;
	else ;					/* Else, nothing to print */

	start = format_table.after;
	call interpret_format;
	bv_outx = outx;
	return;

interpret_format:
	procedure ();

/* automatic */

dcl (columns, delta, first, i, j, jump_index, l, w)
     fixed bin (21);
dcl  code fixed bin (35);
dcl  justify bit (2) aligned;
dcl  temp char (13) varying aligned;
dcl  date_time char (24) aligned;
dcl  arg_number fixed bin,
     arg_len fixed bin (21),
     arg_ptr ptr,
     contains_BS bit (1) aligned;

/* based */

dcl  arg_string char (arg_len) based (arg_ptr);

/* internal static */

declare  BS char (1) internal static init ("");

/* program */

	     if start = 0
	     then return;

	     do i = start by 1;

		j = item (i).action;
		w = item (i).width;
		justify = item (i).justification;

		if j < 0
		then jump_index = -j;
		else jump_index = 0;

		go to jump (jump_index);

jump (0):						/* print field */
		atomp = input_record.field (j);

		contains_BS = "0"b;

		if atomp = null			/* if no field */
		then l = 0;			/* set atom length to zero */
		else if index (atom, BS) ^= 0
		then do;
		     l = print_positions (atom);
		     contains_BS = "1"b;
		end;
		else l = length (atom);

		if bv_display			/* called by display_list af. */
		then do;
		     if atomp = null 
			then call add_requoted (requote_string_ (""));
		     else call add_requoted (requote_string_ ((atom)));
		     goto next;
		end;

		if w = 0				/* if no field width specified */
		then w = l;			/* use default length */

		delta = w - l;			/* >0 --> #spaces,  <0 --> #truncate */

		if delta > 0			/* if field fits in window */
		then do;
		     columns = l;			/* print whole field */
		     right_padding = delta;		/* and fill rest of window */
		end;
		else do;
		     columns = w;			/* print as much of field as will fit in window */
		     right_padding = 0;		/* no fill */
		end;

		left_padding = 0;			/* default value for flush_left */

		if justify = flush_right
		then do;
		     if delta > 0			/* need fill */
		     then left_padding = delta;

		     right_padding = 0;		/* don't need any right padding */
		end;
		else if justify = center
		then do;
		     if delta > 0			/* if field fits in window */
		     then do;
			left_padding = divide (delta, 2, 21, 0);
			right_padding = w - columns - left_padding;
		     end;
		     else ;			/* field doesn't fit; padding values are ok */
		end;

/* At this point everything has been arranged to that the following equality holds:
   w = left_padding + columns + right_padding
*/

		if left_padding > 0			/* need padding? */
		then do;
		     substr (outstring, outx, left_padding) = "";
		     outx = outx + left_padding;
		end;

		if columns > 0			/* if atom exists */
		then do;
		     if contains_BS
		     then columns = measure (atom, columns);

		     substr (outstring, outx, columns) = substr (atom, 1, columns);
		     outx = outx + columns;
		end;

		if right_padding > 0		/* finish up flush_left or center item. */
		then do;
		     substr (outstring, outx, right_padding) = "";
		     outx = outx + right_padding;
		end;

		go to next;

jump (1):						/* print literal */
		atomp = literal (w);
		atom_length = length (atom);
		substr (outstring, outx, atom_length) = atom;
		outx = outx + atom_length;
		go to next;

jump (2):						/* print spaces */
		substr (outstring, outx, w) = "";
		outx = outx + w;
		go to next;

jump (4):						/* print date */
		if w = 0
		then w = 8;
		else w = max (min (w, 24), 0);
		call date_time_ (clock (), date_time);
		substr (outstring, outx, w) = date_time;
		outx = outx + w;
		go to next;

jump (5):						/* print time */
		if w = 0
		then w = 6;
		else w = max (min (w, 14), 0);
		call date_time_ (clock (), date_time);
		substr (outstring, outx, w) = substr (date_time, 11, w);
		outx = outx + w;
		go to next;

jump (6):						/* print number of records printed (output_count) */
		temp = convert_binary_integer_$decimal_string (n_records);

		if w = 0
		then w = length (temp);		/* if user didn't specify, use default */

		if justify = flush_right & length (temp) < w
		then substr (outstring, outx, w) = copy (" ", w - length (temp))||temp;
		else if justify = center & length (temp) < w
		then do;
		     left_padding = divide (w - length (temp), 2, 17, 0);
		     right_padding = w - left_padding;
		     substr (outstring, outx, w) = copy (" ", left_padding)||temp||copy (" ", right_padding);
		end;
		else substr (outstring, outx, w) = temp;
		outx = outx + w;
		go to next;

jump (7):						/* print argument N */
		if bv_arg_position = 0
		then do;
		     if ^bv_brief_errors
		     then call com_err_ (0, "process_list",
			"Argument ^d specified in listform segment but not present in command line. ^a",
			item (i).argument_number, bv_listform_path);
		     goto jump (2);			/* use null string. */
		end;

		arg_number = item (i).argument_number;
		call cu_$arg_ptr_rel (bv_arg_position + arg_number, arg_ptr, arg_len, code, bv_arg_list_ptr);
		if code ^= 0
		then do;
		     if ^bv_brief_errors
		     then call com_err_ (0, "process_list",
			"Argument ^d specified in listform segment but not present after -ag. ^a",
			arg_number, bv_listform_path);

		     go to jump (2);		/* use null string */
		end;

		if w = 0
		then w = arg_len;			/* set default length */

		if justify = flush_right & arg_len < w
		then substr (outstring, outx, w) = copy (" ", w - arg_len)||arg_string;
		else if justify = center & arg_len < w
		then do;
		     left_padding = divide (w - arg_len, 2, 17, 0);
		     right_padding = w - left_padding;
		     substr (outstring, outx, w) = copy (" ", left_padding)||arg_string||copy (" ", right_padding);
		end;
		else substr (outstring, outx, w) = arg_string;
		outx = outx + w;
		go to next;

jump (8):
		uid_chars = ltrim (char (input_record.uid)); /* print uid */

		if bv_display			/* called by display_list af. */
		then do;
		     substr (outstring, outx, length (uid_chars) + 2) = """" || uid_chars || """";
		     outx = outx + length (uid_chars) + 2;
		     goto next;
		end;

		if w = 0
		then w = length (uid_chars);		/* set default length */

		if justify = flush_right & length (uid_chars) < w
		then substr (outstring, outx, w) = copy (" ", w - length (uid_chars))||uid_chars;
		else if justify = center & length (uid_chars) < w
		then do;
		     left_padding = divide (w - length (uid_chars), 2, 17, 0);
		     right_padding = w - left_padding;
		     substr (outstring, outx, w) = copy (" ", left_padding)||uid_chars||copy (" ", right_padding);
		end;
		else substr (outstring, outx, w) = uid_chars;
		outx = outx + w;
		go to next;

next:
	     end;

jump (3):						/* end of format list */
	     return;

add_requoted:  procedure (q_string);

dcl  q_string char (*) parameter;

		outx = outx + length (q_string);
		substr (q_outstring, outx - length (q_string)) = q_string;
	     end add_requoted;

print_positions:
	     procedure (P_atom) returns (fixed bin (21));

/* parameters */

declare  P_atom char (*) varying aligned;

/* automatic */

declare  ascii_value fixed bin (9),
         n_chars fixed bin (21),
         n_cols fixed bin (21),
         strx fixed bin (21);

/* builtins */

declare (length, rank, substr)
         builtin;

/* internal static */

declare  BS fixed bin (9) internal static init (8);

/* program */

		n_cols = 0;

		do strx = 1 to length (P_atom);
		     ascii_value = rank (substr (P_atom, strx, 1));

		     if ascii_value = BS
		     then n_cols = n_cols - 1;
		     else n_cols = n_cols + 1;
		end;

		return (n_cols);

measure:
		entry (P_atom, P_width) returns (fixed bin (21));

/* parameters */

declare  P_width fixed bin (21) parameter;

/* program */

		n_cols = 0;
		n_chars = 0;

		do strx = 1 to length (P_atom);
		     ascii_value = rank (substr (P_atom, strx, 1));

		     if ascii_value = BS
		     then do;
			n_chars = n_chars + 1;
			n_cols = n_cols - 1;
		     end;
		     else do;
			if n_cols = P_width
			then return (n_chars);	/* no room to add one more char */

			n_chars = n_chars + 1;
			n_cols = n_cols + 1;
		     end;
		end;

		return (n_chars);			/* they all fit */

	     end print_positions;

	end interpret_format;

     end;
  



		    lister_requests_.pl1            07/23/87  1003.6rew 07/23/87  1000.0      689886


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


/****^  HISTORY COMMENTS:
  1) change(87-07-20,Benjamin), approve(87-07-20,MCR7744),
     audit(87-07-21,Lippard), install(87-07-23,MR12.1-1045):
     Fixed so that copy_list will not allow the same segment as input and
     output.  Fixed so that a QUIT and release in the midst of an append_list
     -prompt session will not result in a partial record remaining in the
     database.
                                                   END HISTORY COMMENTS */


/* Command program for the Lister system.

   Written April 20, 1973 by Paul A. Green II
   Modified 740611 by PG to fix duplicate freeing bug
   Modified 740731 by PG to add search function
   Modified 740902 by PG to add expand function
   Modified 741110 by PG to add options to sort and search functions
   Modified 750330 by PG to use assist_delete_
   Modified 750624 by PG to add type function
   Modified 750713 by PG to add command options to print & search
   Modified 760427 by PG to add merge function
   Modified 761101 by PG to convert to Lister command names.
   Modified 770322 by PG to enhance -sm ctl arg to print_list.
   Modified 770606 by PG to enhance sort_list.
   Modified 770630 by PG to have trim_list print number of records deleted.
   Modified 770707 by PG to change calling sequence to lister_sort_.
   Modified 770718 by PG to fix bug 6 (sort_list path fn1 fn2 fails)
   Modified 770718 by PG to implement -sort ctl arg to sort_list and print_list.
   Modified 770721 by PG to rename print_list to process_list.
   Modified 770804 by PG to change from -brief to -totals (bug 7), from suffix_pathname_ to expand_pathname_$add_suffix,
   and to make selecting 0 records an error.
   Modified 770817 by PG to fix bug causing -sort not to work in process_list unless -select also given.
   Modified 770831 by PG to get sort_list to look at all arguments, and to require -select.
   Modified 770913 by PG to eliminate lister_util_ (we can give better error messages w/o it).
   Modified 770921 by PG to get merge_list to agree with revised documentation, and to fix bugs 004 and 013.
   Modified 770922 by PG to rename reduce_list to copy_list, and to add -totals to process_list and copy_list.
   Modified 771018 by PG to fix bug 015 (merge_list path1 path2 failed)
   Modified 780407 by PG to implement -ag for process_list, and to fix bug 16 (delete .lister if error in cls)
   Modified 790620 by PG to fix 032 (mls w/o -fn fails), 033 (mls -fn performs too little validation),
   and 031 (cpls only accepted one control arg!)
   Modified 790711 by PG to fix 036 (pls fails to truncate output seg if no records are selected, and
   -extend is not given), and to do sugg 030 (make argument to -output_file of pls optional).
   Modified 791128 by PG to fix 040 by having everybody check version number of .lister segments.
   Modified 791128 by PG for numeric selection.
   Modified 791211 by PG to bring back expand_list.
   Modified 791217 by PG to fix 047 (change -ex to -ext), and to make default -of ename for pls be listform ename.
   Modified 800306 by PG to fix bug whereby pls -of failed if -of was followed by another ctl arg.
   Modified 800318 by PG to add -all control argument to expand_list.
   Modified 800520 by PB to pass lister_merge_ a status code and check same.
   Modified 800620 by PB to prevent deleting lister file when no w access.
   Modified 800702 by PB to add status_list command.
   Modified 800813 by PB to change status_list to describe_list and add display_list, modify_list and append_list.
   Modified 801008 by PB to have display_list af requote strings.
   Modified 801024 by PB to update v1 files in place and have dils default to display all fields.
   Modified 810106 by PB to allow display_list to specify format > 250 characters.
   Modified 810226 by PB to have pls pass the listform pathname to lister_print_.
   Modified 810615 by PB to distinguish between arguments and control arguments in error messages.
   Modified 810922 by PB to make -bfe work for mdls and have cpls make empty file if no records selected.
   Modified 811022 by PB to have als not allocate null fields.
   Modified 811109 by PB to implement cls -of.
   Modified 830906 by PB to allow -arguments as well as -argument for pls.
   Modified 840521 by PB to add -sort to display_list.
   Modified 840521 by PB to add support for severity.
   Modified 840522 by PB to add -brief_errors to copy_list and sort_list.
   Modified 840524 by PB to add make_list.
   Modified 840615 by PB to add support for archived listforms.
   Modified 840615 by PB to add ssu_ usage stuff.
   Modified 840618 by PB to prevent 0-length output segments from being created
		     by make_list, copy_list, expand_list, and merge_list
		     in error situations.
   Modified 840619 by PB to do general housecleaning and modernization.
   Modified 840621 by PB to change to standalone invocations.
   Modified 840627 by PB to add -prompt to als.
   Renamed  840628 by PB from lister.pl1 to lister_requests_.pl1.
   Modified 841001 by PB to change als -prompt to use command_query_.
   Modified 841024 by PB to comment out the ssu_ usage stuff.
   Modified 841130 by PB to add check in cpls to see if input and output files
		     are the same.
*/

/* format: style3 */
lister_requests_:
     procedure options (packed_decimal);

/* parameters */

dcl  bv_info_ptr ptr parameter;
dcl  bv_sci_ptr ptr parameter;

/* entries */

dcl  adjust_bit_count_ entry (char(168), char(32), bit(1) aligned,
	fixed bin(24), fixed bin(35)),
     com_err_ entry() options(variable),
     command_query_	entry() options(variable),
     cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35),
	ptr),
     cu_$arg_list_ptr entry () returns (ptr),
     cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), 
	ptr),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin),
     delete_$ptr entry (ptr, bit(36) aligned, char(*), fixed bin(35)),
     expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
     expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*),
	fixed bin(35)),
     expand_pathname_$component_add_suffix entry (char(*), char(*), char(*),
	char(*), char(*), fixed bin(35)),
     get_pdir_ entry () returns (char (168)),
     get_system_free_area_ entry (ptr),
     get_temp_segment_ entry (char(*), ptr, fixed bin(35)),
     get_wdir_ entry () returns (char (168)),
     ioa_ entry options (variable),
     initiate_file_	entry (char(*), char(*), bit(*), ptr, fixed bin(24),
	fixed bin(35)),
     initiate_file_$component	entry (char(*), char(*), char(*), bit(*), ptr,
	fixed bin(24), fixed bin(35)),
     initiate_file_$create entry (char(*), char(*), bit(*), ptr,
	bit(1) aligned, fixed bin(24), fixed bin(35)),
     iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)),
     pathname_ entry (char(*), char(*)) returns(char(168)),
     pathname_$component entry (char(*), char(*), char(*))
	returns(char(194)),
     release_temp_segment_ entry (char(*), ptr, fixed bin(35)),
     ssu_$abort_line entry() options(variable),
     ssu_$arg_list_ptr entry (ptr, ptr),
     ssu_$destroy_invocation entry (ptr),
     ssu_$print_message entry() options(variable),
/*   ssu_$record_usage entry (ptr, ptr, fixed bin(35)), */
     ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr,
	fixed bin(21)),
     ssu_$standalone_invocation entry (ptr, char(*), char(*), ptr, entry,
	fixed bin(35)),
     suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(32),
	fixed bin(35)),
     terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)),
     unique_chars_ entry (bit (*)) returns (char (15));

/* external static */

declare (
         error_table_$active_function fixed bin (35),
         error_table_$bad_arg fixed bin (35),
         error_table_$badopt fixed bin (35),
         error_table_$inconsistent fixed bin (35),
         error_table_$moderr fixed bin (35),
         error_table_$noarg fixed bin (35),
         error_table_$sameseg fixed bin(35),
         error_table_$unimplemented_version fixed bin (35),
         iox_$user_output ptr,
         lister_codes_$cant_convert fixed bin (35),
         lister_codes_$display_unknown_fieldname fixed bin (35),
         lister_codes_$dup_fieldname fixed bin (35),
         lister_codes_$fieldname_not_alpha_start fixed bin (35),
         lister_codes_$listform_unknown_fieldname fixed bin (35),
         lister_codes_$long_fieldname fixed bin (35),
         lister_codes_$master_eq_output fixed bin (35),
         lister_codes_$master_eq_update fixed bin (35),
         lister_codes_$no_current_lister fixed bin (35),
         lister_codes_$undefined_fieldname fixed bin (35),
         lister_codes_$update_eq_output fixed bin (35),
         lister_severity_ fixed bin (35),
         sys_info$max_seg_size fixed bin (19)
     ) external static;

/* automatic */

dcl (
     append_info_ptr ptr,
     arg_already_got bit (1) aligned,
     arg_count fixed bin,
     arg_getter entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr) 
	variable,
     arg_index fixed bin,
     arg_length fixed bin (21),
     arg_list_ptr ptr,
     arg_position fixed bin,
     arg_ptr ptr,
     assign_info_ptr ptr,
     brief_errors bit (1) aligned,
     choice_made bit (1) aligned,
     cleanup_handler_established bit (1) aligned,
     code fixed bin (35),
     code2 fixed bin (35),
     command bit (1) aligned,
     componentname char (32),
     delete_output_file_on_error bit (1),
     dummy_bc fixed bin (24),
     dummy_cr bit (1) aligned,
     error_token char (132),
     fdelim char (1),
     first_fn_arg_num fixed bin,
     format_bitcount fixed bin (24),
     format_dname char (168),
     format_ename char (32),
     format_length fixed bin,
     format_ptr ptr,
     function_index fixed bin,
     i fixed bin,
     ignore_code fixed bin (35),
     in_bitcount fixed bin (24),
     in_dname char (168),
     in_ename char (32),
     in_length fixed bin (21),
     input_ptr ptr,
     last_fn_arg_num fixed bin,
     lister_info_ptr ptr,
     my_name char (16),
     n_fields fixed bin,
     name bit (1) aligned,
     next_char_pos_in_listin fixed bin (21),
     out_bitcount fixed bin (24),
     out_dname char (168),
     out_ename char (32),
     output_all_fieldnames bit (1) aligned,
     output_index fixed bin (21),
     output_file_created bit (1) aligned,
     output_ptr ptr,
     overwrite_master_file bit (1) aligned,
     partial_record_appended bit (1) aligned,
     prompting bit (1) aligned,
     saved_version fixed bin,
     sci_ptr ptr,
     segment_output bit (1) aligned,
     select_all bit (1) aligned,
     selected_records_ptr ptr,
     rdelim char (1),
     temp_append_ptr ptr,
     temp_format_len fixed bin (21),
     temp_format_ptr ptr,
     temp_input_len fixed bin (21),
     temp_input_ptr ptr,
     temp_output_ptr ptr,
     truncate bit (1) aligned,
     width fixed bin,
     working_dir char (168)
     ) internal automatic;

dcl 1 local_qi like query_info;

dcl 1 status_info,
    2 print_switches unal,
      3 print_fdelim bit (1),
      3 print_fnames bit (1),
      3 print_rdelim bit (1),
      3 print_totals bit (1),
    2 af bit (1) aligned,
    2 total fixed bin,
    2 retlen fixed bin (21),
    2 retptr ptr,
    2 header bit (1) aligned,
    2 header_specified bit (1) aligned;


declare (first_s, second_s) char (1) aligned,
        (
         flx,
         counts (3),
         merge_type
         ) fixed bin,
        (all_fields, done, fatal_error)
         bit (1) aligned,
         field_list_ptr ptr;

/* based */

dcl  append_str char (append_info.append_length (i)) 
	based (append_info.append_ptr (i)),
     arg_string char (arg_length) based (arg_ptr),
     field_list (n_fields) fixed bin based (field_list_ptr),
     format_string char (format_length) based (format_ptr),
     out_string char (output_index - 1) based (temp_output_ptr),
     ret_string char (retlen) varying based (retptr),
     temp_append_string char ((sys_info$max_seg_size - 1) * 4) varying based (temp_append_ptr),
     temp_input_file char (temp_input_len) based (temp_input_ptr),
     temp_format_string char (temp_format_len) based (temp_format_ptr);

declare 1 append_info (0:field_table.max_field_index) aligned 
	based (append_info_ptr),
        2 append_ptr ptr,
        2 append_length fixed bin (21);

declare 1 assign_info (0:field_table.max_field_index) aligned 
	based (assign_info_ptr),
        2 assign_ptr ptr,
        2 assign_length fixed bin (21);

declare 1 lister_info based (lister_info_ptr),
        2 database,
        3 dname char (168),
        3 ename char (32);

/* builtin functions */

dcl (addr, before, codeptr, dim, divide, hbound, index, lbound, length, null, 
	pointer, rtrim, substr, string, unspec)
     builtin;

/* conditions */

dcl  cleanup condition;

/* internal static */

declare  APPEND fixed bin internal static options (constant) init (13); /* function index */
declare  COPY fixed bin internal static options (constant) init (8); /* function index */
declare  CREATE fixed bin internal static options (constant) init (1); /* function index */
declare  DESCRIBE fixed bin internal static options (constant) init (10); /* function index */
declare  DISPLAY fixed bin internal static options (constant) init (11); /* function index */
declare  EXPAND fixed bin internal static options (constant) init (6); /* function index */
declare  MAKE fixed bin internal static options (constant) init (14); /* function index */
declare  MERGE fixed bin internal static options (constant) init (5); /* function index */
declare  MODIFY fixed bin internal static options (constant) init (12); /* function index */
declare  NL char (1) initial ("
") internal static options (constant);
declare  OFF bit (1) aligned initial ("0"b) internal static options (constant);
declare  ON bit (1) aligned initial ("1"b) internal static options (constant);
declare  PROCESS fixed bin internal static options (constant) init (3); /* function index */
declare  SORT fixed bin internal static options (constant) init (2); /* function index */
declare  TRIM fixed bin internal static options (constant) init (9); /* function index */
declare  process_dir char (168) initial ("") internal static;
declare  lister_version char (6) initial ("11.0d") internal static options (constant);

/* include files */

%include access_mode_values;

%include delete_options;

%include lister_entries;

%include lister_structures;

%include query_info;

%include terminate_file;

/* program */

create_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = CREATE;
	my_name = "create";
	command = OFF;
	goto create_common;
	
create_list:
cls:
	entry;

	function_index = CREATE;
	my_name = "create_list";
	command = ON;
	
create_common:
	call initialize;
	out_ename = "";
	
	if ^command
	     then do;
	     if lister_info.database.ename = ""
		then call ssu_$abort_line (sci_ptr, lister_codes_$no_current_lister);
	     out_ename = lister_info.database.ename;
	     out_dname = lister_info.database.dname;
	     arg_ptr = addr (lister_info.database.ename);
	     arg_length = length (rtrim (lister_info.database.ename)) - 7;
	end;
	else do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("listin", input_ptr, in_bitcount, code);
	if code ^= 0
	then go to cleanup_and_return;

/* No version number check necessary or possible... */

	print_totals = OFF;
	call get_next_argument;
	do while (code = 0);
	     if arg_string = "-tt" | arg_string = "-totals"
		then print_totals = ON;
	     else if command & (arg_string = "-of" | arg_string = "-output_file")
		then do;
		call get_next_argument;
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Following -output_file");
		call expand_pathname_$add_suffix (arg_string, "lister", out_dname, out_ename, code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code);
	     end;
	     else if ^command & (arg_string = "-if" | arg_string = "-input_file")
		then do;
		call get_next_argument;
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Following -input_file");
		call terminate_file_ (input_ptr, 0, TERM_FILE_TERM, code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code);
		call get_input_segment ("listin", input_ptr, in_bitcount, code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code);
	     end;
	     else call badarg;
	     		
	     call get_next_argument;
	end;

	if command & out_ename = ""
	     then do;
	     call suffixed_name_$new_suffix (in_ename, "listin", "lister", out_ename, code);
	     if code ^= 0
		then call ssu_$abort_line (sci_ptr, code);
	     out_dname = working_dir;
	end;
			     		
	call get_output_segment (out_dname, out_ename, output_ptr, out_bitcount, code);
	if code ^= 0
	     then goto cleanup_and_return;

	in_length = divide (in_bitcount + 8, 9, 24, 0);
	call lister_compile_listin_ (output_ptr, input_ptr, in_length, area_ptr, n, error_token, code);
	if code ^= 0
	then do;
	     if code ^= error_table_$moderr
	     then do;
		unspec (delete_options) = OFF;
		delete_options.force = ON;
		delete_options.segment = ON;
		delete_options.link = ON;
		delete_options.chase = ON;
		call delete_$ptr (output_ptr, string (delete_options), my_name, ignore_code);
		output_ptr = null;
		call ssu_$abort_line (sci_ptr, code, "^a", error_token);
	     end;
	     else call ssu_$abort_line (sci_ptr, code, "^a", out_ename);
	end;

	if print_totals
	then call ioa_ ("create_list: ^d record^[s^].", n, (n ^= 1));

	call adjust_bit_count_ (out_dname, out_ename, OFF, out_bitcount, code);
	lister_severity_ = 0;

	go to finish;

make_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = MAKE;
	my_name = "make";
	command = OFF;
	goto make_common;

make_list:
mkls:	entry;
	
	function_index = MAKE;
	my_name = "make_list";
	command = ON;
	
make_common:
	call initialize;
	delete_output_file_on_error = ON;
		
	if ^command
	     then do;
	     if lister_info.database.ename = ""
		then call ssu_$abort_line (sci_ptr, lister_codes_$no_current_lister);
	     out_dname = lister_info.database.dname;
	     out_ename = lister_info.database.ename;
	     cleanup_handler_established = ON;
	     on cleanup call cleanup_handler;
	end;
	else do;
	     call get_next_argument;
	     if code ^= 0
		then goto usage_ (function_index);

	     cleanup_handler_established = ON;
	     on cleanup call cleanup_handler;
	
	     call expand_pathname_$add_suffix (arg_string, "lister", out_dname, out_ename, code);
	
	     if code ^= 0
		then call ssu_$abort_line (sci_ptr, code);

	end;

	call get_output_segment (out_dname, out_ename, output_ptr, out_bitcount, code);
	if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code);
	
	call get_temp_segment_ (my_name, temp_input_ptr, code);
	
	if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code);

	first_fn_arg_num, last_fn_arg_num = 0;
	
	rdelim = "$";
	fdelim = "=";

	call get_next_argument;

	do while (code = 0);
	     arg_already_got = OFF;
	     if (arg_string = "-delimiter") | (arg_string = "-dm")
		then do;
		call get_next_argument;
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Following -delimiter.");
		if arg_length ^= 2
		     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Following -delimiter.  ^a.", arg_string);
		rdelim = substr (arg_string, 1, 1);
		fdelim = substr (arg_string, 2, 1);
	     end;
	     else if (arg_string = "-field_name") | (arg_string = "-fn")
		then do;
		call get_next_argument;
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "Following -field_name.");
		first_fn_arg_num = arg_index - 1;
		arg_already_got = ON;
		do while (code = 0 & last_fn_arg_num = 0);
		     if arg_length > 0
			then if index (arg_string, "-") = 1
			then last_fn_arg_num = arg_index - 2;
		     else call get_next_argument;
		     else				/* null argument -- compile_listin would choke */
			call ssu_$abort_line (sci_ptr, lister_codes_$fieldname_not_alpha_start, """"".");
		end;
		if last_fn_arg_num = 0
		     then last_fn_arg_num = arg_index - 2;
	     end;
	     else call badarg;
	     if ^arg_already_got
		then call get_next_argument;
	     
	end;
	
	if first_fn_arg_num = 0
	     then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The -field_name control argument is required.");
	
	if first_fn_arg_num > last_fn_arg_num
	     then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following -field_name.");
	
	temp_input_len = sys_info$max_seg_size * 4;
	substr (temp_input_file, 1, 18) = "Record_delimiter: ";
	substr (temp_input_file, 19, 1) = rdelim; 
	substr (temp_input_file, 20, 2) = ";" || NL;
	substr (temp_input_file, 22, 17) = "Field_delimiter: ";
	substr (temp_input_file, 39, 1) = fdelim;
	substr (temp_input_file, 40, 2) = ";" || NL;
	substr (temp_input_file, 42, 13) = "Field_names: ";
	next_char_pos_in_listin = 55;
	do i = first_fn_arg_num to last_fn_arg_num;
	     call cu_$arg_ptr_rel (i, arg_ptr, arg_length, code, arg_list_ptr);
	     substr (temp_input_file, next_char_pos_in_listin, arg_length + 2) = arg_string || ", ";
	     next_char_pos_in_listin = next_char_pos_in_listin + arg_length + 2;
	end;
	substr (temp_input_file, next_char_pos_in_listin - 2, 2) = ";" || NL;
	substr (temp_input_file, next_char_pos_in_listin, 9) = "Records:" || NL;
	temp_input_len = next_char_pos_in_listin + 8;
	
	call lister_compile_listin_ (output_ptr, temp_input_ptr, temp_input_len, area_ptr, n, error_token, code);

	if code ^= 0
	then do;
	     if code ^= error_table_$moderr
	     then do;
		if index (error_token, " on line") ^= 0
		     then error_token = before (error_token, " on line");
		unspec (delete_options) = OFF;
		delete_options.force = ON;
		delete_options.segment = ON;
		delete_options.link = ON;
		delete_options.chase = ON;
		call delete_$ptr (output_ptr, string (delete_options), my_name, ignore_code);
		output_ptr = null;
		call ssu_$abort_line (sci_ptr, code, "^a", error_token);
	     end;
	     else call ssu_$abort_line (sci_ptr, code, "^a", out_ename);
	end;

	call adjust_bit_count_ (out_dname, out_ename, OFF, out_bitcount, code);

	lister_severity_ = 0;
	
	goto finish;
 
describe_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = DESCRIBE;
	my_name = "describe";
	command = OFF;
	goto describe_common;

describe_list:
dls:	entry;

	function_index = DESCRIBE;
	my_name = "describe_list";
	command = ON;

describe_common:
	call initialize;

	if command 
	     then do;
	     call get_next_argument;

	     if code ^= 0
		then goto usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then goto cleanup_and_return;
	
	call check_version_number (in_file_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* OK to process old file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	select_all = ON;
	header_specified = OFF;

	call get_next_argument;
	
	if code ^= 0				/* No more args--give 'em everything. */
	     then unspec (print_switches) = "1111"b;
	else unspec (print_switches) = "0000"b;

	do while (code = 0);
	     arg_already_got = OFF;
	     if (arg_string = "-sel") | (arg_string = "-select")
	     then do;
		select_all = OFF;
		call get_select_arg;
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
	     end;
	     else if (arg_string = "-dm") | (arg_string = "-delimiter")
	     then do;
		call get_next_argument;
		if arg_string = "field"
		then print_fdelim = ON;
		else if arg_string = "record"
		then print_rdelim = ON;
		else do;
		     arg_already_got = ON;
		     print_fdelim = ON;
		     print_rdelim = ON;
		end;
	     end;
	     else if (arg_string = "-fn") | (arg_string = "-field_name")
	     then print_fnames = ON;
	     else if (arg_string = "-tt") | (arg_string = "-totals")
	     then print_totals = ON;
	     else if (arg_string = "-he") | (arg_string = "-header")
	     then do;
		if af
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "^a not allowed for active function usage.", arg_string);
		header = ON;
		header_specified = ON;
	     end;
	     else if (arg_string = "-nhe") | (arg_string = "-no_header")
	     then do;
		header = OFF;
		header_specified = ON;
	     end;
	     else call badarg;
	     if ^arg_already_got
	     then call get_next_argument;
	end;

	if unspec (print_switches) = "0000"b		/* Used -sel alone, */
	then unspec (print_switches) = "1111"b;		/* Gets everything. */
	else if ^select_all then print_totals = ON;	/* -sel implies -tt. */

	if print_totals
	then if ^select_all
	     then total = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);
	     else total = input_file.n_records;

	call lister_status_ (in_file_ptr, in_ename, select_all, addr (status_info));
	if print_totals & total = 0 & ^select_all
	     then lister_severity_ = 1;
	     else lister_severity_ = 0;

	goto finish;

modify_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = MODIFY;
	my_name = "modify";
	command = OFF;
	goto modify_common;

modify_list:
mdls:	entry;

	function_index = MODIFY;
	my_name = "modify_list";
	command = ON;

modify_common:
	call initialize;

	if command
	     then do;
	     call get_next_argument;

	     if code ^= 0
		then goto usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then goto cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);

	if code ^= 0
	then do;
	     if saved_version = 1
	     then call lister_convert_ (in_file_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
	end;

	select_all = ON;
	print_totals = OFF;

	call get_next_argument;
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The ""-field_name"" control argument must be specified.");

	do while (code = 0);
	     if (arg_string = "-fn") | (arg_string = "-field_name")
	     then do;
		if assign_info_ptr = null ()
		then do;
		     field_table_ptr = input_file.field_table_offset;
		     allocate assign_info;
		     do i = 0 to field_table.max_field_index;
			assign_ptr (i) = null;
			assign_length (i) = 0;
		     end;
		end;
		call get_next_argument;
		if code ^= 0 
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		if index (arg_string, "-") = 1
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		i = lister_hash_fid_ (in_file_ptr, (arg_string)); /* Weird stuff happens if not passed by value. */
		if i < 0
		then call ssu_$abort_line (sci_ptr, lister_codes_$undefined_fieldname, "^a", arg_string);
		if assign_ptr (i) ^= null ()
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Multiple assignments to field ""^a"".", arg_string);
		call get_next_argument;
		name = OFF;
		if code = 0 
		then if (arg_string = "-str" | arg_string = "-string")
		then do;
		     call get_next_argument;
		     name = ON;
		end;
		if code ^= 0 
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:  -field_name name {-string} value.");
		if (index (arg_string, "-") = 1 & name = OFF)
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:  -field_name name {-string} value.");
		assign_ptr (i) = arg_ptr;
		assign_length (i) = arg_length;
	     end;
	     else if (arg_string = "-sel") | (arg_string = "-select")
	     then do;
		select_all = OFF;
		call get_select_arg;
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
	     end;
	     else if (arg_string = "-tt") | (arg_string = "-total") | (arg_string = "-totals")
	     then print_totals = ON;
	     else if (arg_string = "-bfe") | (arg_string = "-brief_errors")
	     then brief_errors = ON;
	     else call badarg;
	     call get_next_argument;
	end;

	if assign_info_ptr = null ()
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "The ""-field_name"" control argument must be specified.");


	if ^select_all
	then do;
	     n = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);
	     if n = 0 
		then do;
		lister_severity_ = 1;
		if ^brief_errors
		     then call ssu_$abort_line (sci_ptr, 0, "No records were selected.  ^a>^a", in_dname, in_ename);
		call cleanup_handler;
		return;
	     end;
	end;

	call lister_assign_ (in_file_ptr, select_all, selected_records_ptr, assign_info_ptr);

	if print_totals
	then call ioa_ ("^a:  ^d record^[s^] modified.", my_name, n, (n ^= 1));
	lister_severity_ = 0;

	goto finish;

display_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = DISPLAY;
	my_name = "display";
	command = OFF;
	goto display_common;

display_list:
dils:	entry;

	function_index = DISPLAY;
	my_name = "display_list";
	command = ON;

display_common:
	call initialize;

	if command 
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then goto usage_ (function_index);
	end;
	
	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then goto cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* Try to process old file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	select_all = ON;
	call get_temp_segment_ (my_name, temp_format_ptr, code);
	temp_format_len = 0;

	call get_next_argument;

	do while (code = 0);
	     arg_already_got = OFF;
	     if (arg_string = "-fn") | (arg_string = "-field_name")
	     then do;
		call get_next_argument;
		if code ^= 0 
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		if index (arg_string, "-") = 1
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		temp_format_len = temp_format_len + arg_length + 3;
		substr (temp_format_string, temp_format_len - (arg_length + 2)) = "<" || arg_string || "> ";
		do while ((code = 0) & (^arg_already_got));
		     call get_next_argument;
		     if code = 0
		     then if index (arg_string, "-") = 1
			then arg_already_got = ON;
			else do;
			     temp_format_len = temp_format_len + arg_length + 3;
			     substr (temp_format_string, temp_format_len - (arg_length + 2)) = "<" || arg_string || "> ";
			end;
		end;
	     end;
	     else if (arg_string = "-sel") | (arg_string = "-select")
	     then do;
		select_all = OFF;
		call get_select_arg;
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
	     end;
	     else if (arg_string = "-bfe") | (arg_string = "-brief_errors")
	     then brief_errors = ON;
	     else if arg_string = "-st" | arg_string = "-sort"
	     then do;
		select_all = OFF;
		call get_sort_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else call badarg;
	     if ^arg_already_got
	     then call get_next_argument;
	end;

	if temp_format_len = 0
	then do;
	     field_table_ptr = input_file.field_table_offset;
	     do i = 0 to hbound (field_table.index_to_field_id (*), 1);
		fidp = pointer (field_table.index_to_field_id (i), input_file.area);
		if i ^= 0
		then do;
		     temp_format_len = temp_format_len + 1;
		     substr (temp_format_string, temp_format_len) = " ";
		end;
		temp_format_len = temp_format_len + field_identifier.size + 2;
		substr (temp_format_string, temp_format_len - (field_identifier.size + 1)) = "<" || field_identifier.string || ">";
	     end;
	end;

	if ^select_all | sort_list_ptr ^= null
	then do;
	     n = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);
	     if n = 0 
	     then do;
		lister_severity_ = 1;
		if ^brief_errors
		     then call ssu_$abort_line (sci_ptr, 0, "No records were selected.  ^a>^a", in_dname, in_ename);
		call cleanup_handler;
		return;
	     end;
	     if sort_list_ptr ^= null
	     then call lister_sort_ (in_file_ptr, selected_records_ptr, sort_list_ptr);
	end;

	if saved_version = 1
	then if index (temp_format_string, ":uid") ^= 0
	     then do;
		call lister_convert_ (in_file_ptr, code);
		if code ^= 0
		then do;
		     code = lister_codes_$cant_convert;
		     call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
		end;
	     end;

	if af
	then call lister_format_parse_ (in_file_ptr, area_ptr, "<Begin record:>" || rtrim (temp_format_string) || " <end;>", format_table_ptr, error_token, code);
	else call lister_format_parse_ (in_file_ptr, area_ptr, "<Begin record:>" || rtrim (temp_format_string) || "
<end;>", format_table_ptr, error_token, code);
	if code ^= 0
	then do;
	     if code = lister_codes_$listform_unknown_fieldname /* message would reference LISTFORM & line # */
	     then do;
		code = lister_codes_$display_unknown_fieldname;
		call ssu_$abort_line (sci_ptr, code, "^a", substr (error_token, 1, index (error_token, "
" /* NL */) - 1));
	     end;
	     else call ssu_$abort_line (sci_ptr, code);
	end;

	call get_temp_segment_ (my_name, temp_output_ptr, code);
	if code ^= 0
	then do;
	     call cleanup_handler;
	     return;
	end;
	output_index = 1;

	call lister_print_ (in_file_ptr, format_table_ptr, temp_output_ptr, output_index, select_all, selected_records_ptr, null (), 0, ON, af, "");

	if af
	then ret_string = out_string;
	else call ioa_ ("^a", out_string);

	if n = 0 & ^select_all
	     then lister_severity_ = 1;
	else lister_severity_ = 0;
	
	goto finish;

append_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = APPEND;
	my_name = "append";
	command = OFF;
	goto append_common;

append_list:
als:	entry;

	function_index = APPEND;
	my_name = "append_list";
	command = ON;

append_common:
	call initialize;

	if command 
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then goto usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then goto cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);

	if code ^= 0
	then do;
	     if saved_version = 1
	     then call lister_convert_ (in_file_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
	end;

	call get_next_argument;

	field_table_ptr = input_file.field_table_offset;
	allocate append_info set (append_info_ptr);
	append_info.append_length (*) = 0;
	append_info.append_ptr (*) = null ();

	prompting = ON;
	choice_made = OFF;

	do while (code = 0);
	     if (arg_string = "-prompt" | arg_string = "-pmt")
		then do;
		if choice_made = ON & prompting = OFF
		     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-prompt and -field_name.");
		choice_made = ON;
		prompting = ON;
	     end;
	     else if (arg_string = "-fn" | arg_string = "-field_name")
	     then do;
		if choice_made = ON & prompting = ON
		     then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-prompt and -field_name.");
		choice_made = ON;
		prompting = OFF;
		call get_next_argument;
		if code ^= 0 
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		if index (arg_string, "-") = 1
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "Following ""-field_name"".");
		i = lister_hash_fid_ (in_file_ptr, (arg_string));
		if i < 0
		then call ssu_$abort_line (sci_ptr, lister_codes_$undefined_fieldname, "^a", arg_string);
		if append_info.append_ptr (i) ^= null
		then call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "Multiple occurrences of field ""^a"".", arg_string);
		call get_next_argument;
		name = OFF;
		if code = 0 
		then if (arg_string = "-str" | arg_string = "-string")
		then do;
		     call get_next_argument;
		     name = ON;
		end;
		if code ^= 0 
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:  -field_name name {-string} value.");
		if (index (arg_string, "-") = 1 & name = OFF)
		then call ssu_$abort_line (sci_ptr, error_table_$noarg, "^/Usage:  -field_name name {-string} value.");
		append_info.append_ptr (i) = arg_ptr;
		append_info.append_length (i) = arg_length;
		call get_next_argument;
	     end;
	     else call badarg;
	end;

	if prompting
	     then do;
	     call get_temp_segment_ (my_name, temp_append_ptr, code);
	     if code ^= 0
		then call ssu_$abort_line (sci_ptr, code);
	     local_qi.version = query_info_version_5;
	     local_qi.switches.suppress_name_sw = ON;
	     local_qi.switches.cp_escape_control = "01"b;	/* ".." is data */
	     local_qi.switches.suppress_spacing = ON;
	     local_qi.status_code = 0;
	     local_qi.query_code = 0;
	     local_qi.question_iocbp = null;
	     local_qi.answer_iocbp = null;
	     local_qi.repeat_time = 0;
	     local_qi.explanation_ptr = null;
	     local_qi.explanation_len = 0;
	     recordp = lister_create_record_ (in_file_ptr);
	     partial_record_appended = ON;
	     do i = 0 to hbound (field_table.index_to_field_id (*), 1);
		fidp = pointer (field_table.index_to_field_id (i), input_file.area);
		call command_query_ (addr (local_qi), temp_append_string, 
		     my_name, "^/^a:^2x", field_identifier.string);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code);
		if length (temp_append_string) > 0
		     then do;
		     atom_length = length (temp_append_string);
		     allocate atom in (input_file.area) set (atomp);
		     atom = temp_append_string;
		     input_record.field (i) = atomp;
		end;
	     end;
	     partial_record_appended = OFF;
	     call release_temp_segment_ (my_name, temp_append_ptr, code);
	     if code ^= 0
		then call ssu_$abort_line (sci_ptr, code);
	end;
	    
	else do;
	     recordp = lister_create_record_ (in_file_ptr);    /* get pointer to a new record */
	     partial_record_appended = ON;
	     do i = 0 to field_table.max_field_index;
		if append_info.append_length (i) ^= 0	/* allocate each non-null field */
		     then do;
		     atom_length = append_info.append_length (i);
		     allocate atom in (input_file.area) set (atomp);
		     atom = append_str;
		     input_record.field (i) = atomp;
		end;
	     end;
	     partial_record_appended = OFF;
	end;

	lister_severity_ = 0;
	
	free append_info;
	goto finish;

expand_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = EXPAND;
	my_name = "expand";
	command = OFF;
	goto expand_common;

expand_list:
els:
	entry;

	function_index = EXPAND;
	my_name = "expand_list";
	command = ON;

expand_common:
	call initialize;

	delete_output_file_on_error = ON;
	
	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_and_output_segs ("lister", "listin");
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (input_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* OK to process v1 file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	width = 0;				/* use default width if none given */
	print_totals = OFF;			/* default value */
	output_all_fieldnames = OFF;			/* .. */

	code = 0;
	call get_next_argument;

	do while (code = 0);
	     if arg_string = "-tt" | arg_string = "-totals"
	     then print_totals = ON;
	     else if arg_string = "-ll" | arg_string = "-line_length"
	     then do;
		call get_next_argument;
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "-line_length must be followed by decimal integer.");

		width = cv_dec_check_ (arg_string, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, 0, "^a contains a non-decimal digit in position ^d.", arg_string,
			code);
	     end;
	     else if arg_string = "-a" | arg_string = "-all"
	     then output_all_fieldnames = ON;
	     else call badarg;
	     call get_next_argument;
	end;

	output_index = 1;
	n = lister_expand_ (input_ptr, output_ptr, output_index, width, output_all_fieldnames);

	if print_totals
	then call ioa_ ("expand_list: ^d record^[s^].", n, (n ^= 1));

	out_bitcount = 9 * (output_index - 1);
	call close_output_segment (working_dir, out_ename, output_ptr, out_bitcount, code);
	
	lister_severity_ = 0;
	
	go to finish;

merge_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = MERGE;
	my_name = "merge";
	command = OFF;
	goto merge_common;

merge_list:
mls:
	entry;

	function_index = MERGE;
	my_name = "merge_list";
	command = ON;

merge_common:
	call initialize;

	delete_output_file_on_error = ON;
	output_file_created = OFF;

	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;
	
	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);

	if code ^= 0
	then do;
	     if saved_version = 1
	     then call lister_convert_ (in_file_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
	end;

	out_dname = in_dname;			/* default, unless changed */
	out_ename = in_ename;			/* .. */

	n_fields = dim (input_file.field_table_offset -> field_table.index_to_field_id, 1);
	allocate field_list set (field_list_ptr) in (system_area);

	call get_next_argument;			/* get update file */
	if code ^= 0
	then go to usage_ (function_index);

	call get_input_segment ("lister", up_file_ptr, 0, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (up_file_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* OK if update is v1 file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	if in_file_ptr = up_file_ptr			/* oh oh */
	then call ssu_$abort_line (sci_ptr, lister_codes_$master_eq_update, "^a>^a", in_dname, in_ename);

	call get_next_argument;			/* get output file (optional) */
	if code = 0
	then if index (arg_string, "-") ^= 1
	     then do;
		call expand_pathname_$add_suffix (arg_string, "lister", out_dname, out_ename, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);

		call initiate_file_$create (
		     out_dname, out_ename, RW_ACCESS, out_file_ptr, 
		     output_file_created, dummy_bc, code);
		if out_file_ptr = null
		then call ssu_$abort_line (sci_ptr, code, "^a>^a", out_dname, out_ename);

		call get_next_argument;
	     end;

	if in_file_ptr = out_file_ptr			/* oh oh (2) */
	then call ssu_$abort_line (sci_ptr, lister_codes_$master_eq_output, "^a>^a", out_dname, out_ename);

	if up_file_ptr = out_file_ptr			/* oh oh (3) */
	then call ssu_$abort_line (sci_ptr, lister_codes_$update_eq_output, "^a>^a", out_dname, out_ename);

	if out_file_ptr = null			/* user didn't specify...overwrite master at end */
	then do;
	     call initiate_file_$create (
		process_dir, "!lister." || unique_chars_ (""b), RW_ACCESS,
		out_file_ptr, dummy_cr, dummy_bc, code2);
	     if out_file_ptr = null
	     then call ssu_$abort_line (sci_ptr, code2, "Trying to create temporary segment in process dir.");
	     overwrite_master_file = ON;
	end;
	else overwrite_master_file = OFF;

	merge_type = MERGE_ADD;			/* defaults */
	flx = 0;					/* .. */
	done = OFF;				/* .. */
	print_totals = OFF;			/* .. */
	all_fields = ON;				/* .. */
	fatal_error = OFF;

	do while (code = 0);
	     if arg_string = "-add"
	     then merge_type = MERGE_ADD;

	     else if arg_string = "-and"
	     then merge_type = MERGE_AND;

	     else if arg_string = "-or"
	     then merge_type = MERGE_OR;

	     else if arg_string = "-sub" | arg_string = "-subtract"
	     then merge_type = MERGE_SUBTRACT;

	     else if arg_string = "-tt" | arg_string = "-totals"
	     then print_totals = ON;

	     else if arg_string = "-fn" | arg_string = "-field_name"
	     then do;
		all_fields = OFF;			/* user is about to specify which fields are wanted */

		call get_next_argument;
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, 0, "-field_name must be followed by one or more field names.");

		done = OFF;
		do while (^done);
		     if index (arg_string, "-") = 1
		     then done = ON;		/* drop out of -field_name loop */
		     else do;
			if length (arg_string) > 32
			then do;
			     call ssu_$print_message (sci_ptr, lister_codes_$long_fieldname, arg_string);
			     fatal_error = ON;
			     n = -2;
			end;
			else n = lister_hash_fid_ (in_file_ptr, (arg_string));
			if n = -1
			then do;
			     call ssu_$print_message (sci_ptr, lister_codes_$undefined_fieldname, arg_string);
			     fatal_error = ON;
			end;

			do i = lbound (field_list, 1) to flx while (field_list (i) ^= n);
			end;

			if i <= flx
			then do;
			     call ssu_$print_message (sci_ptr, lister_codes_$dup_fieldname, arg_string);
			     fatal_error = ON;
			end;

			if flx = hbound (field_list, 1)
			then do;
			     call ssu_$print_message (sci_ptr, 0, "Too many fieldnames after -fn. Limit ^d",
				hbound (field_list, 1));
			     fatal_error = ON;
			end;

			if ^fatal_error
			then do;
			     flx = flx + 1;
			     field_list (flx) = n;
			end;

			call get_next_argument;
			if code ^= 0
			then done = ON;
		     end;
		end;				/* end of do while (^done); */
	     end;
	     else call badarg;

	     if done				/* skip call if just came out of -field_name section */
	     then done = OFF;			/* but call next time */
	     else call get_next_argument;
	end;

	if fatal_error
	then go to cleanup_and_return;

	if all_fields
	then do;
	     field_table_ptr = input_file.field_table_offset;
	     n = MIN_FIELD_INDEX;
	     do flx = lbound (field_list, 1) to hbound (field_list, 1);
		field_list (flx) = n;
		n = n + 1;
	     end;
	     flx = flx - 1;
	end;

	counts = lister_merge_ (in_file_ptr, up_file_ptr, out_file_ptr, field_list, flx, merge_type, code);

	if code ^= 0 
	     then call ssu_$abort_line (sci_ptr, code);

	if print_totals
	then do;
	     if counts (1) = 1 & counts (2) = 1
	     then first_s = "";
	     else first_s = "s";

	     if counts (3) = 1
	     then second_s = "";
	     else second_s = "s";

	     call ioa_ ("merge_list: ^d master and ^d update record^a merged into ^d output record^a.", counts (1),
		counts (2), first_s, counts (3), second_s);
	end;

	free field_list;
	if overwrite_master_file
	then do;

/* Copy the items individually in order to generate a call to area_assign_.
   This routine will optimize copying the area, whereas assigning the
   whole level-1 structures will generate inline code to copy all 255K */

	     input_file.field_table_offset = output_file.field_table_offset;
	     input_file.record_head = output_file.record_head;
	     input_file.record_tail = output_file.record_tail;
	     input_file.unused (*) = output_file.unused (*);
	     input_file.next_uid = output_file.next_uid;
	     input_file.version = output_file.version;
	     input_file.n_records = output_file.n_records;
	     input_file.area = output_file.area;
	     unspec (delete_options) = OFF;
	     delete_options.force = ON;
	     delete_options.segment = ON;
	     delete_options.link = ON;
	     delete_options.chase = ON;
	     call delete_$ptr (out_file_ptr, string (delete_options), my_name, code);
	     out_file_ptr = null;
	end;

	call adjust_bit_count_ (out_dname, out_ename, OFF, out_bitcount, code);

	lister_severity_ = 0;
	
	go to finish;

process_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = PROCESS;
	my_name = "process";
	command = OFF;
	goto process_common;

process_list:
pls:
	entry;

	function_index = PROCESS;
	my_name = "process_list";
	command = ON;

process_common:
	call initialize;

	delete_output_file_on_error = ON;

	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, in_bitcount, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* try to process v1 file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

/* Set default listform segment pathname. */

	format_dname = working_dir;
	componentname = "";
	
	call suffixed_name_$new_suffix (in_ename, "lister", "listform", format_ename, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", in_ename);

/* Set default list segment pathname. */

	out_dname = working_dir;
	out_ename = substr (format_ename, 1, length (rtrim (format_ename)) - 4);

/* Set defaults for control arguments. */

	segment_output = OFF;			/* .. */
	truncate = ON;				/* .. */
	select_all = ON;				/* .. */
	arg_position = 0;				/* .. */
	print_totals = OFF;			/* .. */

/* Look for user-specified listform pathname. */

	call get_next_argument;
	if code = 0
	then if index (arg_string, "-") ^= 1
	     then do;
		call expand_pathname_$component_add_suffix (arg_string, "listform", format_dname, format_ename, componentname, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
		out_ename = substr (format_ename, 1, length (rtrim (format_ename)) - 4);

		call get_next_argument;
	     end;

/* Process control arguments. */

	do while (code = 0);
	     if (arg_string = "-ext") | (arg_string = "-extend") | (arg_string = "-ex" /* OBSOLETE */)
	     then truncate = OFF;
	     else if arg_string = "-of" | arg_string = "-output_file"
	     then do;
		segment_output = ON;
		call get_next_argument;
		if code = 0
		then if index (arg_string, "-") ^= 1
		     then do;
			call expand_pathname_ (arg_string, out_dname, out_ename, code);
			if code ^= 0
			then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
		     end;
		     else arg_index = arg_index - 1;
						/* look at this arg again, later */
	     end;
	     else if arg_string = "-sel" | arg_string = "-select"
	     then do;
		select_all = OFF;
		call get_select_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else if arg_string = "-st" | arg_string = "-sort"
	     then do;
		select_all = OFF;
		call get_sort_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else if arg_string = "-tt" | arg_string = "-totals"
	     then print_totals = ON;
	     else if arg_string = "-bfe" | arg_string = "-brief_errors"
	     then brief_errors = ON;
	     else if arg_string = "-ag" | arg_string = "-argument" | arg_string = "-arguments"
	     then do;
		arg_position = arg_index - 1;
		arg_index = arg_count + 1;		/* force loop termination */
	     end;
	     else call badarg;
	     call get_next_argument;
	end;

	if ^segment_output				/* user didn't specify -output_file */
	then do;
	     out_dname = process_dir;
	     out_ename = "!lister." || unique_chars_ (""b);
	end;

	call get_output_segment (out_dname, out_ename, output_ptr, out_bitcount, code);
	if code ^= 0
	then do;
	     call cleanup_handler;
	     return;
	end;

	if truncate
	then output_index = 1;
	else output_index = divide (out_bitcount + 8, 9, 24, 0) + 1;

	if componentname = ""
	     then do;

	     call initiate_file_ (format_dname, format_ename, R_ACCESS, format_ptr, format_bitcount, code);
	     if format_ptr = null
		then call ssu_$abort_line (sci_ptr, code, "^a>^a", format_dname, format_ename);
	end;
	else do;
	     call initiate_file_$component (format_dname, format_ename, componentname, R_ACCESS, format_ptr, format_bitcount, code);
	     if format_ptr = null
		then call ssu_$abort_line (sci_ptr, code, 
		pathname_$component (format_dname, format_ename, componentname));
	end;

	format_length = divide (format_bitcount + 8, 9, 24, 0);

	if saved_version = 1
	then if index (format_string, ":uid") ^= 0
	     then do;
		call lister_convert_ (in_file_ptr, code);
		if code ^= 0
		then call ssu_$abort_line (sci_ptr, lister_codes_$cant_convert, "^a>^a", in_dname, in_ename);
	     end;

	call lister_format_parse_ (in_file_ptr, area_ptr, format_string, format_table_ptr, error_token, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", error_token);

	if select_ptr ^= null | sort_list_ptr ^= null
	then do;
	     n = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);

	     if select_ptr ^= null & n = 0		/* user wanted selection, but we didn't find any */
	     then do;
		out_bitcount = 9 * (output_index - 1);
						/* truncate seg, if necessary */
		call close_output_segment (out_dname, out_ename, output_ptr, out_bitcount, code);

		lister_severity_ = 1;
		if ^brief_errors
		then call ssu_$abort_line (sci_ptr, 0, "No records were selected.  ^a>^a", in_dname, in_ename);
		call cleanup_handler;
		return;
	     end;

	     if sort_list_ptr ^= null
	     then call lister_sort_ (in_file_ptr, selected_records_ptr, sort_list_ptr);
	end;
	else n = input_file.n_records;

	call lister_print_ (in_file_ptr, format_table_ptr, output_ptr, output_index, select_all, selected_records_ptr,
	     arg_list_ptr, arg_position, brief_errors, OFF, rtrim (format_dname) || ">" || format_ename);

	if ^segment_output
	then do;
	     call iox_$put_chars (iox_$user_output, output_ptr, output_index - 1, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "While writing on user_output");

	     unspec (delete_options) = OFF;
	     delete_options.force = ON;
	     delete_options.segment = ON;
	     delete_options.link = ON;
	     delete_options.chase = ON;
	     call delete_$ptr (output_ptr, string (delete_options), my_name, code);
	     output_ptr = null;
	end;
	else do;
	     out_bitcount = 9 * (output_index - 1);
	     call close_output_segment (out_dname, out_ename, output_ptr, out_bitcount, code);
	end;
	
	if print_totals
	then call ioa_ ("process_list: ^d record^[s^] processed.", n, (n ^= 1));

	lister_severity_ = 0;
	
	go to finish;

copy_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = COPY;
	my_name = "copy";
	command = OFF;
	goto copy_common;

copy_list:
cpls:
	entry;

	function_index = COPY;
	my_name = "copy_list";
	command = ON;

copy_common:
	call initialize;
	
	delete_output_file_on_error = ON;

	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);
	if code ^= 0 & saved_version ^= 1		/* Try to process v1 file. */
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	call get_next_argument;
	if code ^= 0
	then go to usage_ (function_index);

	call expand_pathname_$add_suffix (arg_string, "lister", out_dname, out_ename, code);
	if code ^= 0
	then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);

	call initiate_file_$create (
	     out_dname, out_ename, RW_ACCESS, out_file_ptr, 
	     output_file_created, dummy_bc, code);
	if out_file_ptr = null
	then call ssu_$abort_line (sci_ptr, code, "^a>^a", out_dname, out_ename);

	if in_file_ptr = out_file_ptr
	     then call ssu_$abort_line (sci_ptr, error_table_$sameseg, 
	     "^a", pathname_ (out_dname, out_ename));

	print_totals = OFF;			/* default value */
	select_ptr = null;				/* .. */

	call get_next_argument;
	do while (code = 0);
	     if arg_string = "-sel" | arg_string = "-select"
	     then do;
		call get_select_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else if arg_string = "-tt" | arg_string = "-totals"
	     then print_totals = ON;
	     else if arg_string = "-bfe" | arg_string = "-brief_errors"
	     then brief_errors = ON;
	     else call badarg;
	     call get_next_argument;
	end;

	n = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);

	call lister_copy_file_head_ (in_file_ptr, out_file_ptr);
	if n ^= 0					/* Only copy when some are selected */
	     then call lister_copy_records_ (in_file_ptr, out_file_ptr, selected_records_ptr);
	else if ^brief_errors 
	     then call ssu_$print_message (sci_ptr, 0, "No records were selected.  ^a>^a", in_dname, in_ename);

	call adjust_bit_count_ (out_dname, out_ename, OFF, out_bitcount, code);
	
	if print_totals
	then call ioa_ ("copy_list: ^d record^[s^] copied.", n, (n ^= 1));

	if select_ptr ^= null & n = 0
	     then lister_severity_ = 1;
	else lister_severity_ = 0;
	
	go to finish;

sort_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = SORT;
	my_name = "sort";
	command = OFF;
	goto sort_common;

sort_list:
sls:
	entry;

	function_index = SORT;
	my_name = "sort_list";
	command = ON;

sort_common:
	call initialize;

	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);

	if code ^= 0
	then do;
	     if saved_version = 1
	     then call lister_convert_ (in_file_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
	end;

	call get_next_argument;
	do while (code = 0);
	     if arg_string = "-st" | arg_string = "-sort"
	     then do;
		call get_sort_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else if arg_string = "-bfe" | arg_string = "-brief_errors"
	     then brief_errors = ON;
	     else call badarg;

	     call get_next_argument;
	end;

	if sort_list_ptr = null
	then go to usage_ (function_index);

	n = lister_select_ (in_file_ptr, null, area_ptr, selected_records_ptr);

	if n = 0					/* no records selected */
	then do;
	     lister_severity_ = 1;
	     if ^brief_errors
	     then call ssu_$abort_line (sci_ptr, 0, "No records were selected.  ^a>^a", in_dname, in_ename);
	     call cleanup_handler;
	     return;
	end;

	call lister_sort_ (in_file_ptr, selected_records_ptr, sort_list_ptr);

	input_file.record_head = selected_records_ptr -> list_node.list (1);

	do i = 1 to n - 1;
	     selected_records_ptr -> list_node.list (i) -> input_record.next =
		selected_records_ptr -> list_node.list (i + 1);
	end;

	selected_records_ptr -> list_node.list (n) -> input_record.next = null;
	input_file.record_tail = selected_records_ptr -> list_node.list (n);

	lister_severity_ = 0;
	
	go to finish;

trim_request:
	entry (bv_sci_ptr, bv_info_ptr);
	
	sci_ptr = bv_sci_ptr;
	lister_info_ptr = bv_info_ptr;
	function_index = TRIM;
	my_name = "trim";
	command = OFF;
	goto trim_common;

trim_list:
tls:
	entry;

	function_index = TRIM;
	my_name = "trim_list";
	command = ON;

trim_common:
	call initialize;

	if command
	     then do;
	     call get_next_argument;
	     if code ^= 0
		then go to usage_ (function_index);
	end;

	cleanup_handler_established = ON;
	on cleanup call cleanup_handler;

	call get_input_segment ("lister", in_file_ptr, 0, code);
	if code ^= 0
	then go to cleanup_and_return;

	call check_version_number (in_file_ptr, in_dname, in_ename, code);

	if code ^= 0
	then do;
	     if saved_version = 1
	     then call lister_convert_ (in_file_ptr, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
	end;

	print_totals = OFF;
	call get_next_argument;

	do while (code = 0);
	     if arg_string = "-sel" | arg_string = "-select"
	     then do;
		call get_select_arg;
		if code ^= 0
		then do;
		     call cleanup_handler;
		     return;
		end;
	     end;
	     else if arg_string = "-tt" | arg_string = "-totals"
	     then print_totals = ON;
	     else call badarg;

	     call get_next_argument;
	end;

	if select_ptr = null			/* -select not given */
	then call ssu_$abort_line (sci_ptr, error_table_$noarg, "-select must be specified.");

	n = lister_select_ (in_file_ptr, select_ptr, area_ptr, selected_records_ptr);
	call lister_delete_ (in_file_ptr, selected_records_ptr);

	if print_totals
	then call ioa_ ("trim_list: ^d record^[s^] deleted.", n, (n ^= 1));

	if n = 0
	     then lister_severity_ = 1;
	else lister_severity_ = 0;
	
	go to finish;

finish:
	if arg_index <= arg_count
	then call ssu_$print_message (sci_ptr, 0, "Extra arguments after #^d ignored.", arg_index - 1);
	delete_output_file_on_error = OFF;		/* no errors when going to finish */

cleanup_and_return:
	if command
	     then call ssu_$destroy_invocation (sci_ptr);
	     
	if cleanup_handler_established
	     then call cleanup_handler;
	return;

usage_ (1):					/* create */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path {-totals(-tt)}", my_name);

usage_ (2):					/* sort */
	call ssu_$abort_line (sci_ptr, 0,
	     "Usage: ^a path -sort ""sort string"" {-brief_errors(-bfe)}^/where sort string is: " ||
	     "field_name {-ascending(-asc)|-descending(-dsc)|-numeric(-num)|-alphabetic(-alp)}...",
	     my_name);

usage_ (3):					/* process */
	call ssu_$abort_line (sci_ptr, 0,
	     "Usage: ^a path {fmt_path} {-output_file(-of) {path}|-select(-sel) " || 
	     "select_expr|-sort(-st) sort_string|-extend(-ext)|-totals(-tt)", my_name);

usage_ (5):					/* merge */
	call ssu_$abort_line (sci_ptr, 0,
	     "Usage: ^a in_path up_path {out_path} {-add|-and|-or|-subtract(-sub)" || 
	     "|-field_name(-fn) fn1 ... fnK|-totals(-tt)}", my_name);

usage_ (6):					/* expand */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path {-totals(-tt)|-line_length(-ll) N|-all(-a)}",
	     my_name);

usage_ (8):					/* copy */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a in_path out_path {-select(-sel) " ||
	     "select_expr|-totals(-tt)|-brief_errors(-bfe)}", my_name);

usage_ (9):					/* trim */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path -select(-sel) select_expr {-totals(-tt)}", 
	     my_name);
usage_ (10):					/* describe */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path {-field_name(-fn)|-totals(-tt)|" ||
	     "-delimiter(-dm) {record|field}|-select(-sel) select_expr}", my_name);
usage_ (11):					/* display */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path -field_name(-fn) name1 ... nameN " ||
	     "{-select(-sel) select_expr|-brief_errors(-bfe)}", my_name);
usage_ (12):					/* modify	     */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path -field_name(-fn) field_name " ||
	     "{-string(-str)} field_value {-select(-sel) select_expr|-total(-tt)|-brief_errors(-bfe)}", my_name);
usage_ (13):					/* append	     */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path {-field_name(-fn) field_name " || 
	     "{-string(-str)} field_value}", my_name);
usage_ (14):					/* make	     */
	call ssu_$abort_line (sci_ptr, 0, "Usage: ^a path -field_name(-fn) name1 ... nameN " ||
	     "{-delimiter(-dm) RF}", my_name);

badarg:	proc;
	
	if arg_length < 1
	     then call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Null argument encountered.");
	else if index (arg_string, "-") = 1
	     then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg_string);
	else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg_string);

     end badarg;

check_version_number:
	procedure (P_file_ptr, P_dname, P_ename, P_code);

/* parameters */

declare (
         P_file_ptr ptr,
         P_dname char (*),
         P_ename char (*),
         P_code fixed bin (35)
         ) parameter;

/* program */

	     saved_version = P_file_ptr -> input_file.version;
	     if saved_version ^= lister_file_version_2
	     then P_code = error_table_$unimplemented_version;
	     else P_code = 0;
	     return;

	end check_version_number;

cleanup_handler:
	procedure;

/* program */

	     if assign_info_ptr ^= null		/* extents defined in input file. */
	     then free assign_info;			/* so must free first. */

	     if output_ptr ^= null
	     then do;
		if output_file_created & delete_output_file_on_error
		     then do;
		     unspec (delete_options) = OFF;
		     delete_options.force = ON;
		     delete_options.segment = ON;
		     delete_options.link = ON;
		     delete_options.chase = ON;
		     call delete_$ptr (output_ptr, string (delete_options), my_name, ignore_code);
		end;
		else call terminate_file_ (output_ptr, 0, TERM_FILE_TERM, ignore_code);
		output_ptr = null;
	     end;

	     if format_ptr ^= null
	     then do;
		call terminate_file_ (format_ptr, 0, TERM_FILE_TERM, ignore_code);
		format_ptr = null;
	     end;

	     if temp_append_ptr ^= null
		then call release_temp_segment_ (my_name, temp_append_ptr, ignore_code);

	     if temp_format_ptr ^= null
		then call release_temp_segment_ (my_name, temp_format_ptr, ignore_code);

	     if temp_output_ptr ^= null
		then call release_temp_segment_ (my_name, temp_output_ptr, ignore_code);

	     if temp_input_ptr ^= null
		then call release_temp_segment_ (my_name, temp_input_ptr, ignore_code);

	     if input_ptr ^= null
	     then do;
		call terminate_file_ (input_ptr, 0, TERM_FILE_TERM, ignore_code);
		input_ptr = null;
	     end;

	     if partial_record_appended
		then do;
		n = 1;
		allocate list_node 
		     set (selected_records_ptr) in (system_area);
		selected_records_ptr -> list_node.size = 1;
		selected_records_ptr -> list_node.list (1) = recordp;
		call lister_delete_ (in_file_ptr, selected_records_ptr);
		free selected_records_ptr -> list_node in (system_area);
		input_file.next_uid = input_file.next_uid - 1;
	     end;
	     
	     if in_file_ptr ^= out_file_ptr
	     then do;
		if out_file_ptr ^= null
		then do;
		     if output_file_created & delete_output_file_on_error
			then do;
			unspec (delete_options) = OFF;
			delete_options.force = ON;
			delete_options.segment = ON;
			delete_options.link = ON;
			delete_options.chase = ON;
			call delete_$ptr (out_file_ptr, string (delete_options), my_name, code);
		     end;
		     else call terminate_file_ (out_file_ptr, 0, TERM_FILE_TERM, ignore_code);
		     out_file_ptr = null;
		end;
	     end;

	     if in_file_ptr ^= null
	     then do;
		call terminate_file_ (in_file_ptr, 0, TERM_FILE_TERM, ignore_code);
		in_file_ptr = null;
	     end;

	     if up_file_ptr ^= null
	     then do;
		call terminate_file_ (up_file_ptr, 0, TERM_FILE_TERM, ignore_code);
		up_file_ptr = null;
	     end;

	     if select_ptr ^= null
	     then call free_select_expr;

	     if sort_list_ptr ^= null
	     then call free_sort_expr;

	     if format_table_ptr ^= null
	     then call free_format_table;

	     if selected_records_ptr ^= null
	     then do;
		free selected_records_ptr -> list_node in (system_area);
		selected_records_ptr = null;
	     end;

	     return;

	end cleanup_handler;

/* Subroutine to close our output segment (truncate, set bitcount) */

close_output_segment:
	procedure (bv_dir, bv_name, bv_output_ptr, bv_bitcount, bv_code);

/* parameters */

declare (
         bv_dir char (*),
         bv_name char (*),
         bv_output_ptr ptr,
         bv_bitcount fixed bin (24),
         bv_code fixed bin (35)
         ) parameter;

/* program */

	     bv_code = 0;

	     call terminate_file_ (bv_output_ptr, bv_bitcount, TERM_FILE_TRUNC_BC, bv_code);
	     if bv_code ^= 0
		then call ssu_$abort_line (sci_ptr, bv_code, "Attempting to truncate and set bit count on ^a>^a.", bv_dir, bv_name);

	     return;

	end close_output_segment;

free_format_table:
	procedure ();

	     if format_table.literal_table ^= null
	     then do;
		ltp = format_table.literal_table;

		do i = 1 to literal_table.n_literals;
		     atomp = literal_table.literal (i);
		     atom_length = length (atom);
		     free atom in (system_area);
		end;

		free literal_table in (system_area);
	     end;

	     free format_table in (system_area);
	     format_table_ptr = null;
	     return;

	end free_format_table;

free_select_expr:
	procedure ();

/* automatic */

dcl  ltx fixed bin;

/* program */

	     ltp = select_expression.literal_table_ptr;

	     if ltp ^= null
	     then do;
		do ltx = 1 to literal_table.n_literals;
		     atomp = literal_table.literal (ltx);

		     if numeric_atom.flag = numeric_flag
		     then free numeric_atom in (system_area);
		     else do;
			atom_length = length (atom);
			free atom in (system_area);
		     end;
		end;

		free literal_table in (system_area);
	     end;

	     free select_expression in (system_area);
	     select_ptr = null;
	     return;

	end free_select_expr;

free_sort_expr:
	procedure ();

/* program */

	     free sort_list in (system_area);
	     sort_list_ptr = null;
	     return;

	end free_sort_expr;

get_next_argument:
	procedure ();

	     call arg_getter (arg_index, arg_ptr, arg_length, code, arg_list_ptr);
	     arg_index = arg_index + 1;

	end get_next_argument;

get_input_segment:
	procedure (bv_suffix, bv_ptr, bv_bitcount, bv_code);

/* parameters */

declare (
         bv_suffix char (*),
         bv_ptr ptr,
         bv_bitcount fixed bin (24),
         bv_code fixed bin (35)
         ) parameter;

/* program */

	     if command | bv_suffix ^= "lister"
		then do;
		call expand_pathname_$add_suffix (arg_string, bv_suffix, in_dname, in_ename, bv_code);
		if bv_code ^= 0
		     then call ssu_$abort_line (sci_ptr, bv_code, "^a", arg_string);
	     end;
	     else do;
		if lister_info.database.ename = ""
		     then call ssu_$abort_line (sci_ptr, lister_codes_$no_current_lister);
		in_dname = lister_info.database.dname;
		in_ename = lister_info.database.ename;
	     end;

	     call initiate_file_ (in_dname, in_ename, R_ACCESS, bv_ptr, bv_bitcount, bv_code);
	     if bv_ptr = null
	     then call ssu_$abort_line (sci_ptr, bv_code, "^a>^a", in_dname, in_ename);

	     bv_code = 0;
	     return;

	end get_input_segment;

get_input_and_output_segs:
	procedure (bv_in_suffix, bv_out_suffix);

/* parameters */

dcl (
     bv_in_suffix char (*),
     bv_out_suffix char (*)
     ) parameter;

/* program */

	     if command
		then do;
		call expand_pathname_$add_suffix (arg_string, bv_in_suffix, in_dname, in_ename, code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code, "^a", arg_string);
	     end;
	     else do;
		if lister_info.database.ename = ""
		     then call ssu_$abort_line (sci_ptr, lister_codes_$no_current_lister);
		in_dname = lister_info.database.dname;
		in_ename = lister_info.database.ename;
	     end;

	     call suffixed_name_$new_suffix (in_ename, bv_in_suffix, bv_out_suffix, out_ename, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a", in_ename);

	     call initiate_file_ (in_dname, in_ename, R_ACCESS, input_ptr, in_bitcount, code);
	     if input_ptr = null
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);

	     out_dname = working_dir;
	     call initiate_file_$create (
		out_dname, out_ename, RW_ACCESS, 
		output_ptr, output_file_created, dummy_bc, code);
	     if output_ptr = null
	     then call ssu_$abort_line (sci_ptr, code, "^a>^a", out_dname, out_ename);

	     code = 0;
	     return;

	end get_input_and_output_segs;

/* Subroutine to create (if necessary) our output segment */

get_output_segment:
	procedure (bv_dir, bv_name, bv_output_ptr, bv_bitcount, bv_code);

/* parameters */

declare (
         bv_dir char (*),
         bv_name char (*),
         bv_output_ptr ptr,
         bv_bitcount fixed bin (24),
         bv_code fixed bin (35)
         ) parameter;

/* program */

	     bv_code = 0;

	     call initiate_file_$create (
		bv_dir, bv_name, RW_ACCESS, bv_output_ptr, 
		output_file_created, bv_bitcount, bv_code);
	     if bv_output_ptr = null
	     then call ssu_$abort_line (sci_ptr, bv_code, "Unable to create ^a>^a.", bv_dir, bv_name);

	     return;

	end get_output_segment;

get_select_arg:
	procedure ();

	     call get_next_argument;
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "-select must be followed by a select expression.");

	     if saved_version = 1
	     then if index (arg_string, ":uid") ^= 0
		then do;
		     call lister_convert_ (in_file_ptr, code);
		     if code ^= 0
		     then do;
			code = lister_codes_$cant_convert;
			call ssu_$abort_line (sci_ptr, code, "^a>^a", in_dname, in_ename);
		     end;
		end;

	     call lister_compile_select_ (arg_string, in_file_ptr, area_ptr, select_ptr, error_token, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a", error_token);

	     return;

	end get_select_arg;

get_sort_arg:
	procedure ();

	     call get_next_argument;
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "-sort must be followed by a sort string.");

	     call lister_compile_sort_ (arg_string, in_file_ptr, area_ptr, sort_list_ptr, error_token, code);
	     if code ^= 0
	     then call ssu_$abort_line (sci_ptr, code, "^a", error_token);
	     return;

	end get_sort_arg;

abort_entry:
	proc;
	
/* This is where ssu_$abort_line returns for standalone invocations */
/* The charter is to do a non-local goto. */

	goto cleanup_and_return;
	
     end abort_entry;

/* Procedure to initialize a bunch of variables used by most entries, and to initialize
   all variables used by the cleanup handler. NB: this procedure must be quick. */

initialize:
	procedure ();

	     cleanup_handler_established = OFF;
	     if command 
		then do;
		call ssu_$standalone_invocation (sci_ptr, my_name, 
		     lister_version, cu_$arg_list_ptr (), abort_entry,
		     code);
		if code ^= 0
		     then do;
		     call com_err_ (code, my_name);
		     goto cleanup_and_return;
		end;
/*		call ssu_$record_usage (sci_ptr, codeptr (process_list), code);
		if code ^= 0
		     then call ssu_$abort_line (sci_ptr, code); */
	     end;
	     
	     call ssu_$return_arg (sci_ptr, arg_count, af, retptr, retlen);
	     if af				/* Only dls & dils callable as AF, for now. */
	     then if function_index = DESCRIBE | function_index = DISPLAY
		then arg_getter = cu_$af_arg_ptr_rel;
		else call ssu_$abort_line (sci_ptr, error_table_$active_function);
	     else do;
		retptr = null ();
		arg_getter = cu_$arg_ptr_rel;
	     end;
	     arg_index = 1;
	     call ssu_$arg_list_ptr (sci_ptr, arg_list_ptr);

	     brief_errors = OFF;
	     print_totals = OFF;
	     delete_output_file_on_error = OFF;
	     partial_record_appended = OFF;
	     input_ptr = null;			/* initialize variables used in cleanup handler */
	     output_ptr = null;
	     format_ptr = null;
	     in_file_ptr = null;
	     up_file_ptr = null;
	     out_file_ptr = null;
	     area_ptr = null;
	     select_ptr = null;
	     selected_records_ptr = null;
	     sort_list_ptr = null;
	     assign_info_ptr = null;
	     format_table_ptr = null;
	     temp_append_ptr = null;
	     temp_format_ptr = null;
	     temp_output_ptr = null;
	     lister_severity_ = 2;
	     working_dir = get_wdir_ ();

	     if process_dir = ""
	     then process_dir = get_pdir_ ();

	     call get_system_free_area_ (area_ptr);

	end initialize;

     end;
  



		    lister_select_.pl1              11/05/84  1154.9rew 11/02/84  1204.9      144459


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

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

/* Program to search a Lister file and create a list of those records which
   match the search criteria.

   Written by Paul A. Green, July 29, 1973.
   Modified 740604 by PG to finish implementation.
   Modified 740605 by PG to get around pl1_operators_ bug in converting packed ptr to offset.
   Modified 740731 by PG to return number of records found.
   Modified 741110 by PG to add delete option.
   Modified 761105 by PG to rename from assist_search_ to lister_select_.
   Modified 770718 by PG to have a null select_ptr mean select everything, and to take advantage of n_records.
   Modified 770921 by PG to get program to agree with revised documentation.
   Modified 791128 by PG to add numeric selection (sugg 037)
   Modified 800813 by PB to handle :uid.
   Modified 800326 by PB to make less and greater completely case-sensitive.
   Modified 810805 by PB to compare numerically on ":uid less/greater NNN"
   Modified 811022 by PB to make 0-length fields match :null
   Modified 840523 by PB to add begins and ends operators.
*/

/* format: style3 */
lister_select_:
     procedure (bv_in_file_ptr, bv_select_ptr, bv_area_ptr, bv_selected_records_ptr) returns (fixed bin)
	     options (packed_decimal);

/* parameters */

dcl (
     bv_in_file_ptr ptr,
     bv_select_ptr ptr,
     bv_area_ptr ptr,
     bv_selected_records_ptr
     ptr
     ) parameter;

/* automatic */

declare (expr_succeeded_ptr, found_list_ptr, lp, p, selected_records_ptr)
         ptr,
        (n_records, i, j, k, select_depth)
         fixed bin;

/* based */

declare  expression_succeeded
        (select_depth) bit (1) aligned based (expr_succeeded_ptr),
         found_list (n_records) ptr unaligned based (found_list_ptr);

/* builtins */

declare (binary, bool, convert, hbound, index, lbound, length, null, ptr, translate)
         builtin;

/* conditions */

declare (cleanup, conversion)
         condition;

/* internal static initial */

declare (
         lower_case char (26) aligned initial ("abcdefghijklmnopqrstuvwxyz"),
         upper_case char (26) aligned initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")
         ) internal static;

/* include files */

%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	select_ptr = bv_select_ptr;
	area_ptr = bv_area_ptr;
	expr_succeeded_ptr = null;
	found_list_ptr = null;
	selected_records_ptr = null;
	n_records = input_file.n_records;

	on cleanup call cleanup_handler ("1"b);

	if select_ptr = null			/* flag to mean select all records */
	then do;
	     n = n_records;

	     if n = 0
	     then do;
		bv_selected_records_ptr = null;
		return (0);
	     end;

	     allocate list_node in (system_area) set (selected_records_ptr);

	     k = 0;
	     do recordp = input_file.record_head repeat input_record.next while (recordp ^= null);
		k = k + 1;
		selected_records_ptr -> list_node.list (k) = recordp;
	     end;

	     bv_selected_records_ptr = selected_records_ptr;
	     return (k);
	end;

	k = 0;
	allocate found_list in (system_area) set (found_list_ptr);

	ltp = select_expression.literal_table_ptr;
	select_depth = select_expression.size;
	allocate expression_succeeded in (system_area) set (expr_succeeded_ptr);

/* Main loop...inspect each record in the file.  Test it against the selection criteria.
   If the expression evaluates to "1"b, add it to the list of selected records. */

/* Note that the collating sequence explicitly includes null fields...they come before non-null fields. */

	on conversion
	     begin;
	     expression_succeeded (i) = "0"b;
	     go to op_end;
	end;

	do recordp = input_file.record_head repeat recordp -> input_record.next while (recordp ^= null);

	     do i = lbound (select_expression.element (*), 1) to select_expression.last_element;

		element.opcode = binary (select_expression.element (i).opcode, 9);
		element.not = select_expression.element (i).not;
		element.top = select_expression.element (i).top;
		element.field_index = select_expression.element (i).field_index;
		element.literal_index = select_expression.element (i).literal_index;

		expression_succeeded (i) = "0"b;

		go to op (element.opcode);		/* fan out to correct operator */
						/* Note that 8, 9, 13 & 14 are not possible. */

op (4):						/* CONTAINS */
op (15):						/* BEGINS */
op (16):						/* ENDS */

		if element.field_index >= 0		/* FINDEX [NOT] CONTAINS/BEGINS/ENDS LITERAL */
		then do;
		     p = input_record.field (element.field_index);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		     /* bool with "0110"b => (a & ^b) | (^a & b) */
		end;
		else if element.field_index = UID	/* UID [NOT] CONTAINS/BEGINS/ENDS LITERAL */
		then expression_succeeded (i) = ^element.not;
		else do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
		     p = input_record.field (j);	/* ANYFIELD [NOT] CONTAINS/BEGINS/ENDS LITERAL */
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		go to op_end;

op (1):						/* AND */
		expression_succeeded (i) = expression_succeeded (operand1) & expression_succeeded (operand2);
		go to op_end;

op (2):						/* OR */
		expression_succeeded (i) = expression_succeeded (operand1) | expression_succeeded (operand2);
		go to op_end;

op (3):						/* NOT */
		expression_succeeded (i) = ^expression_succeeded (operand1);
		go to op_end;

op (5):						/* EQUAL */
op (10):						/* NEQUAL */
		if element.literal_index = NULL_FIELD	/* ... EQUAL NULL */
		then if element.field_index >= 0	/* FINDEX [NOT] EQUAL NULL */
		     then expression_succeeded (i) =
			bool (element.not, compare (0, ptr (input_record.field (element.field_index), input_file.area), null), "0110"b);
		     else if element.field_index = UID	/* UID [NOT] EQUAL NULL */
		     then expression_succeeded (i) = element.not;
		     else				/* ANYFIELD [NOT] EQUAL NULL */
		     do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
			expression_succeeded (i) = bool (element.not, compare (0, ptr (input_record.field (j), input_file.area), null), "0110"b);
		     end;
		else if element.literal_index = NUMERIC_FIELD
						/* ... [NOT] NEQUAL :NUMERIC */
		then if element.field_index >= 0	/* FINDEX [NOT] NEQUAL :NUMERIC */
		     then do;
			p = input_record.field (element.field_index);
			expression_succeeded (i) = bool (element.not, valid_number (p), "0110"b);
		     end;
		     else if element.field_index = UID	/* UID [NOT] NEQUAL :NUMERIC */
		     then expression_succeeded (i) = ^element.not;
		     else do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
						/* :ANY [NOT] NEQUAL :NUMERIC */
			p = input_record.field (j);
			expression_succeeded (i) = bool (element.not, valid_number (p), "0110"b);
		     end;
		else if element.field_index >= 0	/* FINDEX [NOT] EQUAL LITERAL */
		| element.field_index = UID		/* UID [NOT] LITERAL */
		then do;
		     if element.field_index ^= UID
		     then p = input_record.field (element.field_index);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		else				/* ANYFIELD [NOT] EQUAL LITERAL */
		do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
		     p = input_record.field (j);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		go to op_end;

op (6):						/* LESS */
op (11):						/* NLESS */
		if element.field_index >= 0		/* FINDEX [NOT] LESS LITERAL */
		| element.field_index = UID		/* UID [NOT] LESS LITERAL */
		then do;
		     if element.field_index ^= UID
		     then p = input_record.field (element.field_index);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = ^element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		else				/* ANYFIELD [NOT] LESS LITERAL */
		do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
		     p = input_record.field (j);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = ^element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		go to op_end;

op (7):						/* GREATER */
op (12):						/* NGREATER */
		if element.field_index >= 0		/* FINDEX [NOT] GREATER LITERAL */
		| element.field_index = UID		/* UID [NOT] GREATER LITERAL */
		then do;
		     if element.field_index ^= UID
		     then p = input_record.field (element.field_index);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		else				/* ANYFIELD [NOT] GREATER LITERAL */
		do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i));
		     p = input_record.field (j);
		     lp = ltp -> literal_table.literal (element.literal_index);

		     if p = null
		     then expression_succeeded (i) = element.not;
		     else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b);
		end;
		go to op_end;

op_end:
	     end;					/* of expression evaluation loop */

	     if expression_succeeded (i - 1)		/* last expression */
	     then do;
		k = k + 1;
		found_list (k) = recordp;
	     end;
	end;					/* of record loop */

	if k ^= 0
	then do;
	     n = k;
	     allocate list_node in (system_area) set (selected_records_ptr);

	     do i = 1 to k;
		selected_records_ptr -> list_node.list (i) = found_list (i);
	     end;
	end;

	bv_selected_records_ptr = selected_records_ptr;
	call cleanup_handler ("0"b);
	return (k);

compare:
	procedure (bv_compare_type, bv_fp, bv_lp) returns (bit (1) aligned);

/* parameters */

declare (
         bv_compare_type fixed bin,
         bv_fp ptr,
         bv_lp ptr
         ) parameter;

/* automatic */

declare  field_value_len fixed bin (21),
         literal_value_len fixed bin (21),
         numeric_field_value float dec (29) unal;

/* based */

declare  field_value char (field_value_len) varying based (bv_fp),
         literal_value char (literal_value_len) varying based (bv_lp),
         1 numeric_literal aligned based (bv_lp),
         2 flag fixed bin (35),
         2 value float dec (29) unal;

/* program */

	     if bv_compare_type = 0
		then goto compare_type (0);
	     literal_value_len = length (literal_value);
	     if element.field_index = UID
	     then goto compare_uid (bv_compare_type);	/* Note that 1-4, 8, 9 are not possible */
	     field_value_len = length (field_value);
	     go to compare_type (bv_compare_type);	/* Note that 1-3, 8, 9 are not possible */

compare_type (0):					/* NULL */
	     if bv_fp = null
		then return ("1"b);			/* either a null field */
	     field_value_len = length (field_value);
	     if field_value_len = 0			/* or a zero length field */
		then return ("1"b);			/* should match :null */
	     else return ("0"b);
	     
compare_type (4):					/* CONTAINS */
	     return (index (translate (field_value, lower_case, upper_case), translate (literal_value, lower_case, upper_case))
		^= 0);

compare_type (15):					/* BEGINS */
	     if literal_value_len > field_value_len
		then return ("0"b);
	     else return 
		(substr 
		    (translate (field_value, lower_case, upper_case), 
		    1, 
		    literal_value_len) 
		= translate (literal_value, lower_case, upper_case));
	     
compare_type (16):					/* ENDS */
	     if literal_value_len > field_value_len
		then return ("0"b);
	     else return 
		(substr 
		    (translate (field_value, lower_case, upper_case), 
		    (field_value_len - literal_value_len) + 1, 
		    literal_value_len) 
		= translate (literal_value, lower_case, upper_case));

compare_type (6):					/* LESS */
	     return (field_value < literal_value);
	     
compare_type (5):					/* EQUAL */
	     return (field_value = literal_value);

compare_type (7):					/* GREATER */
	     return (field_value > literal_value);

(conversion):
compare_type (10):					/* NEQUAL */
	     numeric_field_value = convert (numeric_field_value, field_value);
	     return (numeric_field_value = numeric_literal.value);

(conversion):
compare_type (11):					/* NLESS */
	     numeric_field_value = convert (numeric_field_value, field_value);
	     return (numeric_field_value < numeric_literal.value);

(conversion):
compare_type (12):					/* NGREATER */
	     numeric_field_value = convert (numeric_field_value, field_value);
	     return (numeric_field_value > numeric_literal.value);

compare_uid (5):					/* EQUAL	     */
	     return (input_record.uid = binary (literal_value));
	     
compare_uid (6):					/* LESS	     */
	     return (input_record.uid < binary (literal_value));

compare_uid (7):					/* GREATER     */
	     return (input_record.uid > binary (literal_value));

compare_uid (10):					/* NEQUAL	     */
	     return (input_record.uid = numeric_literal.value);

compare_uid (11):					/* NLESS	     */
	     return (input_record.uid < numeric_literal.value);

compare_uid (12):					/* NGREATER    */
	     return (input_record.uid > numeric_literal.value);

	end compare;

valid_number:
	procedure (P_fp) returns (bit (1) aligned);

/* parameters */

declare  P_fp ptr;

/* automatic */

declare  field_value_len fixed bin (21),
         numeric_field_value float dec (29) unal;

/* based */

declare  field_value char (field_value_len) varying based (P_fp);

/* program */

	     if P_fp = null
	     then return ("0"b);

	     field_value_len = length (field_value);

	     on conversion go to fail;

	     numeric_field_value = convert (numeric_field_value, field_value);
	     return ("1"b);

fail:
	     return ("0"b);

	end valid_number;

cleanup_handler:
	procedure (bv_free_selected_records);

/* parameters */

declare  bv_free_selected_records
         bit (1) aligned parameter;

/* program */

	     if found_list_ptr ^= null
	     then do;
		free found_list in (system_area);
		found_list_ptr = null;
	     end;

	     if expr_succeeded_ptr ^= null
	     then do;
		free expression_succeeded in (system_area);
		expr_succeeded_ptr = null;
	     end;

	     if bv_free_selected_records & selected_records_ptr ^= null
	     then do;
		free selected_records_ptr -> list_node in (system_area);
		selected_records_ptr = null;
	     end;

	end cleanup_handler;

     end						/* lister_select_ */;
 



		    lister_sort_.pl1                11/05/84  1154.9r w 11/05/84  1151.5       62514


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

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

/* Program to sort a Lister file into either ascending or descending alphabetical (not ASCII!) order.
   Written by Paul Green
   Modified by PG on 741110 to use alphabetical sort (thanks to Jerry Stern, who first debugged it)
   Modified 770606 by PG to handle -asc/-dsc on a per-field basis
   Modified 770706 by PG to take array of record ptrs as input and not rethread file.
   Modified 770721 by PG to fix bug 8 (can't sort 0 records).
   Modified 781020 by PG to get around pl1 bug 1795.
   Modified 790702 by PG to add numeric sorting.
   NOTE: This program gets bug 1844 if compiled with PL/I 24c or earlier.
   Modified 800312 by PG to fix 052 (sort null fields last in descending order).
   Modified 800605 by PB to remove, hopefully, last vestige of case-sensitivity.
*/

/* format: style3 */
lister_sort_:
     procedure (bv_in_file_ptr, bv_list_ptr, bv_sort_list_ptr) options (packed_decimal);

/* parameters */

declare (
         bv_in_file_ptr ptr,
         bv_list_ptr ptr,
         bv_sort_list_ptr ptr
         ) parameter;

/* builtin */

declare (convert, divide, hbound, lbound, null, onsource, translate)
         builtin;

/* conditions */

declare  conversion condition;

/* internal static */

declare (
         upper_case initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
         lower_case initial ("abcdefghijklmnopqrstuvwxyz")
         ) char (26) internal static;

/* include files */

%include lister_structures;

/* program */

	in_file_ptr = bv_in_file_ptr;
	sort_list_ptr = bv_sort_list_ptr;

	if bv_list_ptr = null			/* sorting 0 records is trivial */
	then return;

	n = bv_list_ptr -> list_node.size;

	if n = 1					/* sorting 1 record is trivial, too. */
	then return;

	on conversion onsource = "0";

	begin;					/* enter begin block to get storage */

/* automatic */

dcl (d, f, fi, i, j, k, previous_d, t)
     fixed bin;
dcl (p, pj, pk, list_ptr)
     ptr;
dcl (ascending, exchange)
     bit (1) aligned;

/* automatic adjustable */

declare  index_list (n) fixed bin;
declare  numeric_field (n) float decimal (29) unaligned;
						/* 4 words per element, 29 digits is plenty */

/* begin block */

	     list_ptr = bv_list_ptr;

	     do f = lbound (sort_list.key, 1) to hbound (sort_list.key, 1);
		fi = sort_list.key (f).field_index;
		ascending = sort_list.key (f).ascending;
		d = n;
		previous_d = d;

		do i = 1 to n;
		     index_list (i) = i;
		end;

		if sort_list.key (f).numeric
		then do i = 1 to n;
		     pj = list_ptr -> list_node.list (i) -> input_record.field (fi);

		     if pj = null
		     then numeric_field (i) = 0e0;
		     else numeric_field (i) = convert (numeric_field (1), pj -> atom);
		end;

		do d = (2 * divide (n, 4, 17, 0) + 1) repeat (2 * divide (d, 4, 17, 0) + 1) while (previous_d > 1);
		     previous_d = d;

		     do i = 1 to n - d;
			k = i + d;
up:
			j = k - d;

			pj = list_ptr -> list_node.list (j) -> input_record.field (fi);
			pk = list_ptr -> list_node.list (k) -> input_record.field (fi);

			exchange = "0"b;

/* Collating Sequence:
   Null fields.
   Non-null fields in alphabetical order.

   Algorithm:
   1. null fields get sorted before non-null fields if ascending,
   and after non-null fields if descending.
   2. equal fields always remain in the same relative order (sort is stable).
   3. alphabetics are translated to lower case before comparison; fields equal
   under translation are then compared directly. Ascending sorts put
   records into ascending (A<B<C<...<Z) order.  Descending sorts are exactly the opposite.
*/

			if pj = null
			then if pk = null
			     then if index_list (j) > index_list (k)
				then exchange = "1"b;
						/* preserve previous order */
				else ;		/* in order */
			     else exchange = ^ascending;
						/* ascending implies null items first */
						/* descending implies non-null items first */
			else if pk = null
			then exchange = ascending;	/* ascending implies null items first */
						/* descending implies non-null items first */
			else if sort_list.key (f).numeric
						/* NUMERIC SORT */
			then if numeric_field (index_list (j)) = numeric_field (index_list (k))
			     then if index_list (j) > index_list (k)
				then exchange = "1"b;
						/* preserve previous order */
				else ;		/* order ok */
			     else if numeric_field (index_list (j)) > numeric_field (index_list (k))
			     then exchange = ascending;
						/* ascending implies "less" items first */
			     else exchange = ^ascending;
						/* descending implies "greater" items first */

/* AVOID BUG 1795		else if translate (pj -> atom, lower_case, upper_case) =
   translate (pk -> atom, lower_case, upper_case) ... */
			else do;			/* ALPHABETIC SORT */
			     equal_bit =
				translate (pj -> atom, lower_case, upper_case)
				= translate (pk -> atom, lower_case, upper_case);
			     if equal_bit
			     then if index_list (j) > index_list (k)
				then exchange = "1"b; /* preserve previous order. */
				else;
						/* AVOID BUG 1795...		else if translate (pj -> atom, lower_case, upper_case) >
						   translate (pk -> atom, lower_case, upper_case)	... */
			     else do;
				greater_bit =
				     translate (pj -> atom, lower_case, upper_case)
				     > translate (pk -> atom, lower_case, upper_case);
				if greater_bit
				then exchange = ascending;
						/* ascending implies "less" items first */
				else exchange = ^ascending;
						/* descending implies "greater" items first */

/* Following is for bug 1795 too */
			     end;
			end;
dcl (equal_bit, greater_bit)
     bit (1) aligned;

/* end bug 1795 section */

			if exchange
			then do;
			     p = list_ptr -> list_node.list (k);
			     list_ptr -> list_node.list (k) = list_ptr -> list_node.list (j);
			     list_ptr -> list_node.list (j) = p;

			     t = index_list (k);
			     index_list (k) = index_list (j);
			     index_list (j) = t;

			     if j > d
			     then do;
				k = j;
				go to up;
			     end;
			end;
		     end;
		end;
	     end;
	end;					/* the begin block */

	return;

     end						/* lister_sort_ */;
  



		    lister_status_.pl1              11/05/84  1154.9r w 11/05/84  1151.5       52083


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

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

/* LISTER_STATUS_ - Program to report selected information about a lister segment.
   *   Written 800702 by Paul W. Benjamin
   Modified 800923 by PB to fix bug where long output is truncated.
   * */

lister_status_:
     proc (bv_in_file_ptr, bv_in_ename, bv_select_all, bv_status_info_ptr)
	     options (packed_decimal);
						/* parameters */

declare (
         bv_in_file_ptr ptr,				/* Input - ptr to lister segment. */
         bv_in_ename char (*),			/* Input - entryname of lister segment. */
         bv_select_all bit (1) aligned,			/* Input - user wants all records. */
         bv_status_info_ptr ptr			/* Input - ptr to status info structure. */
         ) parameter;

/* automatic */

declare  code fixed bin (35),
         fname_len fixed bin (21),
         fname_ptr ptr,
         i fixed bin,
         in_ename char (32),
         now char (24),
         out_len fixed bin (21),
         out_ptr ptr,
         select_all bit (1) aligned,
         selected_records_ptr ptr,
         status_info_ptr ptr,
         verbosity fixed bin;

						/* based */

declare 1 status_info based (status_info_ptr),
        2 print_switches,
	3 print_fdelim bit (1),
	3 print_fnames bit (1),
	3 print_rdelim bit (1),
	3 print_totals bit (1),
        2 af bit (1) aligned,
        2 total fixed bin,
        2 retlen fixed bin (21),
        2 retptr ptr,
        2 header bit (1) aligned,
        2 header_specified bit (1) aligned;

declare  fnames_out char (fname_len) based (fname_ptr),
         out_string char (out_len) based (out_ptr),
         ret_string char (retlen) varying based (retptr);

/* builtins */

declare (clock, fixed, hbound, null, pointer, substr) builtin;

/* conditions */

declare  cleanup condition;

/* entries */

declare  date_time_ entry (fixed bin (71), char (*)),
         get_temp_segment_ entry (char (*), ptr, fixed bin (35)),
        (ioa_, ioa_$rsnpnnl) entry () options (variable),
         release_temp_segment_ entry (char (*), ptr, fixed bin (35));

/* external static */

declare  sys_info$max_seg_size fixed bin (19) ext static;

						/* include files */
%include lister_entries;
%include lister_structures;


/* program */

	in_file_ptr = bv_in_file_ptr;
	in_ename = bv_in_ename;
	select_all = bv_select_all;
	status_info_ptr = bv_status_info_ptr;

	out_ptr = null ();
	fname_ptr = null ();

	on cleanup begin;
	     if out_ptr ^= null ()
	     then call release_temp_segment_ ("lister_status_", out_ptr, code);
	     if fname_ptr ^= null ()
	     then call release_temp_segment_ ("lister_status_", fname_ptr, code);
	end;

	call get_temp_segment_ ("lister_status_", out_ptr, code);

	field_table_ptr = input_file.field_table_offset;

	if af
	then verbosity = 0;
	else verbosity = fixed (print_fdelim) + fixed (print_rdelim) + fixed (print_totals) + fixed (print_fnames);

	if ^header_specified
	then if verbosity = 4
	     then header = "1"b;
	     else header = "0"b;

	if print_fnames
	then do;
	     call get_temp_segment_ ("lister_status_", fname_ptr, code);
	     fname_len = 0;
	     do i = 0 to hbound (field_table.index_to_field_id (*), 1);
		fidp = pointer (field_table.index_to_field_id (i), input_file.area);
		if i ^= 0 & verbosity > 1
		then do;
		     fname_len = fname_len + 1;
		     substr (fnames_out, fname_len, 1) = ",";
		end;
		if i ^= 0
		then do;
		     fname_len = fname_len + 1;
		     substr (fnames_out, fname_len, 1) = " ";
		end;
		fname_len = fname_len + field_identifier.size;
		substr (fnames_out, fname_len + 1 - field_identifier.size, field_identifier.size) = field_identifier.string;
	     end;
	end;

	if header
	then call date_time_ (clock (), now);

	out_len = sys_info$max_seg_size * 4;
	call ioa_$rsnpnnl (
	     "^[^21t^a^41t^a^2/^;^2s^]" ||		/* Header.     */
	     "^[^[Total ^[Selected ^]Records:^25t^;^s^]^i^[^/^;^x^]^;^4s^]" ||
	     "^[^[Record_delimiter:^25t^]^a^[^[;^]^/^;^x^s^]^;^4s^]" ||
	     "^[^[Field_delimiter:^25t^]^a^[^[;^]^/^;^x^s^]^;^4s^]" ||
	     "^[^[Field_names:^25t^]^a^[^[;^]^/^;^x^]^]",
	     out_string,
	     out_len,
	     (header = "1"b),			/* Only print header if all fields printed. */
	     in_ename,
	     now,
	     (print_totals = "1"b),
	     (verbosity > 1),
	     (select_all = "0"b),
	     total,
	     (af = "0"b),
	     (print_rdelim = "1"b),
	     (verbosity > 1),
	     field_table.record_delimiter,
	     (af = "0"b),
	     (verbosity > 1),
	     (print_fdelim = "1"b),
	     (verbosity > 1),
	     field_table.field_delimiter,
	     (af = "0"b),
	     (verbosity > 1),
	     (print_fnames = "1"b),
	     (verbosity > 1),
	     fnames_out,
	     (af = "0"b),
	     (verbosity > 1)
	     );

	if af
	then ret_string = out_string;
	else call ioa_ ("^a", out_string);

	call release_temp_segment_ ("lister_status_", out_ptr, code);
	if fname_ptr ^= null ()
	then call release_temp_segment_ ("lister_status_", fname_ptr, code);

     end;


		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved