


		    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 (