



		    format_pl1.pl1                  08/10/84  0951.5re  08/10/84  0946.6      166113



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

/* DESCRIPTION:

   Program to format a PL/I program according to my own set of conventions.
   Basically, if-then-else and do-end groups get lined up so that it is easy
   to find the matching else statement, or the end of a do-end group.

   This program has its origins in the Multics indent command, but unlike
   indent, we understand the syntax of PL/I fully, and don't get confused by
   strange constructs.  We also attempt to do more processing, since we have
   the knowledge.

   I have wanted to write this program for a long time.  I published my first
   ideas in my S.B.  thesis in 1973.  I wrote a draft of the parser in 1974.
   The notes I took for the lexical analyzer for format_pl1 turned into the
   EIS lex for PL/I itself in 1977.  So at long last...  (Paul Green)

   This command is being modified to be the Multics standard PL/I formatting
   command for MCR 3503.  Consequently, it must have options to make it act
   similar to indent as well as other formatting styles.  (Monte Davidoff)

   Maintenance Instructions:

   To add another:

   1) PL/I statement, see format_pl1_stmt_type_, format_pl1_.
   2) Formatting mode, see format_pl1_.
   3) Macro, see format_pl1_lex_, format_pl1_stmt_type_, format_pl1_.
   4) Declare statement attribute, see format_pl1_.
   5) Token type, see format_pl1_lex_, format_pl1_stmt_type_,
   format_pl1_.
   6) Numbered style, see format_pl1_.
*/

/* HISTORY:
   Written by Paul Green, 11/06/77.

   Modified:
   11/01/78 by Monte Davidoff:
   09/01/82 by Benson I. Margulies:  for .X.pmac files.
   06/05/84 by R. Michael Tague:  to recognize all legal pmac % statements.
*/

/* format: style5 */
format_pl1:
fp:
        procedure options (variable);

/* automatic */

        declare arg_count		fixed binary;
        declare arg_length		fixed binary (21);
        declare arg_ptr		pointer;
        declare argument_no		fixed binary;
        declare argx		fixed binary;
        declare bit_count		fixed binary (24);
        declare 1 ca,
	        2 check_comments	bit (1),
	        2 no_check_comments	bit (1),
	        2 check_strings	bit (1),
	        2 no_check_strings	bit (1),
	        2 force		bit (1),
	        2 no_force		bit (1),
	        2 long		bit (1),
	        2 brief		bit (1),
	        2 modes		bit (1),
	        2 output_file	bit (1),
	        2 record_style	bit (1),
	        2 no_record_style	bit (1),
	        2 require_style_comment
				bit (1),
	        2 no_require_style_comment
				bit (1),
	        2 version		bit (1),
	        2 no_version	bit (1);
        declare code		fixed binary (35);
        declare in_dname		char (168);
        declare in_ename		char (32);
        declare modes_length		fixed binary (21);
        declare modes_ptr		pointer;
        declare output_ptr		pointer;
        declare source_ptr		pointer;
        declare suffix		char (3);
        declare out_dname		char (168);
        declare out_ename		char (32);

/* based */

        declare arg_string		char (arg_length) based (arg_ptr);
        declare modes_string		char (modes_length) based (modes_ptr);

/* builtin */

        declare (baseno, divide, index, null, reverse, rtrim, size, string,
	      substr)		builtin;

/* condition */

        declare cleanup		condition;

/* internal static */

        declare DEFAULT_STYLE		fixed binary internal static
				options (constant) initial (1);
        declare VERSION		char (3) internal static
				options (constant) initial ("6.6");

/* external static */

        declare error_table_$badopt	fixed binary (35) external static;
        declare error_table_$noentry	fixed binary (35) external static;
        declare format_pl1_severity_	fixed binary (35) external static;

/* entry */

        declare com_err_		entry options (variable);
        declare com_err_$suppress_name	entry options (variable);
        declare cu_$arg_count		entry (fixed binary, fixed binary (35));
        declare cu_$arg_ptr		entry (fixed binary, pointer,
				fixed binary (21), fixed binary (35));
        declare expand_pathname_	entry (char (*), char (*), char (*),
				fixed binary (35));
        declare get_equal_name_	entry (char (*), char (*), char (32),
				fixed binary (35));
        declare get_temp_segments_	entry (char (*), (*) pointer,
				fixed binary (35));
        declare hcs_$initiate_count	entry (char (*), char (*), char (*),
				fixed binary (24), fixed binary (2),
				pointer, fixed binary (35));
        declare hcs_$make_seg		entry (char (*), char (*), char (*),
				fixed binary (5), pointer,
				fixed binary (35));
        declare ioa_		entry options (variable);
        declare release_temp_segments_	entry (char (*), (*) pointer,
				fixed binary (35));
        declare suffixed_name_$make	entry (char (*), char (*), char (32),
				fixed binary (35));
        declare suffixed_name_$new_suffix
				entry (char (*), char (*), char (*),
				char (32), fixed binary (35));
        declare terminate_file_	entry (pointer, fixed binary (24),
				bit (*), fixed binary (35));

%include format_pl1_dcls;
%include terminate_file;
%include access_mode_values;

/* program */

        source_ptr = null;
        output_ptr = null;
        temp_segs (*) = null;
        modes_ptr = null;
        modes_length = 0;
        format_pl1_severity_ = 5;

        string (ca) = ""b;
        ca.long = "1"b;

        call cu_$arg_count (arg_count, code);
        if code ^= 0 then
	      do;
	      call com_err_ (code, command);
	      return;
	      end;

        argument_no = 0;
        do argx = 1 to arg_count;
	      call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
	      if code ^= 0 then
		    do;
		    call com_err_ (code, command, "Argument ^d.", argx);
		    return;
		    end;

	      if arg_string = "-version" | arg_string = "-ver" then
		    do;
		    ca.version = "1"b;
		    ca.no_version = "0"b;
		    end;

	      else    if arg_string = "-no_version" | arg_string = "-nver"
		        then
		    do;
		    ca.version = "0"b;
		    ca.no_version = "1"b;
		    end;

	      else    if arg_string = "-record_style" | arg_string = "-rcst"
		        then
		    do;
		    ca.record_style = "1"b;
		    ca.no_record_style = "0"b;
		    end;

	      else    if arg_string = "-no_record_style"
		        | arg_string = "-nrcst" then
		    do;
		    ca.record_style = "0"b;
		    ca.no_record_style = "1"b;
		    end;

	      else    if arg_string = "-check_comments"
		        | arg_string = "-ckcom" then
		    do;
		    ca.check_comments = "1"b;
		    ca.no_check_comments = "0"b;
		    end;

	      else    if arg_string = "-no_check_comments"
		        | arg_string = "-nckcom" then
		    do;
		    ca.check_comments = "0"b;
		    ca.no_check_comments = "1"b;
		    end;

	      else    if arg_string = "-check_strings" | arg_string = "-ckstr"
		        then
		    do;
		    ca.check_strings = "1"b;
		    ca.no_check_strings = "0"b;
		    end;

	      else    if arg_string = "-no_check_strings"
		        | arg_string = "-nckstr" then
		    do;
		    ca.check_strings = "0"b;
		    ca.no_check_strings = "1"b;
		    end;

	      else    if arg_string = "-require_style_comment"
		        | arg_string = "-rqst" then
		    do;
		    ca.require_style_comment = "1"b;
		    ca.no_require_style_comment = "0"b;
		    end;

	      else    if arg_string = "-no_require_style_comment"
		        | arg_string = "-nrqst" then
		    do;
		    ca.require_style_comment = "0"b;
		    ca.no_require_style_comment = "1"b;
		    end;

	      else    if arg_string = "-force" | arg_string = "-fc" then
		    do;
		    ca.force = "1"b;
		    ca.no_force = "0"b;
		    end;

	      else    if arg_string = "-no_force" | arg_string = "-nfc" then
		    do;
		    ca.force = "0"b;
		    ca.no_force = "1"b;
		    end;

	      else    if arg_string = "-long" | arg_string = "-lg" then
		    do;
		    ca.long = "1"b;
		    ca.brief = "0"b;
		    end;

	      else    if arg_string = "-brief" | arg_string = "-bf" then
		    do;
		    ca.long = "0"b;
		    ca.brief = "1"b;
		    end;

	      else    if arg_string = "-modes" | arg_string = "-mode"
		        | arg_string = "-md" then
		    do;
		    argx = argx + 1;
		    if argx > arg_count then
			  do;
			  call com_err_ (0, command,
			      "Missing modes string after -modes.");
			  return;
			  end;

		    call cu_$arg_ptr (argx, modes_ptr, modes_length, code);
		    if code ^= 0 then
			  do;
			  call com_err_ (code, command, "Argument ^d.",
			      argx);
			  return;
			  end;

		    ca.modes = "1"b;
		    end;

	      else    if arg_string = "-output_file" | arg_string = "-of" then
		    do;
		    argx = argx + 1;
		    if argx > arg_count then
			  do;
			  call com_err_ (0, command,
			      "Missing pathname after -output_file.");
			  return;
			  end;

		    call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
		    if code ^= 0 then
			  do;
			  call com_err_ (code, command, "Argument ^d.",
			      argx);
			  return;
			  end;

		    call expand_pathname_ (arg_string, out_dname, out_ename,
		        code);
		    if code ^= 0 then
			  do;
			  call com_err_ (code, command, "^a", arg_string);
			  return;
			  end;

		    ca.output_file = "1"b;
		    end;

	      else    if index (arg_string, "-") = 1 then
		    do;
		    call com_err_ (error_table_$badopt, command, "^a",
		        arg_string);
		    return;
		    end;

	      else
		    do;
		    argument_no = argument_no + 1;

		    if argument_no = 1 then
			  do;
			  call expand_pathname_ (arg_string, in_dname,
			      in_ename, code);
			  if code ^= 0 then
				do;
				call com_err_ (code, command, "^a",
				    arg_string);
				return;
				end;
			  end;
		    end;
        end;

        if argument_no ^= 1 then
	      do;
	      call com_err_$suppress_name (0, command,
		"Usage: ^a in_path {-control_args}", command);
	      return;
	      end;

        on cleanup call cleanup_procedure;

        call get_input_segment (code);
        if code ^= 0 then
	      do;
	      call cleanup_procedure;
	      return;
	      end;

        if ca.output_file then
	      begin;
	      declare old_ename	        char (32);

	      old_ename = out_ename;
	      call get_equal_name_ (in_ename, old_ename, out_ename, code);
	      if code ^= 0 then
		    do;
		    call com_err_ (code, command, "Equal name ^a with ^a.",
		        old_ename, in_ename);
		    call cleanup_procedure;
		    return;
		    end;

	      old_ename = out_ename;
	      call suffixed_name_$make (old_ename, suffix, out_ename, code);
	      if code ^= 0 then
		    do;
		    call com_err_ (code, command, "^a with ^a suffix.",
		        old_ename, suffix);
		    call cleanup_procedure;
		    return;
		    end;
	      end;

        call get_temp_segments_ (command, temp_segs (*), code);
        if code ^= 0 then
	      do;
	      call com_err_ (code, command,
		"Getting temporary segments in process directory.");
	      call cleanup_procedure;
	      return;
	      end;

        global.source_ptr = source_ptr;
        global.source_length = divide (bit_count + 8, 9, 21);
        global.max_severity = 0;
        global.modes_ptr = modes_ptr;
        global.modes_length = modes_length;
        global.ca = ca, by name;
        global.include_file = ends_with (in_ename, ".incl.pl1");
        global.rdc_source = ends_with (in_ename, ".rd");

/* Initialize the current style. */

        global.current_style = styles (DEFAULT_STYLE);

        if ca.modes then
	      do;
	      call format_pl1_modes_ (temp_segs (*), modes_string, null, "0"b,
		"0"b);
	      if global.max_severity > 0 then
		    do;
		    format_pl1_severity_ = global.max_severity;
		    call cleanup_procedure;
		    return;
		    end;
	      end;

        else
	      global.ca.long = "0"b;

        global.command_line_style = global.current_style;

        if ca.force then
	      global.current_style = styles (DEFAULT_STYLE);

/* Initialization is complete.  Print version if requested. */

        if ca.version then
	      call ioa_ ("Format PL/I ^a", VERSION);

/* Lex the program. */

        call format_pl1_lex_ (temp_segs (*));
        if global.max_severity > 2 then
	      do;
	      format_pl1_severity_ = global.max_severity;
	      call com_err_ (0, command, "No formatting will be done.");
	      call cleanup_procedure;
	      return;
	      end;

/* Produce a list of statements. */

        call format_pl1_stmt_type_ (temp_segs (*));
        if global.max_severity > 3 then
	      do;
	      format_pl1_severity_ = global.max_severity;
	      call com_err_ (0, command, "No formatting will be done.");
	      call cleanup_procedure;
	      return;
	      end;

/* Do the formatting. */

        call format_pl1_ (temp_segs (*));
        if global.max_severity > 3 then
	      do;
	      format_pl1_severity_ = global.max_severity;
	      call com_err_ (0, command, "No formatting will be done.");
	      call cleanup_procedure;
	      return;
	      end;

/* Copy the formatted program over to the output segment. */

        if ^ca.output_file then
	      if global.max_severity <= 1 then
		    do;
		    out_dname = in_dname;
		    out_ename = in_ename;
		    output_ptr = source_ptr;
		    source_ptr = null;
		    end;

	      else
		    do;
		    out_dname = "[pd]";
		    out_ename = in_ename;

		    call hcs_$make_seg ("", out_ename, "", RW_ACCESS_BIN,
		        output_ptr, code);
		    if output_ptr = null then
			  do;
			  call com_err_ (code, command, "^a^[>^]^a",
			      out_dname, out_dname ^= ">", out_ename);
			  call cleanup_procedure;
			  return;
			  end;

		    if baseno (source_ptr) = baseno (output_ptr) then
			  do;
			  format_pl1_severity_ = global.max_severity;
			  call com_err_ (0, command,
			      "Input segment not replaced.");
			  call cleanup_procedure;
			  return;
			  end;

		    call com_err_ (0, command,
		        "Input segment not replaced. Formatted copy is in ^a^[>^]^a."
		        , out_dname, out_dname ^= ">", out_ename);
		    end;

        else
	      do;
	      call hcs_$make_seg (out_dname, out_ename, "", RW_ACCESS_BIN,
		output_ptr, code);
	      if output_ptr = null then
		    do;
		    call com_err_ (code, command, "^a^[>^]^a", out_dname,
		        out_dname ^= ">", out_ename);
		    call cleanup_procedure;
		    return;
		    end;
	      end;

        substr (output_ptr -> output_string, 1, global.output_length) =
	  substr (output_string, 1, global.output_length);

        call terminate_file_ (output_ptr, 9 * global.output_length,
	  TERM_FILE_TRUNC_BC_TERM, code);
        if code ^= 0 then
	      do;
	      global.max_severity = 5;
	      call com_err_ (code, command, "Terminating the file ^a^[>^]^a.",
		out_dname, out_dname ^= ">", out_ename);
	      end;

        format_pl1_severity_ = global.max_severity;

        call cleanup_procedure;

        return;

get_input_segment:
        procedure (code);

        declare code		fixed binary (35);
					      /* (Output) standard status code */

        declare explicit_suffix	bit (1) aligned;
        declare tentative_ename	char (32);
        declare test_ename		char (32);


/* NOTE: pmac suffices, like rd, must be explicit. */
/*       no attempt is made to remember pmac-ness so as to */
/*       reject %set etc. in non-pmac segments, since this will */
/*       be in the compiler some day. */

        code = 0;
        explicit_suffix = "1"b;

        if ends_with (in_ename, ".pmac") then
	      test_ename = before (in_ename, ".pmac");
        else
	      test_ename = in_ename;

        if ends_with (test_ename, ".pl1") then
	      suffix = "pl1";

        else    if ends_with (test_ename, ".cds") then
	      suffix = "cds";

        else    if ends_with (test_ename, ".rd") then
	      suffix = "rd";

        else
	      do;
	      explicit_suffix = "0"b;
	      suffix = "pl1";

	      tentative_ename = in_ename;
	      call suffixed_name_$make (tentative_ename, suffix, in_ename,
		code);
	      if code ^= 0 then
		    do;
		    call com_err_ (code, command, "^a with ^a suffix.",
		        tentative_ename, suffix);
		    return;
		    end;
	      end;

        call hcs_$initiate_count (in_dname, in_ename, "", bit_count, 0,
	  source_ptr, code);
        if source_ptr ^= null then
	      do;
	      code = 0;
	      return;
	      end;

        if explicit_suffix | code ^= error_table_$noentry then
	      do;
	      call com_err_ (code, command, "^a^[>^]^a", in_dname,
		in_dname ^= ">", in_ename);
	      return;
	      end;

        call suffixed_name_$new_suffix (in_ename, "pl1", "cds", tentative_ename,
	  code);
        if code ^= 0 then
	      do;
	      call com_err_ (code, command, "^a with ^a suffix.", in_ename,
		"cds");
	      return;
	      end;

        call hcs_$initiate_count (in_dname, tentative_ename, "", bit_count, 0,
	  source_ptr, code);
        if source_ptr ^= null then
	      do;
	      code = 0;
	      in_ename = tentative_ename;
	      suffix = "cds";
	      return;
	      end;

        if code = error_table_$noentry then
	      call com_err_ (code, command, "^a^[>^]^a", in_dname,
		in_dname ^= ">", in_ename);
        else
	      call com_err_ (code, command, "^a^[>^]^a", in_dname,
		in_dname ^= ">", tentative_ename);
        end get_input_segment;

/* Check if one string ends another with trailing blanks ignored. */

ends_with:
        procedure (string, ending) returns (bit (1) aligned);

        declare string		char (*);	      /* (Input) string with unknown ending */
        declare ending		char (*);	      /* (Input) possible ending */

        return (index (reverse (rtrim (string)), reverse (rtrim (ending))) = 1);
        end ends_with;

/* Release temporary storage and terminate segments. */

cleanup_procedure:
        procedure;

        call terminate_file_ (source_ptr, 0, TERM_FILE_TERM, code);
        call terminate_file_ (output_ptr, 0, TERM_FILE_TERM, code);
        call release_temp_segments_ (command, temp_segs (*), code);
        end cleanup_procedure;

        end format_pl1;




		    format_pl1_.pl1                 08/10/84  0951.5re  08/10/84  0947.3      802926



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

/* DESCRIPTION:
   Format a PL/I program given a list of tokens and statements.  For most
   statements, as much of the statement is put on a line as possible.  If a
   statement will not fit on one line, parenthesis nesting and the precedence
   of each token is used to determine where to break the statement across
   lines.  This default formatting is done by format_other.  Most of this
   program handles special cases that format_other would not format correctly.
   Some token types are changed by format_pl1_stmt_type_ because some tokens
   require different precedences in different contexts.  This procedure
   assumes the token type needs no further refinement.  The steps are:

   1) Convert a statement into items.  Items are tokens and comments.  The
   item structure has many fields that facilitate formatting.
   2) Figure out how to format the statement by modifying the item structure.
   3) Copy the items for a statement into the output string using the item
   structure control information.
   4) This procedure keeps track of the syntactic nesting of the program in
   the unit_stack.  The unit_stack is kept current after each statement by
   adjust_unit_stack.

   Maintenance Instructions:

   To add another token type:

   1) Add an entry to the precedence array.
   2) Add entries to the last_space_class and this_space_class arrays
   in make_items.  If necessary, add entries to the space_table
   array in make_items.

   To add another PL/I statement:

   1) If the statement needs special formatting, change
   format_one_statement.

   To add another macro:

   1) If the macro needs special formatting, change
   format_one_statement.

   To add another declare statement attribute:

   1) If the attribute consists of an identifier or an identifier
   followed by something in parentheses, and no special formatting
   is needed, no change is necessary.  Otherwise, change
   attribute_set.

   To add another formatting mode:

   1) Change the style stucture in format_pl1_dcls.incl.pl1 to include
   space for the new mode.
   2) Add a declaration that starts with "mode_" to
   format_pl1_dcls.incl.pl1 to reference the mode in the current
   style.  This declaration is used only by this procedure.
   3) For a switch mode, add entries to the switch_mode_names and
   switch_antonym_names arrays.  For a value mode, add an entry to
   the value_mode_names array.  These arrays are in
   format_pl1_dcls.incl.pl1.
   4) Add a default value for the new mode in each style in the styles
   array of structures in format_pl1_dcls.incl.pl1.
   5) Change this procedure to use the new "mode_" declaration.

   To add another numbered style:

   1) Add new entries to the styles array of structures in
   format_pl1_dcls.incl.pl1 that defines a default value for each
   mode in the new style.
*/

/* HISTORY:
Written by Paul Green, 11/01/77.
Rewritten by Monte Davidoff, 07/17/78.
Modified:
09/03/83 by Jim Lippard:  to not go into an infinite loop on
            "dcl a defined (b;".
06/05/84 by R. Michael Tague:  Handle the % macro statments of pmac.  Changed
            pop_unit so that a multiple closure error message will be printed
            when a labeled end statement is used to close a %if or %else
            statement instead of the proper closure with a %endif.
            Added the elsedo formatting option.
*/
 
/* format: style5 */

format_pl1_:
        procedure (P_temp_segs);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */

/* automatic */

        declare copy_position		fixed binary (21);
					      /* index in output segment of next character to write */
        declare item_ptr		pointer;	      /* pointer to base of item array */
        declare left_margin		fixed binary;   /* current indentation level column */
        declare line_position		fixed binary;   /* column next character will be written into */
        declare looked_ahead		bit (1) aligned;/* on if next statement will fit on the current line */
        declare off_region_ptr	pointer;	      /* pointer to first character not to format */
        declare text_after_end_msg	bit (1) aligned;/* on if printed text after end of program message */
        declare unit_stack_index	fixed binary;   /* number of entries in unit stack */
        declare unit_stack_ptr	pointer;	      /* pointer to base of unit_stack */

/* based */

        declare 1 item		(
				divide (sys_info$max_seg_size
				- binary (rel (item_ptr), 18), 5, 17))
				aligned based (item_ptr),
	        2 string_size	fixed binary (21) unaligned,
	        2 comment_ind_len	fixed binary (3) unsigned unaligned,
	        2 pad1		bit (2) unaligned,
	        2 type		fixed binary (8) unaligned,
	        2 string_ptr	pointer unaligned,
	        2 paren_depth	fixed binary (8) unaligned,
	        2 precedence	fixed binary (9) unsigned unaligned,
	        2 last_col		fixed binary (17) unaligned,
	        2 next_token	fixed binary (17) unaligned,
	        2 header		unaligned,
		3 tab		bit (1),
		3 need_space	fixed binary (1) unsigned,
		3 tab_blkcom	bit (1),
		3 insnl		bit (1),
		3 pad2		bit (5),
		3 amount		fixed binary (9) unsigned,
	        2 trailer		unaligned,
		3 NP		bit (1),
		3 pad3		bit (8),
		3 VTs		fixed binary (9) unsigned,
		3 NLs		fixed binary (9) unsigned,
	        2 flags		unaligned,
		3 control_comment	bit (1),
		3 gave_error_msg	bit (1),
		3 indcomtxt	bit (1),
		3 pad4		bit (6);

        declare 1 unit_stack		(
				divide (sys_info$max_seg_size
				- binary (rel (unit_stack_ptr), 18), 4,
				17)) aligned based (unit_stack_ptr),
	        2 type		fixed binary (17) unaligned,
	        2 label_start	fixed binary (17) unaligned,
	        2 label_end		fixed binary (17) unaligned,
	        2 close_left_margin	fixed binary (17) unaligned,
	        2 previous_left_margin
				fixed binary (17) unaligned,
	        2 flags		unaligned,
		3 case		bit (1),
		3 in_else_clause	bit (1),
		3 pad		bit (16),
	        2 construct_ptr	pointer unaligned;

/* builtin */

        declare (addr, after, before, binary, copy, divide, hbound, index,
	      length, ltrim, max, min, null, rel, reverse, rtrim, search,
	      size, substr, unspec, verify)
				builtin;

/* internal static */

        declare close_comment		char (2) internal static
				options (constant) initial ("*/");
        declare open_comment		char (2) internal static
				options (constant) initial ("/*");
        declare tab_interval		fixed binary (4) internal static
				options (constant) initial (10);

        declare (
	      NO_UNIT		initial (0),
	      BEGIN_UNIT		initial (1),
	      DO_UNIT		initial (2),
	      PROCEDURE_UNIT	initial (3),
	      IF_UNIT		initial (4),
	      ELSE_UNIT		initial (5),
	      ON_UNIT		initial (6),
	      PERCENT_IF_UNIT	initial (7)
	      )			fixed binary internal static
				options (constant);

        declare BS			char (1) internal static
				options (constant) initial ("");
        declare HT			char (1) internal static
				options (constant) initial ("	");
        declare HT_BS_NL_VT_NP	char (5) internal static
				options (constant) initial ("	
");
        declare HT_SP		char (2) internal static
				options (constant) initial ("	 ");

        declare precedence		(0:53) fixed binary (9)
				unsigned internal static
				options (constant) initial (15,
					      /* no_token */
				15,	      /* invalid_char */
				15,	      /* identifier */
				3,	      /* keyword_token */
				15,	      /* isub */
				10,	      /* infix + */
				10,	      /* infix - */
				11,	      /* * */
				11,	      /* / */
				12,	      /* ** */
				12,	      /* ^ */
				7,	      /* & */
				6,	      /* | */
				9,	      /* || */
				8,	      /* = */
				8,	      /* ^= */
				8,	      /* < */
				8,	      /* > */
				8,	      /* <= */
				8,	      /* >= */
				8,	      /* ^> */
				8,	      /* ^< */
				12,	      /* prefix + */
				12,	      /* prefix - */
				4,	      /* assignment */
				15,	      /* : */
				15,	      /* ; */
				2,	      /* , */
				14,	      /* . */
				13,	      /* -> */
				17,	      /* ( */
				1,	      /* ) */
				15,	      /* % */
				5,	      /* target , */
				16,	      /* comment */
				0,	      /* nl_vt_np_token */
				(18) 15);	      /* constants */

        declare HT_SP_NL_VT_NP	char (5) internal static
				options (constant) initial ("	 
");
        declare NL			char (1) internal static
				options (constant) initial ("
");
        declare NP			char (1) internal static
				options (constant) initial ("");
        declare SP			char (1) internal static
				options (constant) initial ("");
        declare VT			char (1) internal static
				options (constant) initial ("");

/* entry */

        declare ioa_		entry options (variable);

        declare char_offset_		entry (pointer)
				returns (fixed binary (21)) reducible;

/* more internal static */

        declare NL_VT_NP		char (3) internal static
				options (constant) initial ("
");
%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);
        global.output_length = 0;

        copy_position = 1;
        line_position = 1;
        looked_ahead = "0"b;
        text_after_end_msg = "0"b;

        unit_stack_ptr = addr (token (global.n_tokens + 2));
        unspec (unit_stack (1)) = ""b;
        unit_stack (1).type = NO_UNIT;
        unit_stack_index = 1;

        item_ptr = addr (stmt (global.n_stmts + 2));
        unspec (item (1)) = ""b;
        item (1).type = no_token;
        item (1).string_ptr = null;
        item (1).trailer.NLs = 1;

        begin;
	      declare n_items	        fixed binary;
	      declare prevailing_style_item   fixed binary;

	      left_margin = 1;
	      n_items = 1;
	      call make_items (1, 1, "1"b, "0"b, n_items);
	      call set_prevailing_style (n_items, prevailing_style_item);

	      if global.ca.long
		& unspec (global.prevailing_style)
		^= unspec (global.command_line_style) then
		    call format_pl1_long_ (temp_segs (*),
		        (item (prevailing_style_item).string_ptr));

	      n_items = 1;
	      call make_items (1, 1, "1"b, "1"b, n_items);

	      if prevailing_style_item <= n_items then
		    if global.ca.force then
			  call delete_and_record_new_prevailing_style_comment
			      (prevailing_style_item, n_items);
		    else
			  call copy_items (2, n_items);

	      else
		    do;
		    call copy_items (2, n_items);
		    call record_style;
		    end;
        end;

        begin;
	      declare last_stmt_type	        fixed binary (8);
	      declare stmtx		        fixed binary;

	      last_stmt_type = unknown_statement;
	      stmtx = 2;
	      do while (stmtx <= global.n_stmts);
		    call format_one_statement (stmtx, last_stmt_type);
	      end;
        end;

        if off_region_ptr ^= null then
	      call copy_off_region (global.source_length);

        do unit_stack_index = unit_stack_index to 2 by -1;
	      if (unit_stack (unit_stack_index).type = BEGIN_UNIT
		| unit_stack (unit_stack_index).type = DO_UNIT
		| unit_stack (unit_stack_index).type = PROCEDURE_UNIT)
		& (^global.rdc_source | unit_stack_index > 2) then
		    call error (3, "Missing end statement.",
		        unit_stack (unit_stack_index).construct_ptr);

	      else    if unit_stack (unit_stack_index).type = PERCENT_IF_UNIT
		        then
		    call error (3, "Missing %endif macro.",
		        unit_stack (unit_stack_index).construct_ptr);
        end;

unrecoverable_error:
        global.output_length = copy_position - 1;

        return;

/* Find the prevailing style comment and set the prevailing style. */

set_prevailing_style:
        procedure (n_items, prevailing_style_item);

        declare n_items		fixed binary;   /* (Input) index of last item before the first token */
        declare prevailing_style_item	fixed binary;   /* (Output) index of prevailing style comment,
					         or n_items + 1 if none */

        declare item_string		char (item (prevailing_style_item)
				.string_size)
				based (item (prevailing_style_item)
				.string_ptr);

        do prevailing_style_item = 2 to n_items
	  while (^item (prevailing_style_item).control_comment);
        end;

        if prevailing_style_item <= n_items then
	      call format_pl1_modes_ (temp_segs (*),
		before (after (item_string, control_comment_indicator),
		close_comment), addr (item_string), "0"b,
		item (prevailing_style_item).gave_error_msg);

        else    if global.ca.require_style_comment then
	      call error (2,
		"Program does not already contain a prevailing style control comment."
		, null);

        if global.ca.force then
	      begin;
	      declare 1 control_com_style     aligned like style;

	      declare command_line_modes      char (global.modes_length)
				        based (global.modes_ptr);

	      control_com_style = global.current_style;
	      call format_pl1_modes_ (temp_segs (*), command_line_modes, null,
		"0"b, "1"b);

	      if unspec (control_com_style) = unspec (global.current_style)
		then
		    global.ca.force = "0"b;
	      end;

        global.prevailing_style = global.current_style;
        left_margin = mode_initcol;

        if mode_on then
	      off_region_ptr = null;
        else
	      off_region_ptr = global.source_ptr;
        end set_prevailing_style;

/* Delete an existing prevailing style control comment and optionally record a new one. */

delete_and_record_new_prevailing_style_comment:
        procedure (prevailing_style_item, n_items);

        declare prevailing_style_item	fixed binary;   /* (Input) index of prevailing style comment */
        declare n_items		fixed binary;   /* (Input) index of last item before the first token */

        call copy_items (2, prevailing_style_item - 1);

        if off_region_ptr = null then
	      call record_style;

        else
	      do;
	      call copy_off_region (
		char_offset_ ((item (prevailing_style_item).string_ptr)));
	      call record_style;

	      if prevailing_style_item < n_items then
		    off_region_ptr =
		        item (prevailing_style_item + 1).string_ptr;

	      else    if global.n_tokens > 1 then
		    off_region_ptr = token (2).string_ptr;
	      end;

        call copy_items (prevailing_style_item + 1, n_items);
        end delete_and_record_new_prevailing_style_comment;

/* Record the prevailing style in the output segment. */

record_style:
        procedure;

        if ^global.ca.record_style then
	      return;

        if off_region_ptr = null then
	      call format_pl1_record_style_ (temp_segs (*), copy_position,
		line_position);

        else    if global.n_tokens <= 1 then
	      do;
	      call copy_off_region (global.source_length);
	      call format_pl1_record_style_ (temp_segs (*), copy_position,
		line_position);
	      end;

        else
	      do;
	      call copy_off_region (char_offset_ ((token (2).string_ptr)));
	      call format_pl1_record_style_ (temp_segs (*), copy_position,
		line_position);
	      off_region_ptr = token (2).string_ptr;
	      end;
        end record_style;

/* Format a statement. */

format_one_statement:
        procedure (stmtx, last_stmt_type);

        declare stmtx		fixed binary;   /* (Updated) statement to format */
        declare last_stmt_type	fixed binary (8);
					      /* (Updated) type of the last statement */

        declare n_items		fixed binary;
        declare label_start		fixed binary;
        declare label_end		fixed binary;
        declare last_stmt_item	fixed binary;
        declare stmt_type		fixed binary (8);

        if stmt (stmtx).type = condition_prefix_list then
	      do;
	      call format_prefix_list (stmtx);
	      if stmtx > global.n_stmts then
		    return;
	      end;

        if stmt (stmtx).type = label_prefix_list then
	      do;
	      label_start = stmt (stmtx).start;
	      label_end = stmt (stmtx).end;

	      call format_prefix_list (stmtx);
	      if stmtx > global.n_stmts then
		    return;
	      end;

        else
	      do;
	      label_start = 0;
	      label_end = 0;
	      end;

        stmt_type = stmt (stmtx).type;
        call convert_stmt_to_items (stmtx, 1, "0"b, n_items);

        if stmt_type = assignment_statement then
	      call format_assignment (n_items);

        else    if stmt_type = begin_statement then
	      call format_begin (n_items, last_stmt_type, label_start,
		label_end);

        else    if stmt_type = declare_statement then
	      call format_declare (n_items);

        else    if stmt_type = do_statement then
	      call format_do (n_items, last_stmt_type, label_start, label_end)
		;

        else    if stmt_type = end_statement then
	      call format_end (n_items);

        else    if stmt_type = if_statement then
	      call format_if (last_stmt_type, n_items);

        else    if stmt_type = else_clause then
	      call format_else (n_items);

        else    if stmt_type = on_statement then
	      call format_on (n_items);

        else    if stmt_type = procedure_statement then
	      call format_procedure (n_items, label_start, label_end);

        else    if stmt_type = entry_statement then
	      call format_entry (n_items);

        else    if stmt_type = percent_if_statement then
	      call format_percent_if_macros (n_items, "1"b, "1"b, "1"b);

        else    if stmt_type = percent_elseif_statement then
	      call format_percent_if_macros (n_items, "0"b, "1"b, "1"b);

        else    if stmt_type = percent_else_statement then
	      call format_percent_if_macros (n_items, "0"b, "1"b, "0"b);

        else    if stmt_type = percent_endif_statement then
	      call format_percent_if_macros (n_items, "0"b, "0"b, "0"b);

        else    if is_macro_statement (stmt_type) then
	      call format_other (2, n_items, 1, mode_lineconind, "1"b);

        else
	      call format_other (2, n_items, left_margin, mode_lineconind,
		"1"b);

        do last_stmt_item = n_items by -1
	  while (item (last_stmt_item).type = comment_token);
        end;

        call copy_items (2, last_stmt_item);

        if ^is_macro_whitespace (stmt_type) then
	      do;
	      call adjust_unit_stack (stmt_type, next_statement (stmtx));
	      last_stmt_type = stmt_type;
	      end;

        call copy_items (last_stmt_item + 1, n_items);

        stmtx = stmtx + 1;

        return;

format_prefix_list:
        procedure (stmtx);

        declare stmtx		fixed binary;   /* (Updated) prefix list to format */

        declare first_prefix_item	fixed binary;
        declare itemx		fixed binary;
        declare n_items		fixed binary;

        call convert_stmt_to_items (stmtx, 1, "0"b, n_items);

        do first_prefix_item = 2 repeat itemx + 1
	  while (first_prefix_item <= n_items);
	      item (first_prefix_item).header.need_space = 1;

	      do itemx = first_prefix_item to n_items
		while (item (itemx).type ^= colon);
	      end;

	      do itemx = itemx to n_items
		while (item (itemx + 1).type = comment_token);
		    call insert_tab (itemx + 1, mode_comcol);
	      end;

	      if stmt (stmtx).type = condition_prefix_list then
		    call format_other (first_prefix_item, itemx, 1, 0, "1"b)
		        ;
	      else
		    call format_other (first_prefix_item, itemx, 1,
		        mode_lineconind, "1"b);
        end;

        call copy_items (2, n_items);
        stmtx = stmtx + 1;
        end format_prefix_list;

/* Convert the tokens in a statement to items. */

convert_stmt_to_items:
        procedure (P_stmtx, initial_itemx, P_reconverting, P_itemx);

        declare P_stmtx		fixed binary;   /* (Input) statement to convert */
        declare initial_itemx		fixed binary;   /* (Input) last used item */
        declare P_reconverting	bit (1) aligned;/* (Input) on if stmt has already been converted in place */
        declare P_itemx		fixed binary;   /* (Output) last item that was converted */

        declare first_in_item_array	bit (1) aligned;
        declare itemx		fixed binary;
        declare reconverting		bit (1) aligned;
        declare stmtx		fixed binary;
        declare tokenx		fixed binary;

        stmtx = P_stmtx;
        itemx = initial_itemx;
        first_in_item_array = initial_itemx = 1;
        reconverting = P_reconverting;

        do tokenx = stmt (stmtx).start to stmt (stmtx).end;
	      call make_items (stmtx, tokenx, first_in_item_array,
		reconverting, itemx);
        end;

        P_itemx = itemx;

        item (initial_itemx + 1).header.need_space = 1;
        item (initial_itemx + 1).header.amount = 1;

        if itemx >= hbound (item, 1) then
	      call error (4, "Too many tokens and comments in a statement.",
		item (itemx).string_ptr);

        unspec (item (itemx + 1)) = ""b;
        item (itemx + 1).type = no_token;
        item (itemx + 1).string_ptr = token (stmt (stmtx).end + 1).string_ptr;

        if first_in_item_array & ^reconverting
	  & stmt (stmtx).type ^= unknown_statement
	  & (token (stmt (stmtx).end).type = semi_colon
	  | ^is_macro_statement (stmt (stmtx + 1).type)
	  | is_macro_whitespace (stmt (stmtx + 1).type)) then
	      if item (itemx).paren_depth > 1
		| item (itemx).paren_depth = 1
		& item (itemx).type ^= right_parn then
		    call error (2, "Missing right parenthesis.",
		        item (2).string_ptr);

	      else    if item (itemx).paren_depth < 0
		        | item (itemx).paren_depth = 0
		        & item (itemx).type = right_parn then
		    call error (2, "Missing left parenthesis.",
		        item (2).string_ptr);
        end convert_stmt_to_items;

/* Adjust the unit stack for the next statement. */

adjust_unit_stack:
        procedure (last_stmt_type, stmtx);

        declare last_stmt_type	fixed binary (8);
					      /* (Input) type of the last statement */
        declare stmtx		fixed binary;   /* (Input) index of the next statement */

        if unit_stack (unit_stack_index).type = ON_UNIT
	  & (last_stmt_type ^= on_statement
	  | stmt (stmtx).type = on_statement
	  | stmt (stmtx).type = if_statement) then
	      call pop_unit (0, left_margin, left_margin);

        if last_stmt_type ^= if_statement & last_stmt_type ^= else_clause then
	      if stmt (stmtx).type = else_clause then
		    begin;		      /* pop unit stack through matching then */
		    declare loop		      bit (1) aligned;

		    loop = "1"b;
		    do while (loop);
			  if unit_stack (unit_stack_index).type = IF_UNIT
			      then
				do;
				loop = "0"b;
				unit_stack (unit_stack_index).type =
				    ELSE_UNIT;
				left_margin =
				    unit_stack (unit_stack_index)
				    .close_left_margin;

				if (^unit_stack (unit_stack_index).case
				    |
				    ^unit_stack (unit_stack_index)
				    .in_else_clause
				    & stmt (next_statement (stmtx)).type
				    ^= if_statement) & mode_indthenelse
				    then
				        left_margin =
					  left_margin + mode_ind;
				end;

			  else	if unit_stack (unit_stack_index).type
				    = ELSE_UNIT then
				call pop_unit (0, 0, left_margin);

			  else
				do;
				loop = "0"b;
				call error (3,
				    "No if statement preceding else clause."
				    , token (stmt (stmtx).start)
				    .string_ptr);
				end;
		    end;
		    end;

	      else
		    do while (unit_stack (unit_stack_index).type = IF_UNIT
		        | unit_stack (unit_stack_index).type = ELSE_UNIT);
			  call pop_unit (0, 0, left_margin);
		    end;
        end adjust_unit_stack;

format_procedure:
        procedure (n_items, label_start, label_end);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */
        declare label_start		fixed binary;   /* (Input) first label token */
        declare label_end		fixed binary;   /* (Input) last label token */

        declare previous_left_margin	fixed binary;
        declare procedure_nest_depth	fixed binary;
        declare unitx		fixed binary;

        previous_left_margin = left_margin;

        procedure_nest_depth = 0;
        do unitx = unit_stack_index to 2 by -1;
	      if unit_stack (unit_stack_index).type = PROCEDURE_UNIT then
		    procedure_nest_depth = procedure_nest_depth + 1;
        end;

        if procedure_nest_depth < 2 | ^mode_indproc then
	      left_margin = mode_ind + 1;

        call format_other (2, n_items, left_margin, mode_lineconind, "1"b);

        call push_unit (PROCEDURE_UNIT, label_start, label_end, left_margin,
	  previous_left_margin);
        if mode_indprocbody then
	      left_margin = left_margin + mode_ind;
        end format_procedure;

format_assignment:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        if mode_equalind = 0 then
	      call format_other (2, n_items, left_margin, mode_lineconind,
		"1"b);
        else
	      begin;
	      declare assignment_item	        fixed binary;
	      do assignment_item = 2 to n_items
		while (item (assignment_item).type ^= assignment);
	      end;

	      call format_other (2, assignment_item - 1, left_margin,
		mode_lineconind, "0"b);
	      call format_other (assignment_item, n_items,
		left_margin + mode_equalind, mode_lineconind, "1"b);
	      end;
        end format_assignment;

format_begin:
        procedure (n_items, last_stmt_type, label_start, label_end);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */
        declare last_stmt_type	fixed binary (8);
					      /* (Input) type of the last nonwhitespace stmt */
        declare label_start		fixed binary;   /* (Input) first label token */
        declare label_end		fixed binary;   /* (Input) last label token */

        declare previous_left_margin	fixed binary;

        call format_other (2, n_items, left_margin, mode_lineconind, "1"b);

        previous_left_margin = left_margin;

        if last_stmt_type ^= if_statement & last_stmt_type ^= else_clause
	  & last_stmt_type ^= on_statement then
	      do;
	      if mode_indbegin then
		    do;
		    left_margin = left_margin + mode_ind;
		    call push_unit (BEGIN_UNIT, label_start, label_end,
		        indent_margin (mode_indbeginend, left_margin),
		        previous_left_margin);
		    end;
	      else
		    call push_unit (BEGIN_UNIT, label_start, label_end,
		        left_margin, previous_left_margin);
	      end;
        else
	      do;
	      if mode_indthenbegin then
		    left_margin = left_margin + mode_ind;
	      call push_unit (BEGIN_UNIT, label_start, label_end,
		indent_margin (mode_indthenbeginend, left_margin),
		previous_left_margin);
	      end;

        end format_begin;

format_do:
        procedure (n_items, last_stmt_type, label_start, label_end);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */
        declare last_stmt_type	fixed binary (8);
					      /* (Input) type of the last non whitespace stmt */
        declare label_start		fixed binary;   /* (Input) first label token */
        declare label_end		fixed binary;   /* (Input) last label token */

        declare indent_end		bit (1);
        declare previous_left_margin	fixed binary;

        call format_other (2, n_items, left_margin, mode_lineconind, "1"b);

        previous_left_margin = left_margin;

        if last_stmt_type = if_statement | last_stmt_type = else_clause
	  | last_stmt_type = on_statement then
	      if stmt (stmtx).subtype = subtype_noniterative_do then
		    do;
		    if mode_indnoniterdo then
			  left_margin = left_margin + mode_ind;

		    indent_end = mode_indnoniterend;
		    end;

	      else
		    do;
		    if mode_inditerdo then
			  left_margin = left_margin + mode_ind;

		    indent_end = mode_indend;
		    end;

        else
	      do;
	      left_margin = left_margin + mode_ind;
	      indent_end = mode_indend;
	      end;

        call push_unit (DO_UNIT, label_start, label_end,
	  indent_margin (indent_end, left_margin), previous_left_margin);
        end format_do;

format_entry:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        declare unitx		fixed binary;

        do unitx = unit_stack_index to 2 by -1
	  while (unit_stack (unitx).type ^= PROCEDURE_UNIT);
        end;

        if unit_stack (unitx).type = PROCEDURE_UNIT then
	      call format_other (2, n_items,
		(unit_stack (unitx).close_left_margin), mode_lineconind,
		"1"b);
        else
	      call format_other (2, n_items, mode_ind + 1, mode_lineconind,
		"1"b);
        end format_entry;

format_end:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        declare previous_left_margin	fixed binary;

        if unit_stack_index = 2 & stmtx < global.n_stmts & ^text_after_end_msg
	  then
	      do;
	      call error (3, "Text follows logical end of program.",
		token (stmt (stmtx + 1).start).string_ptr);
	      text_after_end_msg = "1"b;
	      end;

        if unit_stack_index > 1 then
	      if token (stmt (stmtx).start + 1).type = identifier then
		    call pop_unit (stmt (stmtx).start + 1, left_margin,
		        previous_left_margin);
	      else
		    call pop_unit (0, left_margin, previous_left_margin);

        else
	      do;
	      left_margin = 1;
	      previous_left_margin = mode_ind + 1;
	      call error (3, "End statement follows logical end of program.",
		item (2).string_ptr);
	      end;

        call format_other (2, n_items, left_margin, mode_lineconind, "1"b);

        left_margin = previous_left_margin;
        end format_end;

format_if:
        procedure (last_stmt_type, n_items);

        declare last_stmt_type	fixed binary (8);
					      /* (Input) type of the last statement */
        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        declare current_mode_case	bit (1) aligned;
        declare then_item		fixed binary;
        declare previous_left_margin	fixed binary;

        declare third_item_string	char (item (3).string_size)
				based (item (3).string_ptr);

        current_mode_case = mode_case;

        if last_stmt_type = if_statement | last_stmt_type = else_clause then
	      current_mode_case = unit_stack (unit_stack_index).case;

        if item (3).type = comment_token then
	      if third_item_string = case_control_comment then
		    current_mode_case = "1"b;

	      else    if third_item_string = tree_control_comment then
		    current_mode_case = "0"b;

        previous_left_margin = left_margin;

        if last_stmt_type = else_clause & current_mode_case then
	      left_margin = unit_stack (unit_stack_index).close_left_margin;

        call push_unit (IF_UNIT, 0, 0, left_margin, previous_left_margin);
        unit_stack (unit_stack_index).case = current_mode_case;
        unit_stack (unit_stack_index).in_else_clause =
	  last_stmt_type = else_clause;

        if mode_indthenelse then
	      left_margin = left_margin + mode_ind;

        do then_item = n_items by -1
	  while (item (then_item).type = comment_token);
        end;

        if is_ifthenstmt (stmtx, last_stmt_type, current_mode_case)
	  & mode_ifthenstmt then
	      begin;
	      declare last_item	        fixed binary;
	      declare may_be_ifthenstmt       bit (1) aligned;

	      call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item)
		;

	      may_be_ifthenstmt = "1"b;

	      if stmt (stmtx + 1).type = on_statement then
		    if may_be_one_line_on_unit (stmtx + 1) then
			  call convert_stmt_to_items (stmtx + 2,
			      (last_item), "0"b, last_item);
		    else
			  may_be_ifthenstmt = "0"b;

	      if may_be_ifthenstmt then
		    do;
		    call format_other (2, last_item, previous_left_margin,
		        mode_lineconind, "1"b);
		    call look_ahead_if_is_on_one_line (stmtx, 2, last_item,
		        looked_ahead);
		    end;
	      end;

        else    if stmt (stmtx + 1).subtype = subtype_noniterative_do
		& mode_ifthendo then
	      begin;
	      declare itemx		        fixed binary;
	      declare last_item	        fixed binary;
	      declare then_item_NLs	        fixed binary;

	      call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item)
		;
	      then_item_NLs = item (then_item).trailer.NLs;
	      call format_other (2, last_item, previous_left_margin,
		mode_lineconind, "1"b);

	      do itemx = last_item by -1
		while (item (itemx).type = comment_token);
	      end;

	      do itemx = itemx to then_item by -1
		while (^item (itemx).header.tab);
	      end;

	      if itemx < then_item & ^mode_thendo then
		    looked_ahead = "1"b;
	      else
		    do;
		    item (then_item).trailer.NLs = then_item_NLs;
		    call convert_stmt_to_items (stmtx + 1, n_items, "0"b,
		        last_item);
		    call format_other (then_item, last_item, left_margin,
		        mode_lineconind, "1"b);
		    call look_ahead_if_is_on_one_line (stmtx, then_item,
		        last_item, looked_ahead);
		    end;
	      end;

        if ^looked_ahead then
	      if mode_ifthen then
		    begin;
		    declare itemx		      fixed binary;

		    do itemx = then_item + 1 by 1
		        while (item (itemx).type = comment_token);
			  call insert_tab (itemx, mode_comcol);
		    end;

		    call format_other (2, n_items, previous_left_margin,
		        mode_lineconind, "0"b);

		    end;

	      else
		    begin;
		    declare itemx		      fixed binary;

		    do itemx = then_item - 1 by -1
		        while (item (itemx).type = comment_token);
			  call insert_tab (itemx, mode_comcol);
		    end;

		    call format_other (2, then_item - 1,
		        previous_left_margin, mode_lineconind, "1"b);
		    call format_other (then_item, n_items, left_margin,
		        mode_lineconind, "0"b);
		    end;

        if mode_ifthen then
	      left_margin = left_margin + mode_ind;
        else
	      left_margin =
		left_margin + clause_indentation (stmt (stmtx + 1).type);

        return;

is_ifthenstmt:
        procedure (stmtx, last_stmt_type, case) returns (bit (1) aligned);

        declare stmtx		fixed binary;   /* (Input) current if statement */
        declare last_stmt_type	fixed binary (8);
					      /* (Input) type of last statement */
        declare case		bit (1) aligned;/* (Input) current mode case */

        if ^is_independent_statement (stmt (stmtx + 1).type)
	  | stmt (stmtx + 1).type = if_statement then
	      return ("0"b);

        if stmt (stmtx + 2).type ^= else_clause then
	      return ("1"b);

        return (case
	  & (last_stmt_type = else_clause
	  | stmt (next_statement (stmtx + 2)).type = if_statement));
        end is_ifthenstmt;

        end format_if;

format_else:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        if stmt (stmtx + 1).subtype = subtype_noniterative_do & mode_ifthendo
	  then
	      begin;
	      declare last_item	        fixed binary;

	      call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item)
		;
	      call format_other (2, last_item, left_margin, mode_lineconind,
		"1"b);
	      call look_ahead_if_is_on_one_line (stmtx, 2, last_item,
		looked_ahead);
	      end;

        if ^looked_ahead then
	      if mode_elsestmt then
		    call format_other (2, n_items, left_margin,
		        mode_lineconind, "0"b);
	      else
		    do;
		    if stmt (stmtx + 1).type = if_statement
		        & unit_stack (unit_stack_index).case then
			  call format_other (2, n_items, left_margin,
			      mode_lineconind, "0"b);
		    else
			  call format_other (2, n_items, left_margin,
			      mode_lineconind, "1"b);
		    end;

        if mode_elsestmt then
	      left_margin =
		left_margin + clause_indentation (stmt (stmtx + 1).type);
        else
	      left_margin = left_margin + mode_ind;
        end format_else;

clause_indentation:
        procedure (clause_type) returns (fixed binary);

        declare clause_type		fixed binary (8) unaligned;
					      /* (Input) type of then clause or else clause */

/* length ("then") = length ("else") */

        if is_independent_statement (clause_type) then
	      return (max (length ("then") + 1, mode_ind));
        else
	      return (mode_ind);
        end clause_indentation;

next_statement:
        procedure (this_stmtx) returns (fixed binary);

        declare this_stmtx		fixed binary;   /* (Input) current statement */

        declare stmtx		fixed binary;

        do stmtx = this_stmtx + 1 by 1
	  while (stmt (stmtx).type = condition_prefix_list
	  | stmt (stmtx).type = label_prefix_list
	  | is_macro_whitespace (stmt (stmtx).type));
        end;

        return (stmtx);
        end next_statement;

format_on:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        if may_be_one_line_on_unit (stmtx) then
	      if ^looked_ahead then
		    begin;
		    declare last_item	      fixed binary;

		    call convert_stmt_to_items (stmtx + 1, n_items, "0"b,
		        last_item);
		    call format_other (2, last_item, left_margin,
		        mode_lineconind, "1"b);
		    call look_ahead_if_is_on_one_line (stmtx, 2, last_item,
		        looked_ahead);
		    end;

        if ^looked_ahead then
	      call format_other (2, n_items, left_margin, mode_lineconind,
		"1"b);

        call push_unit (ON_UNIT, 0, 0, left_margin, left_margin);
        left_margin = left_margin + mode_ind;
        end format_on;

may_be_one_line_on_unit:
        procedure (stmtx) returns (bit (1) aligned);

        declare stmtx		fixed binary;   /* (Input) on statement index */

        return (is_independent_statement (stmt (stmtx + 1).type)
	  & stmt (stmtx + 1).type ^= if_statement
	  & stmt (stmtx + 1).type ^= on_statement
	  & stmt (stmtx + 1).type ^= return_statement
	  & stmt (stmtx + 1).type ^= revert_statement);
        end may_be_one_line_on_unit;

look_ahead_if_is_on_one_line:
        procedure (stmtx, first_item, last_item, looked_ahead);

        declare stmtx		fixed binary;   /* (Input) current statement */
        declare first_item		fixed binary;   /* (Input) first item to check */
        declare last_item		fixed binary;   /* (Input) last item to check */
        declare looked_ahead		bit (1) aligned;/* (Output) on if next statement fits on the current line */

        declare itemx		fixed binary;
        declare last_stmt_item	fixed binary;

        do last_stmt_item = last_item by -1
	  while (item (last_stmt_item).type = comment_token);
        end;

        if item (last_stmt_item).type ^= semi_colon then
	      last_stmt_item = last_item + 1;

        do itemx = first_item to last_stmt_item - 1
	  while (item (itemx).trailer.NLs = 0);
        end;

        looked_ahead = itemx >= last_stmt_item;

        if ^looked_ahead then
	      call convert_stmt_to_items (stmtx, 1, "1"b, itemx);
        end look_ahead_if_is_on_one_line;

format_percent_if_macros:
        procedure (n_items, first_clause, start_clause, has_percent_then);

        declare n_items		fixed binary;   /* (Input) number of items in the macro */
        declare first_clause		bit (1) aligned;/* (Input) on to start new macro: %if */
        declare start_clause		bit (1) aligned;/* (Input) on to start new clause: %if, %elseif, %else */
        declare has_percent_then	bit (1) aligned;/* (Input) on if macro has %then: %if, %elseif */

        declare itemx		fixed binary;

        if ^first_clause then
	      if start_clause then
		    do;
		    do while (unit_stack (unit_stack_index).type
		        ^= PERCENT_IF_UNIT & unit_stack_index >= 2);
			  call pop_unit (0, 0, left_margin);
		    end;

		    if unit_stack (unit_stack_index).type = PERCENT_IF_UNIT
		        then
			  call pop_unit (0, left_margin, left_margin);
		    else
			  call error (3, "No preceding %if macro.",
			      item (2).string_ptr);
		    end;

	      else
		    begin;
		    declare unitx		      fixed binary;

		    do unitx = unit_stack_index to 2 by -1
		        while (unit_stack (unitx).type ^= PERCENT_IF_UNIT);
		    end;

		    if unit_stack (unitx).type = PERCENT_IF_UNIT then
			  do;
			  do unitx = unitx + 1 to unit_stack_index;
				unit_stack (unitx - 1) =
				    unit_stack (unitx);
			  end;

			  unit_stack_index = unit_stack_index - 1;
			  end;

		    else
			  call error (3,
			      "No %if macro preceding %endif macro.",
			      item (2).string_ptr);
		    end;

        if start_clause then
	      call push_unit (PERCENT_IF_UNIT, 0, 0, left_margin, left_margin)
		;

        do itemx = n_items by -1 while (item (itemx).type = comment_token);
	      call insert_tab (itemx, mode_comcol);
        end;

        call format_other (2, n_items, 1, mode_lineconind, "1"b);

        if has_percent_then & item (itemx).header.tab then
	      call insert_tab (itemx, 1);
        end format_percent_if_macros;

format_declare:
        procedure (n_items);

        declare n_items		fixed binary;   /* (Input) number of items in the statement */

        declare declare_margin	fixed binary;
        declare factored_level_number	bit (1) aligned;
        declare id_start_col		fixed binary;
        declare itemx		fixed binary;
        declare levels_ptr		pointer;
        declare levelx		fixed binary;
        declare tokenx		fixed binary;

        declare levels		(0:sys_info$max_seg_size
				- binary (rel (levels_ptr), 18) - 1)
				fixed binary based (levels_ptr);

        tokenx = n_items + 1;
        do itemx = tokenx to 2 by -1;
	      item (itemx).next_token = tokenx;

	      if item (itemx).type ^= comment_token then
		    tokenx = itemx;
        end;

        levels_ptr = addr (item (n_items + 2));
        levels (0) = -1;
        levelx = 0;

        factored_level_number = "0"b;
        itemx = 2;

        if mode_inddcls then
	      declare_margin = left_margin;
        else
	      declare_margin = 1;

        if item (itemx).string_size = length ("dcl") then
	      id_start_col = declare_margin + mode_dclind;
        else
	      id_start_col = declare_margin + mode_declareind;

        call insert_tab (itemx, declare_margin);

        itemx = item (itemx).next_token;
        call declaration_list;

        itemx = item (itemx).next_token;
        call insert_NL (itemx - 1, 0);

        return;

declaration_list:
        procedure;

        declare declare_stack_index	fixed binary;
        declare declare_stack_ptr	pointer;

        declare 1 declare_stack	(
				divide (sys_info$max_seg_size
				- binary (rel (declare_stack_ptr), 18),
				2, 17)) aligned
				based (declare_stack_ptr),
	        2 state		fixed binary (17) unaligned,
	        2 flags		unaligned,
		3 has_level_number	bit (1),
		3 pad		bit (17),
	        2 component_start	fixed binary (17);

        declare item_string		char (item (itemx).string_size)
				based (item (itemx).string_ptr);

        declare (
	      START_COMPONENT	initial (0),
	      WANT_RIGHT_PAREN	initial (1),
	      WANT_ATTRIBUTE_SET	initial (2)
	      )			fixed binary internal static
				options (constant);

        declare_stack_ptr = addr (unit_stack (unit_stack_index + 1));
        declare_stack_index = 0;

        call push_declare_stack_entry (declare_stack_index);
        do while (declare_stack_index > 0);
	      if declare_stack (declare_stack_index).state = START_COMPONENT
		then
		    do;
		    declare_stack (declare_stack_index).state =
		        WANT_ATTRIBUTE_SET;
		    declare_stack (declare_stack_index).has_level_number =
		        "0"b;
		    declare_stack (declare_stack_index).component_start =
		        itemx;

		    if item (itemx).type = dec_integer then
			  begin;
			  declare level		    fixed binary;

			  level = binary (item_string, 17);

			  do levelx = levelx to 1 by -1
			      while (levels (levelx) >= level);
			  end;

			  if levelx >= hbound (levels, 1) then
				call error (4, "Too many levels.",
				    item (itemx).string_ptr);

			  levelx = levelx + 1;
			  levels (levelx) = level;
			  declare_stack (declare_stack_index)
			      .has_level_number = "1"b;

			  if factored_level_number then
				call error (3,
				    "Level number within the scope of a factored level number."
				    , item (itemx).string_ptr);

			  itemx = item (itemx).next_token;
			  end;

		    else	  if ^factored_level_number
			      & item (itemx).type ^= left_parn then
			  levelx = 0;

		    call insert_tab (declare_stack (declare_stack_index)
		        .component_start, structure_id_start_col (levelx));

		    if item (itemx).type = identifier then
			  itemx = item (itemx).next_token;

		    else	  if item (itemx).type = left_parn then
			  begin;
			  declare ix		    fixed binary;

			  factored_level_number =
			      declare_stack (declare_stack_index)
			      .has_level_number;

			  call completely_factored_declaration_list (
			      itemx, ix);
			  if ix > 0 then
				itemx = ix;
			  else
				do;
				itemx = item (itemx).next_token;
				declare_stack (declare_stack_index)
				    .state = WANT_RIGHT_PAREN;
				call push_declare_stack_entry (
				    declare_stack_index);
				end;
			  end;

		    else	  if stmt (stmtx + 1).type ^= percent_statement
			      then
			  call error (3,
			      "Syntax error in declaration component.",
			      item (itemx).string_ptr);
		    end;

	      else    if declare_stack (declare_stack_index).state
		        = WANT_RIGHT_PAREN then
		    do;
		    declare_stack (declare_stack_index).state =
		        WANT_ATTRIBUTE_SET;

		    if item (itemx).type = right_parn then
			  begin;
			  declare ix		    fixed binary;

			  do ix = itemx - 1 by -1
			      while (item (ix).type = comment_token);
				call insert_tab (ix, mode_comcol);
			  end;

			  call insert_NL (itemx - 1,
			      structure_id_start_col (levelx));
			  itemx = item (itemx).next_token;
			  end;

		    else	  if stmt (stmtx + 1).type ^= percent_statement
			      then
			  call error (3,
			      "Missing right parenthesis after declaration list."
			      , item (itemx).string_ptr);

		    if declare_stack (declare_stack_index).has_level_number
		        then
			  factored_level_number = "0"b;
		    end;

	      else
		    do;			      /* WANT_ATTRIBUTE_SET */
		    call attribute_set (id_start_col + mode_idind, itemx);

		    if mode_indattr then
			  if declare_stack (declare_stack_index)
			      .has_level_number then
				call tab_continuation_lines (
				    declare_stack (declare_stack_index)
				    .component_start + 1, itemx,
				    structure_id_start_col (levelx)
				    + mode_ind);
			  else
				call tab_continuation_lines (
				    declare_stack (declare_stack_index)
				    .component_start + 1, itemx,
				    structure_id_start_col (levelx));

		    else	  if item (itemx).type = comma
			      | item (itemx).type = semi_colon then
			  call format_other (
			      declare_stack (declare_stack_index)
			      .component_start, itemx,
			      structure_id_start_col (levelx),
			      mode_lineconind, "0"b);
		    else
			  call format_other (
			      declare_stack (declare_stack_index)
			      .component_start, itemx - 1,
			      structure_id_start_col (levelx),
			      mode_lineconind, "0"b);

		    if item (itemx).type = comma then
			  do;
			  itemx = item (itemx).next_token;
			  call insert_NL (itemx - 1, 0);
			  declare_stack (declare_stack_index).state =
			      START_COMPONENT;
			  end;

		    else
			  declare_stack_index = declare_stack_index - 1;
		    end;
        end;

        return;

push_declare_stack_entry:
        procedure (declare_stack_index);

        declare declare_stack_index	fixed binary;   /* (Updated) top of the declare_stack */

        if declare_stack_index >= hbound (declare_stack, 1) then
	      call error (4, "Declaration lists nested too deep.",
		item (itemx).string_ptr);

        declare_stack_index = declare_stack_index + 1;
        unspec (declare_stack (declare_stack_index)) = ""b;
        declare_stack (declare_stack_index).state = START_COMPONENT;
        end push_declare_stack_entry;

/* Format a declaration list if it has all the attributes factored, doesn't
   contain any comments, and the identifiers don't contain dollar signs. */

completely_factored_declaration_list:
        procedure (first_item, last_item);

        declare first_item		fixed binary;   /* (Input) left paren preceding declaration list */
        declare last_item		fixed binary;   /* (Output) item after right paren of declaration component,
					         or 0 if not a completely factored declaration list */

        declare itemx		fixed binary;

        declare item_string		char (item (itemx).string_size)
				based (item (itemx).string_ptr);

        last_item = 0;
        itemx = first_item + 1;

        if item (itemx).type ^= identifier then
	      return;

        do itemx = itemx + 1 repeat itemx + 1 while (item (itemx).type = comma);
	      itemx = itemx + 1;

	      if item (itemx).type ^= identifier then
		    return;

	      if index (item_string, "$") > 0 then
		    return;
        end;

        if item (itemx).type ^= right_parn then
	      return;

        if ^factored_level_number then
	      levelx = 0;

        if declare_stack (declare_stack_index).has_level_number then
	      call format_other (declare_stack (declare_stack_index)
		.component_start, itemx, structure_id_start_col (levelx),
		mode_lineconind, "0"b);
        else
	      call format_other (declare_stack (declare_stack_index)
		.component_start, itemx, structure_id_start_col (levelx), 0,
		"0"b);

        if declare_stack (declare_stack_index).has_level_number then
	      factored_level_number = "0"b;

        last_item = itemx + 1;
        end completely_factored_declaration_list;

attribute_set:
        procedure (start_col, itemx);

        declare start_col		fixed binary;   /* (Input) column the attributes start in */
        declare itemx		fixed binary;   /* (Updated) current item */

        declare first_item		fixed binary;
        declare initial_paren_depth	fixed binary;

        declare item_string		char (item (itemx).string_size)
				based (item (itemx).string_ptr);

        first_item = itemx;
        do while (item (itemx).type ^= comma & item (itemx).type ^= semi_colon
	  & item (itemx).type ^= right_parn & item (itemx).type ^= no_token);
	      if item (itemx).type = identifier then
		    do;
		    item (itemx).type = keyword_token;
		    item (itemx).precedence = precedence (keyword_token);

/*		     if item_string = "entry"
   then call entry_attribute;
   else if item_string = "returns"
   then call returns_attribute;
   else if item_string = "generic"
   then call generic_attribute;
   else */

		    if item_string = "like" then
			  do;
			  itemx = item (itemx).next_token;

			  if item (itemx).type = identifier then
				do;
				itemx = item (itemx).next_token;
				do while (item (itemx).type = period);
				        itemx = item (itemx).next_token;

				        if item (itemx).type
					  = identifier then
					      itemx =
						item (itemx)
						.next_token;
				end;
				end;
			  end;

		    else	  if item_string = "defined" | item_string = "def"
			      then
			  do;
			  initial_paren_depth = item (itemx).paren_depth;
			  do itemx = item (itemx).next_token
			      repeat item (itemx).next_token
			      while (item (itemx).paren_depth
			      > initial_paren_depth & itemx < n_items
			      | item (itemx).type ^= comma
			      & item (itemx).type ^= semi_colon
			      & item (itemx).type ^= right_parn
			      & (item (itemx).type ^= identifier
			      |
			      ^
			      could_end_a_reference (item (itemx - 1)
			      .type)));
			  end;
			  end;

		    else
			  itemx = item (itemx).next_token;
		    end;

	      else    if item (itemx).type = left_parn then
		    do;
		    initial_paren_depth = item (itemx).paren_depth;
		    do itemx = item (itemx).next_token
		        repeat item (itemx).next_token
		        while (item (itemx).paren_depth
		        >= initial_paren_depth);
		    end;
		    end;

	      else
		    itemx = item (itemx).next_token;
        end;

        if first_item < itemx & mode_indattr then
	      if item (itemx).type = comma | item (itemx).type = semi_colon
		then
		    call format_other (first_item, itemx, start_col, 0,
		        "0"b);
	      else
		    call format_other (first_item, itemx - 1, start_col, 0,
		        "0"b);

        return;

could_end_a_reference:
        procedure (type) returns (bit (1) aligned);

        declare type		fixed binary (8) unaligned;
					      /* (Input) token type which might end a reference */

        return (type = identifier | type = isub | type = right_parn
	  | min_constant_token <= type & type <= max_constant_token);
        end could_end_a_reference;

        end attribute_set;

structure_id_start_col:
        procedure (level) returns (fixed binary);

        declare level		fixed binary;   /* (Input) current normalized structure level */

        return (id_start_col + mode_struclvlind * max (0, level - 1));
        end structure_id_start_col;

        end declaration_list;

        end format_declare;

/* Format items using the precedence rules. */

format_other:
        procedure (first_item, last_item, start_col, continuation_indent,
	  insert_final_NL_sw);

        declare first_item		fixed binary;   /* (Input) first item to format */
        declare last_item		fixed binary;   /* (Input) last item to format */
        declare start_col		fixed binary;   /* (Input) left margin for this statement fragment */
        declare continuation_indent	fixed binary;   /* (Input) number of columns to indent continuation lines */
        declare insert_final_NL_sw	bit (1) aligned;/* (Input) on to insert a NL after last_item */

        declare first_on_line		fixed binary;
        declare ix			fixed binary;
        declare last_line_pos		fixed binary;

        declare ix_item_string	char (item (ix).string_size)
				based (item (ix).string_ptr);
        declare last_ix_item_string	char (item (ix - 1).string_size)
				based (item (ix - 1).string_ptr);

        if looked_ahead then
	      do;
	      looked_ahead = "0"b;
	      return;
	      end;

        call insert_tab (first_item, start_col);
        call tab_continuation_lines (first_item + 1, last_item,
	  start_col + continuation_indent);

        if ^mode_insnl then
	      return;

        first_on_line = first_item;
        do while (first_on_line <= last_item);
	      do ix = first_on_line to last_item
		while (item (ix - 1).last_col <= mode_ll
		| ix = first_on_line);
		    if item (ix).header.tab then
			  do;
			  first_on_line = ix;
			  last_line_pos = -1;
			  end;

		    else	  if item (ix - 1).type = char_string
			      | item (ix - 1).type = comment_token then
			  if search (last_ix_item_string, NL_VT_NP) = 0
			      then
				last_line_pos = item (ix - 1).last_col;
			  else
				last_line_pos =
				    last_line_position (1,
				    last_ix_item_string);

		    else
			  last_line_pos = item (ix - 1).last_col;

		    if item (ix).type = char_string
		        | item (ix).type = comment_token then
			  item (ix).last_col =
			      next_line_position (last_line_pos
			      + item (ix).header.amount + 1,
			      ix_item_string) - 1;
		    else
			  item (ix).last_col =
			      last_line_pos + item (ix).header.amount
			      + item (ix).string_size;
	      end;

	      if item (ix - 1).last_col <= mode_ll then
		    first_on_line = ix;
	      else
		    begin;
		    declare last_on_line	      fixed binary;
		    declare low_paren_depth	      fixed binary;
		    declare low_precedence	      fixed binary;

		    last_on_line = ix - 1;
		    do first_on_line = first_on_line to last_on_line
		        while (item (first_on_line).last_col
		        < start_col + continuation_indent);
		    end;

		    if item_should_end_line (item (last_on_line).type) then
			  do;
			  low_paren_depth = 1f5;
			  low_precedence = 1f5;
			  end;

		    else
			  do;
			  low_paren_depth =
			      item (last_on_line).paren_depth;
			  low_precedence = item (last_on_line).precedence;
			  end;

		    do ix = first_on_line + 1 to last_on_line - 1;
			  if item (ix).paren_depth < low_paren_depth
			      | item (ix).paren_depth = low_paren_depth
			      & item (ix).precedence <= low_precedence
			      then
				do;
				last_on_line = ix;
				low_paren_depth = item (ix).paren_depth;
				low_precedence = item (ix).precedence;
				end;
		    end;

		    if ^item_should_end_line (item (last_on_line).type)
		        & first_on_line < last_on_line then
			  last_on_line = last_on_line - 1;

		    call insert_NL (last_on_line,
		        start_col + continuation_indent);
		    first_on_line = last_on_line + 1;
		    end;
        end;

        if insert_final_NL_sw then
	      call insert_NL (last_item, 0);

        return;

item_should_end_line:
        procedure (type) returns (bit (1) aligned);

        declare type		fixed binary (8) unaligned;
					      /* (Input) token type */

        return (type = comma | type = target_comma | type = right_parn
	  | type = assignment);
        end item_should_end_line;

        end format_other;

push_unit:
        procedure (unit_type, label_start, label_end, close_left_margin,
	  previous_left_margin);

        declare unit_type		fixed binary;   /* (Input) type of unit to push */
        declare label_start		fixed binary;   /* (Input) first token in the statement's label prefixes */
        declare label_end		fixed binary;   /* (Input) last token in the statement's label prefixes */
        declare close_left_margin	fixed binary;   /* (Input) left margin for corresponding 'end' statement */
        declare previous_left_margin	fixed binary;   /* (Input) left margin for next statement */

        if unit_stack_index >= hbound (unit_stack, 1) then
	      call error (4, "Blocks nested too deep.",
		token (stmt (stmtx).start).string_ptr);

        unit_stack_index = unit_stack_index + 1;
        unspec (unit_stack (unit_stack_index)) = ""b;
        unit_stack (unit_stack_index).type = unit_type;
        unit_stack (unit_stack_index).label_start = label_start;
        unit_stack (unit_stack_index).label_end = label_end;
        unit_stack (unit_stack_index).close_left_margin = close_left_margin;
        unit_stack (unit_stack_index).previous_left_margin =
	  previous_left_margin;
        unit_stack (unit_stack_index).construct_ptr =
	  token (stmt (stmtx).start).string_ptr;
        end push_unit;

pop_unit:
        procedure (label_token, close_left_margin, previous_left_margin);

        declare label_token		fixed binary;   /* (Input) end statement label token, 0 if none */
        declare close_left_margin	fixed binary;   /* (Output) left margin for end statement */
        declare previous_left_margin	fixed binary;   /* (Output) left margin for the next statement */

        declare matched		bit (1) aligned;
        declare multiple_closure_msg	bit (1) aligned;
        declare tx			fixed binary;

        declare label_string		char (token (label_token).string_size)
				based (token (label_token).string_ptr);
        declare tx_token_string	char (token (tx).string_size)
				based (token (tx).string_ptr);

        multiple_closure_msg = "0"b;
        matched = label_token = 0;
        do while (^matched & unit_stack_index >= 2);
	      if unit_stack (unit_stack_index).label_start > 0 then
		    do tx = unit_stack (unit_stack_index).label_start
		        to unit_stack (unit_stack_index).label_end
		        while (^matched);
			  if token (tx).type = identifier
			      & token (tx + 1).type = colon then
				matched =
				    label_string = tx_token_string;
		    end;

	      if ^matched then
		    do;
		    if unit_stack (unit_stack_index).type = BEGIN_UNIT
		        | unit_stack (unit_stack_index).type = DO_UNIT
		        | unit_stack (unit_stack_index).type
		        = PROCEDURE_UNIT
		        | unit_stack (unit_stack_index).type
		        = PERCENT_IF_UNIT then
			  do;
			  if ^multiple_closure_msg then
				do;
				call error (1,
				    "Labeled end statement terminates more than one block or group."
				    , token (label_token).string_ptr);
				multiple_closure_msg = "1"b;
				end;

			  call error (1,
			      "Block or group terminated by labeled end statement."
			      , unit_stack (unit_stack_index)
			      .construct_ptr);
			  end;

		    unit_stack_index = unit_stack_index - 1;
		    end;
        end;

        if matched then
	      do;
	      close_left_margin =
		unit_stack (unit_stack_index).close_left_margin;
	      previous_left_margin =
		unit_stack (unit_stack_index).previous_left_margin;
	      unit_stack_index = unit_stack_index - 1;
	      end;

        else
	      do;
	      close_left_margin = 1;
	      previous_left_margin = 1;
	      call error (3, "No match for labeled end statement.",
		token (label_token).string_ptr);
	      end;
        end pop_unit;

/* Ensure starting columns for continuation lines are specified. */

tab_continuation_lines:
        procedure (first_item, last_item, continuation_col);

        declare first_item		fixed binary;   /* (Input) first item to check */
        declare last_item		fixed binary;   /* (Input) last item to check */
        declare continuation_col	fixed binary;   /* (Input) default continuation line starting column */

        declare itemx		fixed binary;

        do itemx = first_item to last_item;
	      if item (itemx - 1).trailer.NLs > 0 & ^item (itemx).header.tab
		then
		    call insert_tab (itemx, continuation_col);
        end;
        end tab_continuation_lines;

/* Insert a NL in the statement. */

insert_NL:
        procedure (itemx, start_col);

        declare itemx		fixed binary;   /* (Input) index of last item on the line */
        declare start_col		fixed binary;   /* (Input) starting column of first item on the next line,
					         0 if none */

        if item (itemx).trailer.NLs = 0 & mode_insnl then
	      item (itemx).trailer.NLs = 1;

        if start_col > 0 then
	      call insert_tab (itemx + 1, start_col);
        end insert_NL;

/* Insert a tab to a particular column in the statement. */

insert_tab:
        procedure (itemx, start_col);

        declare itemx		fixed binary;   /* (Input) index of item to be moved over */
        declare start_col		fixed binary;   /* (Input) new starting column */

        if item (itemx).type = comment_token & item (itemx).header.tab then
	      return;

        item (itemx).header.tab = "1"b;
        item (itemx).header.amount = start_col;
        end insert_tab;

        end format_one_statement;

/* Convert a token and its trailers to items.

   Puts white space between two items if necessary.
*/
make_items:
        procedure (stmtx, tokenx, scan_control_comments, keep_gave_error_msg,
	  itemx);

        declare stmtx		fixed binary;   /* (Input) statement that the token is in */
        declare tokenx		fixed binary;   /* (Input) token to convert */
        declare scan_control_comments	bit (1) aligned;/* (Input) on to look for control comments */
        declare keep_gave_error_msg	bit (1) aligned;/* (Input) on to keep old value of item.gave_error_msg
					         in trailer items */
        declare itemx		fixed binary;   /* (Updated) last item */

        declare is_after_statement	bit (1) aligned;
        declare last_trailer_type	fixed binary (8);
        declare last_type		fixed binary (8);
        declare loop		bit (1) aligned;
        declare next_comment_in_col_1	bit (1) aligned;
        declare 1 style_before_trailers aligned like style;
        declare this_type		fixed binary (8);
        declare trailerx		fixed binary;

        declare trailer_string	char (trailer (trailerx).string_size)
				based (trailer (trailerx).string_ptr);

        declare last_space_class	(0:53) fixed binary (3) internal
				static options (constant)
				initial ((10) 1, 2,
					      /* ^ */
				(11) 1, 2,      /* prefix + */
				2,	      /* prefix - */
				1,	      /* assignment */
				2,	      /* : */
				1,	      /* ; */
				1,	      /* , */
				2,	      /* . */
				1,	      /* -> */
				3,	      /* ( */
				4,	      /* ) */
				2,	      /* % */
				1,	      /* target , */
				5,	      /* comment */
				(19) (1));

        declare this_space_class	(0:53) fixed binary (3) internal
				static options (constant)
				initial ((25) 1, 4,
					      /* : */
				2,	      /* ; */
				2,	      /* , */
				4,	      /* . */
				1,	      /* -> */
				1,	      /* ( */
				2,	      /* ) */
				4,	      /* % */
				2,	      /* target , */
				5,	      /* comment */
				1,	      /* nl_vt_np_token */
				3,	      /* bit_string */
				3,	      /* char_string */
				(16) (1));

        declare space_table		(5, 5) fixed binary (1)
				unsigned internal static
				options (constant)
				initial (1, 0, 1, 0, 1,
					      /* last space class 1 */
				0, 0, 0, 0, 1,  /* last space class 2 */
				0, 0, 0, 0, 0,  /* last space class 3 */
				1, 0, 0, 0, 1,  /* last space class 4 */
				1, 0, 1, 1, 1); /* last space class 5 */

        this_type = token (tokenx).type;
        last_type = item (itemx).type;

        if itemx >= hbound (item, 1) then
	      call error (4, "Too many tokens and comments in a statement.",
		token (tokenx).string_ptr);

        itemx = itemx + 1;
        unspec (item (itemx)) = ""b;
        item (itemx).type = this_type;
        item (itemx).string_ptr = token (tokenx).string_ptr;
        item (itemx).string_size = token (tokenx).string_size;

        if last_type = right_parn then
	      item (itemx).paren_depth = item (itemx - 1).paren_depth - 1;
        else
	      item (itemx).paren_depth = item (itemx - 1).paren_depth;

        if this_type = left_parn then
	      item (itemx).paren_depth = item (itemx).paren_depth + 1;

        item (itemx).precedence = precedence (this_type);

        if item (itemx - 1).trailer.NLs = 0 then
	      item (itemx).header.amount, item (itemx).header.need_space =
		space_table (last_space_class (last_type),
		this_space_class (this_type));

        if token (tokenx).trailer_index = 0 then
	      return;

        style_before_trailers = global.current_style;

        is_after_statement =
	  this_type = no_token | this_type = semi_colon
	  | is_macro_statement (stmt (stmtx).type)
	  & tokenx = stmt (stmtx).end;
        next_comment_in_col_1 =
	  this_type = no_token
	  | this_type = semi_colon & is_macro_statement (stmt (stmtx).type);
        last_trailer_type = no_token;

        loop = "1"b;
        do trailerx = token (tokenx).trailer_index by 1 while (loop);
	      if trailer (trailerx).type = nl_vt_np_token then
		    if is_after_statement | ^mode_delnl then
			  begin;
			  declare i		    fixed
						    binary (21);

			  next_comment_in_col_1 =
			      trailer_string ^= NL
			      | last_trailer_type = nl_vt_np_token
			      | next_comment_in_col_1;
			  do i = 1 to length (trailer_string);
				if substr (trailer_string, i, 1) = NL
				    then
				        item (itemx).trailer.NLs =
					  item (itemx).trailer.NLs
					  + 1;

				else    if substr (trailer_string, i, 1)
					  = VT then
				        do;
				        item (itemx).trailer.VTs =
					  item (itemx).trailer.VTs
					  + 1;
				        item (itemx).trailer.NLs = 0;
				        end;

				else
				        do;     /* NP */
				        item (itemx).trailer.NP = "1"b;
				        item (itemx).trailer.VTs = 0;
				        item (itemx).trailer.NLs = 0;
				        end;
			  end;
			  end;
		    else
			  ;		      /* ignore vertical white space within stmt in delnl mode */

	      else
		    begin;		      /* comment trailer */
		    declare category	      fixed binary (2);
		    declare old_gave_error_msg      bit (1) aligned;

		    call adjust_vertical_white_space_after_item (itemx);

		    if this_type = semi_colon
		        & trailerx = token (tokenx).trailer_index + 1
		        & ^item (itemx).trailer.NP
		        & item (itemx).trailer.VTs = 0
		        & item (itemx).trailer.NLs = 1 & mode_delnl then
			  item (itemx).trailer.NLs = 0;

		    if itemx >= hbound (item, 1) then
			  call error (4,
			      "Too many tokens and comments in a statement."
			      , trailer (trailerx).string_ptr);

		    itemx = itemx + 1;
		    old_gave_error_msg = item (itemx).gave_error_msg;
		    unspec (item (itemx)) = ""b;
		    item (itemx).type = comment_token;
		    item (itemx).string_ptr = trailer (trailerx).string_ptr;
		    item (itemx).string_size =
		        trailer (trailerx).string_size;

		    if item (itemx - 1).type = right_parn then
			  item (itemx).paren_depth =
			      item (itemx - 1).paren_depth - 1;
		    else
			  item (itemx).paren_depth =
			      item (itemx - 1).paren_depth;

		    item (itemx).precedence = precedence (comment_token);
		    item (itemx).header.need_space =
		        space_table (
		        last_space_class (item (itemx - 1).type),
		        this_space_class (comment_token));
		    item (itemx).gave_error_msg =
		        old_gave_error_msg & keep_gave_error_msg;

		    do category = length (comment_indicator_extra_chars)
		        to 1 by -1
		        while (
		        substr (trailer_string, length (open_comment) + 1,
		        min (length (trailer_string)
		        - length (open_comment) - length (close_comment),
		        category))
		        ^=
		        substr (comment_indicator_extra_chars, 1, category))
		        ;
		    end;

		    item (itemx).comment_ind_len =
		        length (open_comment) + category;
		    item (itemx).header.insnl = category > 0;

		    if substr (trailer_string,
		        item (itemx).comment_ind_len + 1,
		        length (comment_indicator_no_indcomtxt))
		        = comment_indicator_no_indcomtxt then
			  item (itemx).comment_ind_len =
			      item (itemx).comment_ind_len
			      + length (comment_indicator_no_indcomtxt);
		    else
			  item (itemx).indcomtxt = "1"b;

		    if category = 0 then
			  if next_comment_in_col_1 then
				if mode_indcom & tokenx > 1 then
				        category = 2;
				else
				        category = 3;

			  else	if is_after_statement
				    | this_type = comma
				    | this_type = target_comma then
				category = 1;

		    if category = 3 then
			  do;
			  item (itemx).header.tab = "1"b;
			  item (itemx).header.amount = 1;
			  end;

		    else	  if category = 2 then
			  do;
			  item (itemx).header.tab = "1"b;
			  item (itemx).header.amount =
			      indent_margin (mode_indblkcom, left_margin);
			  item (itemx).header.tab_blkcom =
			      tokenx = stmt (stmtx).end;
			  end;

		    else	  if category = 1 then
			  do;
			  item (itemx).header.tab = "1"b;
			  item (itemx).header.amount = mode_comcol;
			  end;

		    else
			  do;
			  item (itemx).header.amount =
			      item (itemx).header.need_space;

			  if trailer (trailerx).continued & mode_linecom
			      then
				if trailer (trailerx + 1).type
				    = nl_vt_np_token then
				        do;
				        item (itemx).header.tab = "1"b;
				        item (itemx).header.amount =
					  mode_comcol;

				        if mode_delnl then
					      item (itemx).trailer
						.NLs = 1;
				        end;
			  end;

		    if scan_control_comments then
			  if is_control_comment (trailer_string,
			      (item (itemx).comment_ind_len),
			      item (itemx).gave_error_msg) then
				if is_after_statement then
				        do;
				        item (itemx).control_comment =
					  "1"b;
				        call format_pl1_modes_ (
					  temp_segs (*),
					  before (
					  after (trailer_string,
					  control_comment_indicator),
					  close_comment),
					  addr (trailer_string), "1"b,
					  item (itemx).gave_error_msg)
					  ;
				        end;

				else
				        call error (2,
					  "Control comment within statement."
					  , item (itemx).string_ptr);
		    end;

	      last_trailer_type = trailer (trailerx).type;
	      loop = trailer (trailerx).continued;
        end;
        call adjust_vertical_white_space_after_item (itemx);

        global.current_style = style_before_trailers;

        return;

adjust_vertical_white_space_after_item:
        procedure (itemx);

        declare itemx		fixed binary;   /* (Input) item to adjust */

        if (item (itemx).trailer.NP | item (itemx).trailer.VTs > 0)
	  & item (itemx).trailer.NLs = 0 then
	      item (itemx).trailer.NLs = 1;

        if item (itemx).type = comment_token & item (itemx).header.tab
	  & item (itemx).trailer.NLs = 0 & mode_insnl then
	      item (itemx).trailer.NLs = 1;
        end adjust_vertical_white_space_after_item;

is_control_comment:
        procedure (comment, comment_ind_len, gave_error_msg)
	  returns (bit (1) aligned);

        declare comment		char (*);	      /* (Input) comment which may be a control comment */
        declare comment_ind_len	fixed binary (3);
					      /* (Input) comment indicator length */
        declare gave_error_msg	bit (1);	      /* (Updated) on if printed it's a bad control comment */

        declare control_comment	bit (1) aligned;

        if index (comment, control_comment_indicator) = 0 then
	      return ("0"b);

        if verify (
	  before (substr (comment, comment_ind_len + 1),
	  control_comment_indicator), HT_SP) ^= 0 then
	      return ("0"b);

        control_comment =
	  search (
	  ltrim (
	  rtrim (
	  before (after (comment, control_comment_indicator), close_comment),
	  HT_SP), HT_SP), HT_SP) = 0;

        if ^control_comment & ^gave_error_msg then
	      do;
	      call error (2, "Invalid syntax in control comment.",
		addr (comment));
	      gave_error_msg = "1"b;
	      end;

        return (control_comment);
        end is_control_comment;

        end make_items;

/* Copy all items in a statement into the output segment. */

copy_items:
        procedure (first_item, last_item);

        declare first_item		fixed binary;   /* (Input) index of first item to copy */
        declare last_item		fixed binary;   /* (Input) index of last item to copy */

        declare itemx		fixed binary;

        declare item_string		char (item (itemx).string_size)
				based (item (itemx).string_ptr);

        do itemx = first_item to last_item;
	      if item (itemx).header.tab_blkcom then
		    item (itemx).header.amount =
		        indent_margin (mode_indblkcom, left_margin);

	      if item (itemx).control_comment then
		    do;
		    call format_pl1_modes_ (temp_segs (*),
		        before (
		        after (item_string, control_comment_indicator),
		        close_comment), addr (item_string), "1"b,
		        item (itemx).gave_error_msg);

		    if off_region_ptr = null then
			  if mode_on then
				call copy_item (itemx, "111"b);
			  else
				do;
				call copy_item (itemx, "100"b);
				off_region_ptr =
				    item (itemx).string_ptr;
				end;

		    else	  if mode_on then
			  do;
			  call copy_off_region (
			      char_offset_ ((item (itemx).string_ptr)));
			  call copy_item (itemx, "011"b);
			  end;
		    end;

	      else    if mode_on then
		    call copy_item (itemx, "111"b);
        end;

        return;

/* Copy one item into the output segment. */

copy_item:
        procedure (itemx, copy_sws);

        declare itemx		fixed binary;   /* (Input) item to copy */
        declare copy_sws		bit (3) aligned;/* (Input) on to copy header, item, trailer, respectively */

        declare item_string		char (item (itemx).string_size)
				based (item (itemx).string_ptr);

        if substr (copy_sws, 1, 1) & item (itemx).header.amount > 0 then
	      begin;
	      declare col_to_go	        fixed binary;
	      declare tabs		        fixed binary;

	      if item (itemx).header.tab then
		    col_to_go = item (itemx).header.amount;
	      else
		    col_to_go = line_position + item (itemx).header.amount;

	      if col_to_go < line_position
		| col_to_go = line_position & line_position > 1
		& item (itemx).type ^= comment_token then
		    if mode_insnl | item (itemx).header.insnl then
			  do;
			  call copy_string (NL);
			  line_position = 1;
			  end;

		    else
			  col_to_go =
			      line_position
			      + item (itemx).header.need_space;

	      tabs = divide (col_to_go - 1, tab_interval, 17)
		- divide (line_position - 1, tab_interval, 17);
	      if tabs > 0 & col_to_go - line_position > 1 then
		    do;
		    call copy_char (HT, tabs);
		    line_position =
		        tab_interval
		        * divide (col_to_go - 1, tab_interval, 17) + 1;
		    end;

	      if line_position < col_to_go then
		    do;
		    call copy_char (SP, col_to_go - line_position);
		    line_position = col_to_go;
		    end;
	      end;

        if substr (copy_sws, 2, 1) then
	      if item (itemx).type = comment_token
		& (^global.rdc_source | index (item_string, "/*++") ^= 1)
		& item (itemx).indcomtxt & mode_indcomtxt then
		    begin;
		    declare comment_close_ind_len   fixed binary (21);
		    declare comment_text_len	      fixed binary (21);
		    declare scan_index	      fixed binary (21);

		    comment_text_len =
		        length (item_string)
		        - item (itemx).comment_ind_len
		        - length (close_comment);
		    comment_close_ind_len = length (close_comment);

		    scan_index =
		        verify (
		        reverse (
		        substr (item_string,
		        item (itemx).comment_ind_len + 1, comment_text_len))
		        , comment_indicator_extra_chars) - 1;
		    if scan_index < 0 then
			  scan_index = comment_text_len;

		    scan_index =
		        min (scan_index,
		        length (comment_indicator_extra_chars));
		    comment_text_len = comment_text_len - scan_index;
		    comment_close_ind_len =
		        comment_close_ind_len + scan_index;

		    if comment_text_len
		        >= length (comment_indicator_no_indcomtxt) then
			  if substr (item_string,
			      item (itemx).comment_ind_len
			      + comment_text_len
			      - length (comment_indicator_no_indcomtxt)
			      + 1,
			      length (comment_indicator_no_indcomtxt))
			      = comment_indicator_no_indcomtxt then
				do;
				comment_text_len =
				    comment_text_len
				    -
				    length (
				    comment_indicator_no_indcomtxt);
				comment_close_ind_len =
				    comment_close_ind_len
				    +
				    length (
				    comment_indicator_no_indcomtxt);
				end;

		    begin;
			  declare comment_close_ind	    char (
						    comment_close_ind_len
						    )
						    defined (
						    item_string)
						    position (
						    item (itemx)
						    .comment_ind_len
						    +
						    comment_text_len
						    + 1);
			  declare comment_indicator	    char (
						    item (itemx)
						    .
						    comment_ind_len)
						    defined (
						    item_string);
			  declare comment_text	    char (
						    comment_text_len)
						    defined (
						    item_string)
						    position (
						    item (itemx)
						    .comment_ind_len
						    + 1);

			  call indent_comment (comment_indicator,
			      comment_text, comment_close_ind,
			      (item (itemx).header.tab),
			      item (itemx).header.amount - 1,
			      line_position);
		    end;
		    end;

	      else
		    do;
		    call copy_string (item_string);

		    if item (itemx).type = char_string
		        | item (itemx).type = comment_token then
			  line_position =
			      last_line_position (line_position,
			      item_string);
		    else
			  line_position =
			      line_position + length (item_string);
		    end;

        if substr (copy_sws, 3, 1) & item (itemx).trailer.NLs > 0 then
	      do;
	      if (item (itemx).trailer.NP | item (itemx).trailer.VTs > 0)
		& line_position > 1 then
		    call copy_string (NL);

	      if item (itemx).trailer.NP then
		    call copy_string (NP);

	      call copy_char (VT, (item (itemx).trailer.VTs));
	      call copy_char (NL, (item (itemx).trailer.NLs));

	      line_position = 1;
	      end;

        return;

indent_comment:
        procedure (comment_indicator, comment_text, comment_close_ind, tab,
	  comment_indentation, line_position);

        declare comment_indicator	char (*);	      /* (Input) what the comment starts with */
        declare comment_text		char (*);	      /* (Input) text of comment to indent */
        declare comment_close_ind	char (*);	      /* (Input) what the comment ends with */
        declare tab			bit (1) aligned;/* (Input) on for block comments */
        declare comment_indentation	fixed binary;   /* (Input) number of columns to indent comment */
        declare line_position		fixed binary;   /* (Output) output segment line position */

        declare line_length		fixed binary (21);
        declare n_HT		fixed binary;
        declare n_SP		fixed binary;
        declare scan_index		fixed binary (21);
        declare scan_position		fixed binary (21);

        if tab then
	      begin;
	      declare text_indentation        fixed binary;

	      text_indentation =
		comment_indentation + length (comment_indicator || SP);
	      n_HT = divide (text_indentation, tab_interval, 17);
	      n_SP = text_indentation - tab_interval * n_HT;
	      end;

        call copy_string (comment_indicator);

        scan_position = 1;
        do while (scan_position <= length (comment_text));
	      scan_index =
		search (substr (comment_text, scan_position), NL_VT_NP) - 1;
	      if scan_index < 0 then
		    do;
		    scan_index =
		        length (substr (comment_text, scan_position));
		    line_length = scan_index;
		    end;

	      else
		    line_length =
		        length (
		        rtrim (
		        substr (comment_text, scan_position, scan_index),
		        HT_SP));

	      if scan_position = 1 then
		    begin;
		    declare line		      char (line_length)
					      defined (comment_text);

		    if verify (line, HT_SP) = 1 then
			  call copy_string (SP);

		    call copy_string (line);
		    end;

	      else    if tab then
		    begin;
		    declare trim_length	      fixed binary (21);

		    trim_length =
		        length (
		        ltrim (
		        substr (comment_text, scan_position, line_length),
		        HT_SP));
		    if trim_length > 0 then
			  begin;
			  declare trimmed_line	    char (
						    trim_length)
						    defined (
						    comment_text)
						    position (
						    scan_position
						    + line_length
						    - trim_length);

			  call copy_char (HT, n_HT);
			  call copy_char (SP, n_SP);
			  call copy_string (trimmed_line);
			  end;
		    end;

	      else
		    begin;
		    declare line		      char (line_length)
					      defined (comment_text)
					      position (scan_position)
					      ;

		    call copy_string (line);
		    end;

	      scan_position = scan_position + scan_index;

	      scan_index =
		verify (substr (comment_text, scan_position), NL_VT_NP) - 1;
	      if scan_index < 0 then
		    scan_index =
		        length (substr (comment_text, scan_position));

	      begin;
		    declare vertical_white_space    char (scan_index)
					      defined (comment_text)
					      position (scan_position)
					      ;

		    call copy_string (vertical_white_space);
	      end;

	      scan_position = scan_position + scan_index;
        end;

        if tab
	  & index (NL_VT_NP, substr (output_string, copy_position - 1, 1)) > 0
	  then
	      do;
	      n_HT = divide (comment_indentation, tab_interval, 17);
	      call copy_char (HT, n_HT);
	      call copy_char (SP, comment_indentation - tab_interval * n_HT);
	      end;

        else    if index (HT_SP_NL_VT_NP,
		substr (output_string, copy_position - 1, 1)) = 0 then
	      call copy_string (SP);

        call copy_string (comment_close_ind);

        begin;
	      declare output	        char (copy_position - 1)
				        defined (output_string);

	      line_position = last_line_position (1, output);
        end;
        end indent_comment;

/* Copy one character several times into the output segment.

   The complicated case statement is just to get better code out of the compiler.
*/
copy_char:
        procedure (char, number);

        declare char		char (1);	      /* (Input) character to place in the output segment */
        declare number		fixed binary;   /* (Input) how many times to copy the character */

        if char = SP then
	      substr (output_string, copy_position, number) = "";

        else    if char = HT then
	      substr (output_string, copy_position, number) =
		copy (HT, number);

        else    if char = NL then
	      substr (output_string, copy_position, number) =
		copy (NL, number);

        else    if char = VT then
	      substr (output_string, copy_position, number) =
		copy (VT, number);

        else
	      substr (output_string, copy_position, number) =
		copy (char, number);

        copy_position = copy_position + number;
        end copy_char;

        end copy_item;

        end copy_items;

/* Copy an off region into the output segment. */

copy_off_region:
        procedure (stop_position);

        declare stop_position		fixed binary (21);
					      /* (Input) last character to copy */

        declare off_region_length	fixed binary (21);

        declare off_region_string	char (off_region_length)
				based (off_region_ptr);

        off_region_length = stop_position - char_offset_ (off_region_ptr);

        call copy_string (off_region_string);
        line_position = last_line_position (line_position, off_region_string);

        off_region_ptr = null;
        end copy_off_region;

/* Copy a string into the output segment. */

copy_string:
        procedure (string);

        declare string		char (*);	      /* (Input) string to place in the output segment */

        substr (output_string, copy_position, length (string)) = string;
        copy_position = copy_position + length (string);
        end copy_string;

/* Calculate an indented margin. */

indent_margin:
        procedure (indent, margin) returns (fixed binary);

        declare indent		bit (1);	      /* (Input) on to indent to margin */
        declare margin		fixed binary;   /* (Input) margin to indent to */

        if indent then
	      return (margin);
        else
	      return (max (margin - mode_ind, 1));
        end indent_margin;

/* Calculate the line position after a string. */

last_line_position:
        procedure (line_position, string) returns (fixed binary);

        declare line_position		fixed binary;   /* (Input) line position string starts on */
        declare string		char (*);	      /* (Input) string to place at line_position */

        declare last_line_length	fixed binary (21);

        last_line_length = search (reverse (string), NL_VT_NP) - 1;
        if last_line_length < 0 then
	      return (next_line_position (line_position, string));

        begin;
	      declare last_line	        char (last_line_length)
				        defined (string)
				        position (length (string)
				        - last_line_length + 1);

	      return (next_line_position (1, last_line));
        end;
        end last_line_position;

/* Calculate the line position after a string on its first line, i.e. before any vertical white space. */

next_line_position:
        procedure (start_line_position, string) returns (fixed binary);

        declare start_line_position	fixed binary;   /* (Input) line position string start on */
        declare string		char (*);	      /* (Input) string to place at start_line_position */

        declare line_position		fixed binary (21);
        declare scan_index		fixed binary (21);
        declare scan_position		fixed binary (21);

        line_position = start_line_position;
        scan_position = 1;
        do while (scan_position <= length (string));
	      scan_index =
		search (substr (string, scan_position), HT_BS_NL_VT_NP) - 1;
	      if scan_index < 0 then
		    scan_index = length (substr (string, scan_position));

	      line_position = line_position + scan_index;
	      scan_position = scan_position + scan_index + 1;

	      if scan_position - 1 <= length (string) then
		    if substr (string, scan_position - 1, 1) = HT then
			  line_position =
			      tab_interval
			      *
			      divide (line_position + tab_interval - 1,
			      tab_interval, 17) + 1;

		    else	  if substr (string, scan_position - 1, 1) = BS
			      then
			  line_position = line_position - 1;

		    else
			  scan_position = length (string) + 1;
        end;

        return (line_position);
        end next_line_position;

/* Print an error message. */

error:
        procedure (severity, error_string, source_ptr);

        declare severity		fixed binary (35);
					      /* (Input) severity of the error */
        declare error_string		char (*);	      /* (Input) error message */
        declare source_ptr		pointer unaligned;
					      /* (Input) pointer to error in source */

        call format_pl1_error_ (temp_segs (*), severity, error_string,
	  (source_ptr));

        if severity >= 4 then
	      goto unrecoverable_error;
        end error;

        end format_pl1_;





		    format_pl1_error_.pl1           08/10/84  0951.5re  08/10/84  0947.1       27252



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


/* Centralize format_pl1 error reporting.

   Written by Paul Green.
   Modified by Monte Davidoff.
*/
/* format: style5 */
format_pl1_error_:
        procedure (P_temp_segs, P_severity, P_error_string, P_source_ptr);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */
        declare P_severity		fixed binary (35);
					      /* (Input) severity of the error */
        declare P_error_string	char (*);	      /* (Input) error message */
        declare P_source_ptr		pointer;	      /* (Input) pointer to where error occured in the source */

/* automatic */

        declare line_length		fixed binary (21);
        declare line_number		fixed binary (21);
        declare line_start		fixed binary (21);

/* based */

        declare source_string		char (global.source_length)
				based (global.source_ptr);

/* builtin */

        declare (divide, index, length, max, null, size, substr)
				builtin;

/* internal static */

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

/* entry */

        declare char_offset_		entry (pointer)
				returns (fixed binary (21)) reducible;
        declare ioa_		entry options (variable);

%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);

        global.max_severity = max (global.max_severity, P_severity);

        line_number = 0;

        if P_source_ptr ^= null then
	      begin;
	      declare loop		        bit (1) aligned;
	      declare source_position	        fixed binary (21);

	      source_position =
		char_offset_ (P_source_ptr)
		- char_offset_ (global.source_ptr) + 1;

	      line_start = 1;
	      line_length = 0;

	      loop = "1"b;
	      do while (loop);
		    line_number = line_number + 1;
		    line_start = line_start + line_length;
		    line_length =
		        index (substr (source_string, line_start), NL);

		    loop = line_start + line_length <= source_position
		        & line_length > 0;
	      end;

	      if line_length = 0 then
		    line_length =
		        length (substr (source_string, line_start)) + 1;
	      end;

/* Print the error message. */

        call ioa_ ("^/^[WARNING^s^;SEVERITY ^d ERROR^]^[^s^; ON LINE ^d^]",
	  P_severity = 1, P_severity, line_number = 0, line_number);

        if P_error_string ^= "" then
	      call ioa_ ("^a", P_error_string);

        if line_number > 0 then
	      call ioa_ ("SOURCE:^-^a",
		substr (source_string, line_start, line_length - 1));
        end format_pl1_error_;




		    format_pl1_lex_.pl1             08/10/84  0951.5re  08/10/84  0947.2      223803



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

/* DESCRIPTION:

   This is the lexical analysis program for the format_pl1 command.  The
   primary responsibilities of this program are:

   1) Break the source program into tokens.
   2) Thread comments off the preceding token.
   3) Thread interstatement white space off the preceding token.
   4) Diagnose errors in the lexical syntax of programs.

   This program also performs several miscellaneous chores that assist
   subsequent phases.  They are:

   1) Determine the type of arithmetic constants.

   Maintenance Instructions:

   To add another token type:

   1) Add a token type declaration to format_pl1_dcls.incl.pl1.
   2) Adjust the token class limits in format_pl1_dcls.incl.pl1.
   3) If necessary, adjust tentative_token_type and action_table.

   To add another macro:

   1) To add another macro statement, see in format_pl1_stmt_type_.
   2) To add another macro reference, i.e.  a macro construct that gets
   formatted like a PL/I reference such as %isarg, %isdef, and
   %target, add an entry to the ignore_percent_token array.
*/

/* HISTORY:
   Written by Paul Green, 11/05/77.
   from "lex" in the PL/I compiler.
   Modified:
   12/26/77 by Paul Green:  Save comments and vertical white space as
   token trailers.
   11/01/78 by Monte Davidoff:
   06/05/84 by R. Michael Tague:  Make format_pl1 handle all % macro statements.
   Changed %arg to %isarg, and added %isdef to ignore_percent_token.
*/
/* format: style5 */
format_pl1_lex_:
        procedure (P_temp_segs);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */

/* automatic */

        declare action_index		fixed binary;   /* index of action to execute */
        declare current_char		char (1) aligned;
					      /* character that stopped the scan, char we are checking */
        declare loop		bit (1) aligned;/* loop control variable */
        declare scan_index		fixed binary (21);
					      /* index (relative to source_index) of forward scan */
        declare source_index		fixed binary (21);
					      /* index into current source segment */
        declare source_length		fixed binary (21);
					      /* length (in characters) of current source segment */
        declare source_ptr		pointer;	      /* pointer to base of source segment */
        declare string_length		fixed binary (21);
					      /* number of characters in dequoted string */
        declare token_length		fixed binary (21);
					      /* length of token in characters */
        declare token_start		fixed binary (21);
					      /* index of first character of current token */
        declare token_type		fixed binary (8);
					      /* type of current token */
        declare tokenx		fixed binary;   /* index into token */
        declare trailerx		fixed binary;   /* index into trailer */

        declare tentative_token_type	(0:128) fixed binary (8)
				initial ((9) invalid_char,
					      /* 000-010	ctl chars	*/
				no_token,	      /* 011		HT	*/
				(3) nl_vt_np_token,
					      /* 012-014	NL VT NP	*/
				(19) invalid_char,
					      /* 015-037	ctl chars	*/
				no_token,	      /* 040		SP	*/
				invalid_char,   /* 041		!	*/
				char_string,    /* 042		"	*/
				(2) invalid_char,
					      /* 043-044	# $	*/
				percent,	      /* 045		%	*/
				and,	      /* 046		&	*/
				invalid_char,   /* 047		'	*/
				left_parn,      /* 050		(	*/
				right_parn,     /* 051		)	*/
				asterisk,	      /* 052		*	*/
				plus,	      /* 053		+	*/
				comma,	      /* 054		,	*/
				minus,	      /* 055		-	*/
				period,	      /* 056		.	*/
				slash,	      /* 057		/	*/
				(10) dec_integer,
					      /* 060-071	0 - 9	*/
				colon,	      /* 072		:	*/
				semi_colon,     /* 073		;	*/
				lt,	      /* 074		<	*/
				assignment,     /* 075		=	*/
				gt,	      /* 076		>	*/
				(2) invalid_char,
					      /* 077-100	? @	*/
				(26) identifier,/* 101-132	A - Z	*/
				(3) invalid_char,
					      /* 133-135	[ \ ]	*/
				not,	      /* 136		^	*/
				(2) invalid_char,
					      /* 137-140	_ `	*/
				(26) identifier,/* 141-172	a - z	*/
				invalid_char,   /* 173		{	*/
				or,	      /* 174		|	*/
				(3) invalid_char,
					      /* 175-177	} ~ PAD	*/
				invalid_char);  /* >177		non-ASCII	*/

/* based */

        declare source_string		char (source_length) based (source_ptr);
        declare source_string_array	(source_length) char (1)
				based (source_ptr);
        declare token_string		char (token (tokenx).string_size)
				based (token (tokenx).string_ptr);

/* builtin */

        declare (addr, binary, bit, char, divide, hbound, index, lbound, length,
	      min, null, rank, search, size, substr, unspec, verify)
				builtin;

/* internal static */

        declare action_table		(0:128) fixed binary internal
				static options (constant)
				initial ((9) 10,/* 000-010	ctl chars */
				1,	      /* 011		HT	*/
				(3) 9,	      /* 012-014	NL VT NP	*/
				(19) 10,	      /* 015-037	ctl chars	*/
				1,	      /* 040		SP	*/
				10,	      /* 041		!	*/
				2,	      /* 042		"	*/
				10,	      /* 043		#	*/
				10,	      /* 044		$	*/
				4,	      /* 045		%	*/
				5,	      /* 046		&	*/
				10,	      /* 047		'	*/
				(2) 5,	      /* 050-051	( )	*/
				11,	      /* 052		*	*/
				(2) 5,	      /* 053-054	+ ,	*/
				12,	      /* 055		-	*/
				7,	      /* 056		.	*/
				6,	      /* 057		/	*/
				(10) 8,	      /* 060-071	0 - 9	*/
				(2) 5,	      /* 072-073	: ;	*/
				13,	      /* 074		<	*/
				5,	      /* 075		=	*/
				14,	      /* 076		>	*/
				(2) 10,	      /* 077-100	? @	*/
				(26) 3,	      /* 101-132	A - Z	*/
				(3) 10,	      /* 133-135	[ \ ]	*/
				15,	      /* 136		^	*/
				(2) 10,	      /* 137-140	_ `	*/
				(26) 3,	      /* 141-172	a - z	*/
				10,	      /* 173		{	*/
				16,	      /* 174		|	*/
				(3) 10,	      /* 175-177	} ~ PAD	*/
				10);	      /* >177		non-ASCII	*/

        declare bit_string_characters	char (23) internal static
				options (constant)
				initial ("""0123456789ABCDEFabcdef");
        declare digits		char (10) internal static
				options (constant)
				initial ("0123456789");
        declare identifier_characters	char (64) internal static
				options (constant)
				initial (
				"$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
				);
        declare ignore_percent_token	(3) char (8) internal static
				options (constant)
				initial ("%isarg", "%isdef", "%target");
        declare HT_SP		char (2) internal static
				options (constant) initial ("	 ");
        declare NL_VT_NP		char (3) internal static
				options (constant) initial ("
");
%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);
        global.n_tokens = 0;
        global.n_trailers = 0;

        source_ptr = global.source_ptr;
        source_length = global.source_length;
        source_index = 1;

        unspec (token (1)) = ""b;		      /* build dummy first token */
        token (1).type = no_token;
        token (1).string_ptr = null;
        tokenx = 1;
        trailerx = 0;

action (1):				      /* Scan horizontal white space */
        scan_index = verify (substr (source_string, source_index), HT_SP);
        if scan_index = 0 then
	      goto end_of_source_reached_but_no_pending_token;

        source_index = source_index + scan_index;
        current_char = substr (source_string, source_index - 1, 1);

        token_start = source_index - 1;
        token_type =
	  tentative_token_type (
	  min (rank (current_char), hbound (tentative_token_type, 1)));

        action_index =
	  action_table (min (rank (current_char), hbound (action_table, 1)));
        goto action (action_index);

action (2):				      /* Scan string: current_char = '"' */
        string_length = 0;			      /* count of number of characters in reduced string */

        loop = "1"b;
        do while (loop);
	      scan_index =
		index (substr (source_string, source_index), """") - 1;
	      if scan_index < 0 then
		    do;
		    call error (3,
		        "Missing double quote after string constant.",
		        token_start);

		    source_index = source_length + 1;
		    string_length =
		        string_length + (source_length - token_start + 1);
		    goto end_of_source_reached;
		    end;

	      source_index = source_index + scan_index + 1;
	      string_length = string_length + scan_index;

	      if source_index > source_length	      /* not an error */
		then
		    goto end_of_source_reached;

	      loop = substr (source_string, source_index, 1) = """";
	      if loop then
		    do;
		    source_index = source_index + 1;
		    string_length = string_length + 1;
		    end;
        end;

        if substr (source_string, source_index, 1) = "b" then
	      do;
	      token_type = bit_string;
	      source_index = source_index + 1;

	      if source_index <= source_length then
		    if index ("1234",
		        substr (source_string, source_index, 1)) > 0 then
			  source_index = source_index + 1;

	      if string_length > max_bit_string_constant then
		    call error (2, "Bit-string constant too long.",
		        token_start);

	      if verify (
		substr (source_string, token_start,
		source_index - token_start), bit_string_characters) ^= 0
		then
		    call error (2,
		        "Invalid characters in bit-string constant.",
		        token_start);
	      end;

        else
	      do;
	      if string_length > max_char_string_constant then
		    call error (2, "Character-string constant too long.",
		        token_start);

	      if global.ca.check_strings
		& (
		search (
		substr (source_string, token_start,
		source_index - token_start), NL_VT_NP) > 0
		|
		index (
		substr (source_string, token_start,
		source_index - token_start), "/*") > 0
		|
		index (
		substr (source_string, token_start,
		source_index - token_start), "*/") > 0) then
		    call error (1,
		        "Character-string constant contains ""/*"", ""*/"", or vertical white space."
		        , token_start);
	      end;

        call make_token;
        goto check_syntax_after_constant;

action (3):				      /* Scan identifiers */
        call scan_past_identifier_characters;
        call make_token;

/* Now make sure the syntax after the identifier is correct. */

        if substr (source_string, source_index, 1) = """"
	  & token_string ^= "p" & token_string ^= "pic"
	  & token_string ^= "picture" then
	      call error (2, "Double quote after identifier.", source_index);

        goto action (1);

action (4):				      /* % */
        if source_index > source_length then
	      goto end_of_source_reached;

        current_char = substr (source_string, source_index, 1);
        action_index =
	  action_table (min (rank (current_char), hbound (action_table, 1)));

        if action_index ^= 3			      /* identifier */
	  then
	      do;
	      call make_token;
	      goto action (1);
	      end;

        source_index = source_index + 1;
        call scan_past_identifier_characters;

        do action_index = lbound (ignore_percent_token, 1)
	  to hbound (ignore_percent_token, 1)
	  while (ignore_percent_token (action_index)
	  ^= substr (source_string, token_start, source_index - token_start));
        end;

        if action_index <= hbound (ignore_percent_token, 1) then
	      token_type = identifier;

        call make_token;

/* Now make sure the syntax after the %<identifier> is correct. */

        if substr (source_string, source_index, 1) = """" then
	      call error (2, "Double quote after %identifier.", source_index);

        goto action (1);

action (5):				      /* Single character tokens */
        call make_token;
        goto action (1);

action (6):				      /* Separate / and /* */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) ^= "*" then
	      do;
	      call make_token;
	      goto action (1);
	      end;

        token_type = comment_token;
        source_index = source_index + 1;

        scan_index = index (substr (source_string, source_index), "*/") - 1;
        if scan_index < 0 then
	      do;
	      call error (3, "Missing ""*/"" at end of comment.", token_start)
		;

	      source_index = source_length + 1;
	      call make_trailer;
	      goto end_of_source_reached_but_no_pending_token;
	      end;

        source_index = source_index + scan_index + length ("*/");

        if index (
	  substr (source_string, token_start + length ("/*"),
	  source_index - token_start - length ("/*") - length ("*/")), "/*")
	  > 0 & global.ca.check_comments then
	      call error (1, "Comment contains ""/*"".", token_start);

        call make_trailer;
        goto action (1);

action (7):				      /* Separate . and numbers: current_char = "." */
        if source_index > source_length then
	      goto end_of_source_reached;

        if index (digits, substr (source_string, source_index, 1)) = 0 then
	      do;
	      call make_token;
	      goto action (1);
	      end;

        token_type = fixed_dec;
        call scan_past_digits;
        goto scan_exponent;

action (8):				      /* Scan numbers and isubs: current char = <digit> */
        if source_index > source_length then
	      goto end_of_source_reached;

        call scan_past_digits;

        if substr (source_string, source_index, 1) = "." then
	      do;
	      token_type = fixed_dec;
	      source_index = source_index + 1;
	      call scan_past_digits;
	      end;

        else    if source_index + 2 <= source_length then
	      if substr (source_string, source_index, 3) = "sub" then
		    do;
		    source_index = source_index + 3;
		    token_type = isub;
		    call make_token;
		    goto check_syntax_after_constant;
		    end;

scan_exponent:
        token_length = source_index - token_start;      /* remember length of mantissa for later error check */

        if substr (source_string, source_index, 1) = "e"
	  | substr (source_string, source_index, 1) = "f" then
	      do;
	      if substr (source_string, source_index, 1) = "e" then
		    token_type =
		        bit_to_arithmetic (arithmetic_to_bit (token_type)
		        | is_float_constant);

	      token_type =
		bit_to_arithmetic (arithmetic_to_bit (token_type)
		& ^is_integral_constant);
	      source_index = source_index + 1;

	      if source_index > source_length then
		    do;
		    call error (3,
		        "Missing exponent in arithmetic constant.",
		        token_start);
		    goto end_of_source_reached;
		    end;

	      if substr (source_string, source_index, 1) = "+"
		| substr (source_string, source_index, 1) = "-" then
		    do;
		    source_index = source_index + 1;

		    if source_index > source_length then
			  do;
			  call error (3,
			      "Missing exponent in arithmetic constant.",
			      token_start);
			  goto end_of_source_reached;
			  end;
		    end;

	      call scan_past_digits;
	      end;

        if substr (source_string, source_index, 1) = "b"/* binary constant */
	  then
	      do;
	      token_type =
		bit_to_arithmetic (arithmetic_to_bit (token_type)
		& ^is_decimal_constant);
	      source_index = source_index + 1;

	      if verify (substr (source_string, token_start, token_length),
		".01") > 0 then
		    call error (2, "Non-binary digit in binary constant.",
		        token_start);
	      end;

        if source_index <= source_length then
	      if substr (source_string, source_index, 1) = "p" then
		    do;			      /* default suppression indicator */
		    token_type =
		        bit_to_arithmetic (arithmetic_to_bit (token_type)
		        & ^is_integral_constant);
		    source_index = source_index + 1;
		    end;

        if source_index <= source_length then
	      if substr (source_string, source_index, 1) = "i" then
		    do;			      /* imaginary constant */
		    token_type =
		        bit_to_arithmetic (arithmetic_to_bit (token_type)
		        | is_imaginary_constant);
		    source_index = source_index + 1;
		    end;

        call make_token;

/* Now make sure the syntax after the constant is correct. */

check_syntax_after_constant:
        if source_index > source_length then
	      goto end_of_source_reached;

        current_char = substr (source_string, source_index, 1);
        action_index =
	  action_table (min (rank (current_char), hbound (action_table, 1)));

        if action_index = 2 | action_index = 3 | action_index = 8
					      /* double quote, identifier, or arithmetic constant */
	  then
	      call error (2, "Invalid syntax after constant or isub.",
		source_index);

        goto action (1);

action (9):				      /* Scan NL VT NP */
        scan_index =
	  verify (substr (source_string, source_index), NL_VT_NP) - 1;
        if scan_index < 0 then
	      source_index = source_length + 1;
        else
	      source_index = source_index + scan_index;

        call make_trailer;
        goto action (1);

action (10):				      /* Invalid characters */
        if rank (current_char) < 32 | 128 <= rank (current_char) then
	      call error (2,
		"Invalid character. """
		|| char (bit (rank (current_char))) || """b",
		source_index - 1);

        else    if current_char = "_" | current_char = "$" then
	      call error (2,
		"""" || current_char || """ may not start an identifier.",
		source_index - 1);

        else
	      call error (2, "Invalid character. """ || current_char || """",
		source_index - 1);

        call make_token;
        goto action (1);

action (11):				      /* Separate * and ** */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = "*" then
	      do;
	      source_index = source_index + 1;
	      token_type = expon;
	      end;

        call make_token;
        goto action (1);

action (12):				      /* Separate - and -> */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = ">" then
	      do;
	      source_index = source_index + 1;
	      token_type = arrow;
	      end;

        call make_token;
        goto action (1);

action (13):				      /* Separate < and <= */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = "=" then
	      do;
	      source_index = source_index + 1;
	      token_type = le;
	      end;

        call make_token;
        goto action (1);

action (14):				      /* Separate > and >= */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = "=" then
	      do;
	      source_index = source_index + 1;
	      token_type = ge;
	      end;

        call make_token;
        goto action (1);

action (15):				      /* Separate ^ and ^= and ^< and ^> */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = "=" then
	      do;
	      source_index = source_index + 1;
	      token_type = ne;
	      end;

        else    if substr (source_string, source_index, 1) = "<" then
	      do;
	      source_index = source_index + 1;
	      token_type = nlt;
	      end;

        else    if substr (source_string, source_index, 1) = ">" then
	      do;
	      source_index = source_index + 1;
	      token_type = ngt;
	      end;

        call make_token;
        goto action (1);

action (16):				      /* Separate | and || */
        if source_index > source_length then
	      goto end_of_source_reached;

        if substr (source_string, source_index, 1) = "|" then
	      do;
	      source_index = source_index + 1;
	      token_type = cat;
	      end;

        call make_token;
        goto action (1);

/* Control transfers here whenever the lex reaches the end of the current source segment. */

end_of_source_reached:
        call make_token;

end_of_source_reached_but_no_pending_token:
        if tokenx >= hbound (token, 1) then
	      call error (4, "Too many tokens.", source_length);

        unspec (token (tokenx + 1)) = ""b;	      /* build dummy last token */
        token (tokenx + 1).type = no_token;

/* Set string_ptr so error messages will indicate the end of the program. */

        if source_length = 0 then
	      token (tokenx + 1).string_ptr = null;
        else
	      token (tokenx + 1).string_ptr =
		addr (source_string_array (source_length));

unrecoverable_error:
        global.n_tokens = tokenx;
        global.n_trailers = trailerx;

        return;

/* Make a Token.

   Convention:
   token_type	set to the correct type
   token_start	set to index of first character of token
   source_index	set to index of first character after token
*/
make_token:
        procedure;

        token_length = source_index - token_start;

        if token_type = identifier & token_length > max_identifier_length then
	      call error (2, "Identifier too long.", token_start);

        if tokenx >= hbound (token, 1) then
	      call error (4, "Too many tokens.", token_start);

        tokenx = tokenx + 1;
        unspec (token (tokenx)) = ""b;
        token (tokenx).type = token_type;
        token (tokenx).string_size = token_length;
        token (tokenx).string_ptr = addr (source_string_array (token_start));
        end make_token;

/* Make a token trailer and thread it off of the previous token.

   Convention:
   token_start	set to index of first char of trailer
   token_type	set to trailer type
   source_index	set to first char past trailer
*/
make_trailer:
        procedure;

        if trailerx >= hbound (trailer, 1) then
	      call error (4, "Too many trailers.", token_start);

        trailerx = trailerx + 1;
        unspec (trailer (trailerx)) = ""b;
        trailer (trailerx).type = token_type;
        trailer (trailerx).string_size = source_index - token_start;
        trailer (trailerx).string_ptr =
	  addr (source_string_array (token_start));

        if token (tokenx).trailer_index = 0 then
	      token (tokenx).trailer_index = trailerx;
        else
	      trailer (trailerx - 1).continued = "1"b;
        end make_trailer;

/* Convert an arithmetic token type to it's bit string encoding. */

arithmetic_to_bit:
        procedure (type) returns (bit (4) aligned);

        declare type		fixed binary (8);
					      /* (Input) arithmetic token type */

        return (bit (binary (type - min_arithmetic_token, 4), 4));
        end arithmetic_to_bit;

/* Convert the bit string encoding of an arithmetic token type to it's token type. */

bit_to_arithmetic:
        procedure (bit_encoding) returns (fixed binary (8));

        declare bit_encoding		bit (4) aligned;/* (Input) arithmetic token type bit string encoding */

        return (binary (bit_encoding, 4) + min_arithmetic_token);
        end bit_to_arithmetic;

/* Scan sequences of identifier characters.

   Convention:
   source_index	Entry: on character after identifier character
   Exit: on stopping break
*/
scan_past_identifier_characters:
        procedure;

        scan_index =
	  verify (substr (source_string, source_index), identifier_characters)
	  - 1;
        if scan_index < 0 then
	      do;
	      source_index = source_length + 1;
	      goto end_of_source_reached;
	      end;

        source_index = source_index + scan_index;
        end scan_past_identifier_characters;

/* Scan sequences of <digits>.

   Convention:
   source_index	Entry: on character after digit
   Exit: on stopping break
*/
scan_past_digits:
        procedure;

        scan_index = verify (substr (source_string, source_index), digits) - 1;
        if scan_index < 0 then
	      do;
	      source_index = source_length + 1;
	      goto end_of_source_reached;
	      end;

        source_index = source_index + scan_index;
        end scan_past_digits;

/* Print an error message. */

error:
        procedure (severity, error_string, error_index);

        declare severity		fixed binary (35);
					      /* (Input) severity of error */
        declare error_string		char (*);	      /* (Input) error message */
        declare error_index		fixed binary (21);
					      /* (Input) index into source where error occured */

        call format_pl1_error_ (temp_segs (*), severity, error_string,
	  addr (source_string_array (error_index)));

        if severity >= 4 then
	      goto unrecoverable_error;
        end error;

        end format_pl1_lex_;




		    format_pl1_long_.pl1            08/10/84  0951.5re  08/10/84  0947.2       31311



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


/* Print the -long control argument message.

   Written 17 March 1981 by M. N. Davidoff.
*/
/* format: style5 */
format_pl1_long_:
        procedure (P_temp_segs, P_source_ptr);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */
        declare P_source_ptr		pointer;	      /* (Input) pointer to prevailing style control comment */

/* automatic */

        declare mode_differences	char (dimension (switch_mode_names, 1)
				* (length (switch_mode_not_indicator)
				+
				max (
				maxlength (
				switch_mode_names (
				lbound (switch_mode_names, 1))),
				maxlength (
				switch_antonym_names (
				lbound (switch_antonym_names, 1))))
				+ length (mode_separator))
				+ dimension (value_mode_names, 1)
				* (
				maxlength (
				value_mode_names (
				lbound (value_mode_names, 1)))
				+ length (null -> value_picture)
				+ length (mode_separator))) varying;
        declare mode_index		fixed binary;

/* based */

        declare value_picture		picture "(5)z9" based;

/* builtin */

        declare (convert, dimension, divide, hbound, lbound, length, ltrim, max,
	      maxlength, null, rtrim, size)
				builtin;

%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);

        mode_differences = "";

        do mode_index = lbound (global.prevailing_style.switches, 1)
	  to hbound (global.prevailing_style.switches, 1);
	      if global.prevailing_style.switches (mode_index)
		^= global.command_line_style.switches (mode_index) then
		    do;
		    if mode_differences ^= "" then
			  mode_differences =
			      mode_differences || mode_separator;

		    if ^global.prevailing_style.switches (mode_index) then
			  if switch_antonym_names (mode_index) = "" then
				mode_differences =
				    mode_differences
				    || switch_mode_not_indicator
				    ||
				    rtrim (
				    switch_mode_names (mode_index));

			  else
				mode_differences =
				    mode_differences
				    ||
				    rtrim (
				    switch_antonym_names (mode_index));

		    else
			  mode_differences =
			      mode_differences
			      || rtrim (switch_mode_names (mode_index));
		    end;
        end;

        do mode_index = lbound (global.prevailing_style.values, 1)
	  to hbound (global.prevailing_style.values, 1);
	      if global.prevailing_style.values (mode_index)
		^= global.command_line_style.values (mode_index) then
		    do;
		    if mode_differences ^= "" then
			  mode_differences =
			      mode_differences || mode_separator;

		    mode_differences =
		        mode_differences
		        || rtrim (value_mode_names (mode_index))
		        ||
		        ltrim (
		        convert (value_picture,
		        global.prevailing_style.values (mode_index)));
		    end;
        end;

        call format_pl1_error_ (temp_segs (*), 1,
	  "The following prevailing style modes differ from the command line modes:
"
	  || mode_differences, P_source_ptr);
        end format_pl1_long_;




		    format_pl1_modes_.pl1           08/10/84  0951.5re  08/10/84  0947.2       58464



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


/* Scan a modes string and apply the modes to the current style.

   Written 5-Nov-79 by M. N. Davidoff.
*/
/* format: style5 */
format_pl1_modes_:
        procedure (P_temp_segs, P_modes_string, P_source_ptr, P_revert_ok_sw,
	  P_printed_error_msg_sw);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */
        declare P_modes_string	char (*);	      /* (Input) modes string to scan */
        declare P_source_ptr		pointer;	      /* (Input) pointer to control comment in source segment, or
					         null for a command line modes string */
        declare P_revert_ok_sw	bit (1);	      /* (Input) on if there is a prevailing style */
        declare P_printed_error_msg_sw	bit (1);	      /* (Input/Output) on if printed it's a bad modes string */

/* automatic */

        declare modes_string_length	fixed binary (21);
        declare scan_index		fixed binary (21);
        declare scan_length		fixed binary (21);

/* based */

        declare modes_string		char (modes_string_length)
				based (addr (P_modes_string));

/* builtin */

        declare (addr, binary, divide, hbound, index, lbound, length, null,
	      reverse, rtrim, search, size, substr, verify)
				builtin;

/* internal static */

        declare HT_SP		char (2) internal static
				options (constant) initial ("	 ");
        declare digits		char (10) internal static
				options (constant)
				initial ("0123456789");

/* entry */

        declare com_err_		entry options (variable);

%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);

        modes_string_length = length (rtrim (P_modes_string, HT_SP));
        if modes_string_length = 0 then
	      call error (2, "");

        scan_index = verify (P_modes_string, HT_SP);
        do while (scan_index <= length (modes_string));
	      scan_length =
		index (substr (modes_string, scan_index), mode_separator)
		- 1;
	      if scan_length < 0 then
		    scan_length =
		        length (substr (modes_string, scan_index));

	      begin;
		    declare mode		      char (scan_length)
					      defined (modes_string)
					      position (scan_index);

		    call apply_mode (mode);
	      end;

	      scan_index = scan_index + scan_length + length (mode_separator);
        end;

        if index (reverse (modes_string), reverse (mode_separator)) = 1 then
	      call error (2, "");

return:
        return;

/* Apply one mode to the current style. */

apply_mode:
        procedure (mode_and_value);

        declare mode_and_value	char (*);	      /* (Input) mode to apply */

        declare mode		char (32);
        declare mode_index		fixed binary;
        declare mode_length		fixed binary (21);
        declare mode_start_pos	fixed binary (21);
        declare not_sw		bit (1) aligned;
        declare value		fixed binary;

        not_sw = index (mode_and_value, switch_mode_not_indicator) = 1;
        if not_sw then
	      mode_start_pos = length (switch_mode_not_indicator) + 1;
        else
	      mode_start_pos = 1;

        mode_length =
	  search (substr (mode_and_value, mode_start_pos), digits) - 1;
        if mode_length < 0 then
	      mode_length = length (substr (mode_and_value, mode_start_pos));

        mode = substr (mode_and_value, mode_start_pos, mode_length);

        if mode_start_pos + mode_length > length (mode_and_value) then
	      value = -1;
        else
	      begin;
	      declare conversion	        condition;
	      declare size		        condition;

	      if verify (
		substr (mode_and_value, mode_start_pos + mode_length),
		digits) ^= 0 then
		    call error (2, mode_and_value);

	      on conversion, size call error (2, mode_and_value);

(conversion, size):
	      value =
		binary (
		substr (mode_and_value, mode_start_pos + mode_length), 17);
	      end;

        if mode = revert_mode then
	      if not_sw | value >= 0 | ^P_revert_ok_sw then
		    call error (2, mode_and_value);
	      else
		    do;
		    global.current_style = global.prevailing_style;
		    return;
		    end;

        if mode = style_mode then
	      if value < lbound (styles, 1) | hbound (styles, 1) < value
		| not_sw then
		    call error (2, mode_and_value);
	      else
		    do;
		    global.current_style = styles (value);
		    return;
		    end;

        do mode_index = lbound (value_mode_names, 1)
	  to hbound (value_mode_names, 1);
	      if mode = value_mode_names (mode_index) then
		    if not_sw | value < 0 then
			  call error (2, mode_and_value);
		    else
			  do;
			  global.current_style.values (mode_index) =
			      value;
			  return;
			  end;
        end;

        if value >= 0 then
	      call error (2, mode_and_value);

        do mode_index = lbound (switch_mode_names, 1)
	  to hbound (switch_mode_names, 1);
	      if mode = switch_mode_names (mode_index) then
		    do;
		    global.current_style.switches (mode_index) = ^not_sw;
		    return;
		    end;
        end;

        do mode_index = lbound (switch_antonym_names, 1)
	  to hbound (switch_antonym_names, 1);
	      if mode = switch_antonym_names (mode_index) then
		    do;
		    global.current_style.switches (mode_index) = not_sw;
		    return;
		    end;
        end;

        call error (2, mode_and_value);
        end apply_mode;

/* Print an error message. */

error:
        procedure (severity, mode);

        declare severity		fixed binary (35);
					      /* (Input) severity of the error */
        declare mode		char (*);	      /* (Input) mode that is in error */

        if ^P_printed_error_msg_sw then
	      do;
	      if P_source_ptr = null then
		    do;
		    global.max_severity = 5;
		    call com_err_ (0, command, "Invalid mode. ""^a""", mode)
		        ;
		    end;

	      else
		    call format_pl1_error_ (temp_segs (*), severity,
		        "Invalid mode. """ || mode || """", P_source_ptr);

	      P_printed_error_msg_sw = "1"b;
	      end;

        goto return;
        end error;

        end format_pl1_modes_;




		    format_pl1_record_style_.pl1    08/10/84  0951.5re  08/10/84  0947.2       49437



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


/* Write a prevailing style control comment into the output segment.

   Written 5-Nov-79 by M. N. Davidoff.
*/
/* format: style5 */
format_pl1_record_style_:
        procedure (P_temp_segs, P_copy_position, P_line_position);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */
        declare P_copy_position	fixed binary (21);
					      /* (Input/Output) output segment index of next character */
        declare P_line_position	fixed binary;   /* (Input/Output) column next character will be in */

/* builtin */

        declare (convert, divide, hbound, lbound, length, ltrim, rtrim, size,
	      substr)		builtin;

/* internal static */

        declare NL			char (1) internal static
				options (constant) initial ("
");
        declare SP			char (1) internal static
				options (constant) initial ("");

%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);

        call record_style (get_nearest_style ());

        return;

/* Find the predefined style closest to the prevailing style. */

get_nearest_style:
        procedure returns (fixed binary);

        declare differences		fixed binary;
        declare fewest_differences	fixed binary;
        declare nearest_style		fixed binary;
        declare style_index		fixed binary;

        nearest_style = lbound (styles, 1);
        fewest_differences = count_differences (nearest_style);
        do style_index = lbound (styles, 1) + 1 to hbound (styles, 1);
	      differences = count_differences (style_index);
	      if differences < fewest_differences then
		    do;
		    fewest_differences = differences;
		    nearest_style = style_index;
		    end;
        end;

        return (nearest_style);

/* Count how many modes are different between a predefined style and the prevailing style. */

count_differences:
        procedure (style_index) returns (fixed binary);

        declare style_index		fixed binary;   /* (Input) predefined style number */

        declare differences		fixed binary;
        declare mode_index		fixed binary;

        differences = 0;

        do mode_index = lbound (global.prevailing_style.switches, 1)
	  to hbound (global.prevailing_style.switches, 1);
	      if global.prevailing_style.switches (mode_index)
		^= styles (style_index).switches (mode_index) then
		    differences = differences + 1;
        end;

        do mode_index = lbound (global.prevailing_style.values, 1)
	  to hbound (global.prevailing_style.values, 1);
	      if global.prevailing_style.values (mode_index)
		^= styles (style_index).values (mode_index) then
		    differences = differences + 1;
        end;

        return (differences);
        end count_differences;

        end get_nearest_style;

/* Write the prevailing style control comment. */

record_style:
        procedure (nearest_style);

        declare nearest_style		fixed binary;   /* (Input) predefined style closest to the prevailing style */

        declare mode_index		fixed binary;

        declare value_picture		picture "(5)z9" based;

        if P_line_position > 1 then
	      do;
	      call copy_string (NL);
	      P_line_position = 1;
	      end;

        call copy_string ("/*" || SP || control_comment_indicator || SP
	  || style_mode || ltrim (convert (value_picture, nearest_style)));

        do mode_index = lbound (global.prevailing_style.switches, 1)
	  to hbound (global.prevailing_style.switches, 1);
	      if global.prevailing_style.switches (mode_index)
		^= styles (nearest_style).switches (mode_index) then
		    do;
		    call copy_string (mode_separator);

		    if ^global.prevailing_style.switches (mode_index) then
			  if switch_antonym_names (mode_index) = "" then
				call copy_string (
				    switch_mode_not_indicator
				    ||
				    rtrim (
				    switch_mode_names (mode_index)));

			  else
				call copy_string (
				    rtrim (
				    switch_antonym_names (mode_index)));

		    else
			  call copy_string (
			      rtrim (switch_mode_names (mode_index)));
		    end;
        end;

        do mode_index = lbound (global.prevailing_style.values, 1)
	  to hbound (global.prevailing_style.values, 1);
	      if global.prevailing_style.values (mode_index)
		^= styles (nearest_style).values (mode_index) then
		    call copy_string (mode_separator
		        || rtrim (value_mode_names (mode_index))
		        ||
		        ltrim (
		        convert (value_picture,
		        global.prevailing_style.values (mode_index))));
        end;

        call copy_string (SP || "*/" || NL);

        return;

/* Copy a string into the output segment. */

copy_string:
        procedure (string);

        declare string		char (*);	      /* (Input) string to copy into the output segment */

        substr (output_string, P_copy_position, length (string)) = string;
        P_copy_position = P_copy_position + length (string);
        end copy_string;

        end record_style;

        end format_pl1_record_style_;




		    format_pl1_stmt_type_.pl1       08/10/84  0951.5re  08/10/84  0947.2      253746



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

/* DESCRIPTION:

   Produce a list of statements from a list of tokens.  The token type
   assigned by format_pl1_lex_ is not based upon the context of the token.
   For example, format_pl1_lex_ assigns "-" the token type minus.  This token
   may be a prefix_minus token depending upon the context.  This procedure
   uses contextual information to make sure the token type is correct.  The
   steps are:

   1) Find the end of condition prefix lists, if any.
   2) Find the end of label prefix lists, if any, and fix up the token types.
   3) Figure out the type of the next statement.
   4) Find the end of the statement.
   5) Fix up the token types in the statement.

   Maintenance Instructions:

   To add another token type:

   1) If necesary, change fix_up_tokens to recognize the context in
   which this token occurs and change an existing token type to the
   new one.

   To add another PL/I statement:

   1) Add a statement type declaration to format_pl1_dcls.incl.pl1.
   2) Add entries to the is_independent_statement, is macro_whitespace,
   and is_macro_statement arrays in format_pl1_dcls.incl.pl1.
   3) Change statement_type to recognize the new statement.  This
   includes adding entries to the keyword, s_type, and
   paren_not_allowed arrays.
   4) If the statement does not end with a semicolon, change
   find_end_of_statement.
   5) If the statement requires certain token types be changed in order
   to be formatted properly, change fix_up_tokens.

   To add another macro:

   1) Add a statement type declaration that starts with "percent_" to
   format_pl1_dcls.incl.pl1.
   2) Add entries to the is_independent_statement, is_macro_statement,
   and is_macro_whitespace array in format_pl1_dcls.incl.pl1.
   3) Change percent_statement_type to recognize the new macro.
   4) If the macro does not end with a semicolon, change
   find_end_of_statement.
   5) If the macro requires certain token types be changed in order to
   be formatted properly, change fix_up_tokens.

*/

/* HISTORY:
   Written by Paul Green, 11/05/77.

   Modified:
   12/10/78 by Monte Davidoff:  Removed from format_pl1_.
   06/05/84 by R. Michael Tague:  To handle all legal pmac % statements.
*/

/* format: style5 */
format_pl1_stmt_type_:
        procedure (P_temp_segs);

        declare P_temp_segs		(*) pointer;    /* (Input) array of temporary segment pointers */

/* automatic */

        declare stmtx		fixed binary;   /* index into stmt */

/* builtin */

        declare (divide, hbound, index, lbound, length, size, substr, unspec)
				builtin;

%include format_pl1_dcls;

/* program */

        temp_segs (*) = P_temp_segs (*);
        global.n_stmts = 0;

        unspec (stmt (1)) = ""b;		      /* build dummy first stmt */
        stmt (1).type = unknown_statement;
        stmt (1).subtype = subtype_none;
        stmt (1).start = 1;
        stmt (1).end = 1;
        stmtx = 1;

        begin;
	      declare tokenx	        fixed binary;

	      tokenx = 2;
	      do while (tokenx <= global.n_tokens);
		    call type_the_prefix_lists (tokenx);

		    if tokenx <= global.n_tokens then
			  call type_one_statement (tokenx);
	      end;
        end;

        if stmtx >= hbound (stmt, 1) then
	      call error (4, "Too many statements.", (stmt (stmtx).start));

        unspec (stmt (stmtx + 1)) = ""b;	      /* build dummy last stmt */
        stmt (stmtx + 1).type = unknown_statement;
        stmt (stmtx + 1).subtype = subtype_none;
        stmt (stmtx + 1).start = global.n_tokens + 1;
        stmt (stmtx + 1).end = global.n_tokens + 1;

unrecoverable_error:
        global.n_stmts = stmtx;

        return;

type_the_prefix_lists:
        procedure (tokenx);

        declare tokenx		fixed binary;   /* (Updated) current token */

        declare label		bit (1) aligned;
        declare labelx		fixed binary;
        declare prefix_start		fixed binary;

/* condition prefix list */

        prefix_start = tokenx;
        do while (token (tokenx).type = left_parn);
	      tokenx = tokenx + 1;

	      if token (tokenx).type = identifier then
		    tokenx = tokenx + 1;

	      else    if token (tokenx).type ^= percent then
		    call error (3,
		        "Missing identifier in condition prefix list.",
		        tokenx);

	      do while (token (tokenx).type = comma);
		    tokenx = tokenx + 1;

		    if token (tokenx).type = identifier then
			  tokenx = tokenx + 1;

		    else	  if token (tokenx).type ^= percent then
			  call error (3,
			      "Missing identifier in condition prefix list."
			      , tokenx);
	      end;

	      if token (tokenx).type = right_parn then
		    tokenx = tokenx + 1;

	      else    if token (tokenx).type ^= percent then
		    call error (3,
		        "Missing right parenthesis in condition prefix list."
		        , tokenx);

	      if token (tokenx).type = colon then
		    tokenx = tokenx + 1;

	      else    if token (tokenx).type ^= percent then
		    call error (3,
		        "Missing colon after condition prefix list.",
		        tokenx);
        end;

        if tokenx > prefix_start then
	      call make_stmt (condition_prefix_list, subtype_none,
		prefix_start, tokenx - 1);

/* label prefix list */

        prefix_start = tokenx;
        label = "1"b;
        do while (token (tokenx).type = identifier & label);
	      labelx = tokenx + 1;

	      if token (labelx).type = left_parn then
		    do;
		    labelx = labelx + 1;

		    if token (labelx).type = plus
		        | token (labelx).type = minus then
			  labelx = labelx + 1;

		    if token (labelx).type = dec_integer
		        |
		        may_be_percent_replace_label_prefix (tokenx, labelx)
		        then
			  do;
			  labelx = labelx + 1;

			  if token (labelx).type = right_parn then
				labelx = labelx + 1;
			  else
				label = "0"b;
			  end;

		    else
			  label = "0"b;
		    end;

	      if token (labelx).type = colon & label then
		    do tokenx = tokenx to labelx;
			  if token (tokenx).type = plus then
				token (tokenx).type = prefix_plus;

			  else	if token (tokenx).type = minus then
				token (tokenx).type = prefix_minus;
		    end;

	      else
		    label = "0"b;
        end;

        if tokenx > prefix_start then
	      call make_stmt (label_prefix_list, subtype_none, prefix_start,
		tokenx - 1);

        return;

/* Label prefixes have the form "id ( [+|-] dec_integer ) :".  The %replace
   macro introduces the possibility that the dec_integer may be an identifier
   that is replaced by a dec_integer.  "id ( id ) :" can't always be formatted
   as a label prefix since "else ( overflow ) :" is ambiguous.  This could be
   an else clause with a condition prefix, rather than a label array named
   "else" with a %replace identifier named "overflow".  This procedure allows
   label prefixes of the form "id ( id ) :" unless the label array is "else"
   and the subscript is a condition prefix list condition name.
*/
may_be_percent_replace_label_prefix:
        procedure (label_token, subscript_token) returns (bit (1) aligned);

        declare label_token		fixed binary;   /* (Input) index of label name token */
        declare subscript_token	fixed binary;   /* (Input) index of subscript token */

        declare cnx			fixed binary;
        declare subscript_start_pos	fixed binary (21);

        declare label_string		char (token (label_token).string_size)
				based (token (label_token).string_ptr);
        declare subscript_string	char (token (subscript_token)
				.string_size)
				based (token (subscript_token)
				.string_ptr);

        declare condition_name	(17) char (16) internal static
				options (constant)
				initial ("conversion", "conv",
				"fixedoverflow", "fofl", "overflow",
				"ofl", "size", "stringrange", "strg",
				"stringsize", "strz", "subscriptrange",
				"subrg", "underflow", "ufl",
				"zerodivide", "zdiv");
        declare disable_prefix	char (2) internal static
				options (constant) initial ("no");

        if token (subscript_token).type ^= identifier then
	      return ("0"b);

        if label_token + 2 ^= subscript_token | label_string ^= "else" then
	      return ("1"b);

        if index (subscript_string, disable_prefix) = 1 then
	      subscript_start_pos = length (disable_prefix) + 1;
        else
	      subscript_start_pos = 1;

        do cnx = lbound (condition_name, 1) to hbound (condition_name, 1)
	  while (condition_name (cnx)
	  ^= substr (subscript_string, subscript_start_pos));
        end;

        return (cnx > hbound (condition_name, 1));
        end may_be_percent_replace_label_prefix;

        end type_the_prefix_lists;

/* Get the type of one statement.

   If the statement contains an embedded statement, e.g.  if, else or on, then
   tokenx is left pointing to the first token of the embedded statement.
*/
type_one_statement:
        procedure (tokenx);

        declare tokenx		fixed binary;   /* (Updated) index of current token, updated to first token of
					         next statement */

        declare start		fixed binary;
        declare type		fixed binary (8);

        start = tokenx;
        type = statement_type (start);
        call find_end_of_statement (type, start, tokenx);
        call fix_up_tokens (type, start, tokenx);

        call make_stmt (type, statement_subtype (type, start, tokenx), start,
	  tokenx);

        tokenx = tokenx + 1;

        return;

statement_type:
        procedure (first_token) returns (fixed binary (8));

        declare first_token		fixed binary;   /* (Input) first token of statement */

        declare tokenx		fixed binary;
        declare keywordx		fixed binary;

        declare tokenx_token_string	char (token (tokenx).string_size)
				based (token (tokenx).string_ptr);

        declare keyword		(34) char (12) aligned internal
				static options (constant)
				initial ("alloc", "allocate", "begin",
				"call", "close", "dcl", "declare",
				"default", "delete", "dft", "do",
				"else", "end", "entry", "format",
				"free", "get", "go", "goto", "if",
				"locate", "on", "open", "proc",
				"procedure", "put", "read", "return",
				"revert", "rewrite", "signal", "stop",
				"system", "write");

        declare s_type		(34) fixed binary (8) internal
				static options (constant) initial (1,
					      /* alloc */
				1,	      /* allocate */
				3,	      /* begin */
				4,	      /* call */
				5,	      /* close */
				6,	      /* dcl */
				6,	      /* declare */
				36,	      /* default */
				8,	      /* delete */
				36,	      /* dft */
				10,	      /* do */
				11,	      /* else */
				12,	      /* end */
				13,	      /* entry */
				15,	      /* format */
				16,	      /* free */
				17,	      /* get */
				18,	      /* go */
				18,	      /* goto */
				19,	      /* if */
				20,	      /* locate */
				22,	      /* on */
				23,	      /* open */
				24,	      /* proc */
				24,	      /* procedure */
				25,	      /* put */
				26,	      /* read */
				27,	      /* return */
				28,	      /* revert */
				29,	      /* rewrite */
				30,	      /* signal */
				31,	      /* stop */
				32,	      /* system */
				35);	      /* write */

        declare paren_not_allowed	(34) bit (1) aligned internal
				static options (constant)
				initial ("1"b, "1"b, "1"b, "1"b, "1"b,
				"0"b, "0"b, "0"b, "1"b, "0"b, "1"b,
				"0"b, "1"b, "0"b, "0"b, "1"b, "1"b,
				"1"b, "1"b, "0"b, "1"b, "1"b, "1"b,
				"0"b, "0"b, "1"b, "1"b, "0"b, "1"b,
				"1"b, "1"b, "1"b, "1"b, "1"b);

/* Figure out what the next statement is. */

        tokenx = first_token;

        if token (tokenx).type = semi_colon then
	      return (null_statement);

        if token (tokenx).type = percent then
	      return (percent_statement_type (tokenx));

        if token (tokenx).type ^= identifier then
	      do;
	      if global.include_file & stmtx = 1 then
		    call error (1,
		        "Unknown statement at beginning of include file.",
		        tokenx);

	      else    if stmt (stmtx).type = percent_statement then
		    call error (1, "Unknown statement after macro.", tokenx)
		        ;

	      else
		    call error (3, "Unknown statement.", tokenx);

	      return (unknown_statement);
	      end;

/* statement starts with an identifier */

        if token (tokenx + 1).type = assignment
	  | token (tokenx + 1).type = arrow
	  | token (tokenx + 1).type = period | token (tokenx + 1).type = comma
	  then
	      return (assignment_statement);

        do keywordx = lbound (keyword, 1) to hbound (keyword, 1)
	  while (keyword (keywordx) ^= tokenx_token_string);
        end;

        if keywordx > hbound (keyword, 1) then
	      return (assignment_statement);

        if token (tokenx + 1).type = left_parn then
	      if paren_not_allowed (keywordx) then
		    return (assignment_statement);
	      else
		    ;

        else
	      return (s_type (keywordx));

/* statement starts with "keyword (" */

        call skip_parens (tokenx);

        if token (tokenx).type = arrow | token (tokenx).type = period then
	      return (assignment_statement);

        if token (tokenx).type = comma then
	      if s_type (keywordx) = declare_statement then
		    do;
		    do while (token (tokenx).type ^= semi_colon
		        & token (tokenx).type ^= assignment);
			  if token (tokenx).type = left_parn then
				call skip_parens (tokenx);
			  else
				tokenx = tokenx + 1;
		    end;

		    if token (tokenx).type = assignment then
			  return (assignment_statement);
		    else
			  return (declare_statement);
		    end;

	      else
		    return (assignment_statement);

        if token (tokenx).type = assignment then
	      if s_type (keywordx) ^= if_statement then
		    return (assignment_statement);
	      else
		    ;

        else
	      return (s_type (keywordx));

/* statement starts with "if ( ... ) =" */

        call find_then (first_token, tokenx);

        if token (tokenx).type = identifier then
	      return (if_statement);

        return (assignment_statement);

percent_statement_type:
        procedure (first_token) returns (fixed binary (8));

        declare first_token		fixed binary;   /* (Input) first token of statement */
        declare first_token_string	char (token (first_token).string_size)
				based (token (first_token).string_ptr);

        if first_token_string = "%" then
	      return (percent_statement);
        else    if first_token_string = "%abort" then
	      return (percent_abort_statement);
        else    if first_token_string = "%default" then
	      return (percent_default_statement);
        else    if first_token_string = "%else" then
	      return (percent_else_statement);
        else    if first_token_string = "%elseif" then
	      return (percent_elseif_statement);
        else    if first_token_string = "%endif" then
	      return (percent_endif_statement);
        else    if first_token_string = "%error" then
	      return (percent_error_statement);
        else    if first_token_string = "%if" then
	      return (percent_if_statement);
        else    if first_token_string = "%include" then
	      return (percent_include_statement);
        else    if first_token_string = "%INCLUDE" then
	      return (percent_include_statement);
        else    if first_token_string = "%page" then
	      return (percent_page_statement);
        else    if first_token_string = "%print" then
	      return (percent_print_statement);
        else    if first_token_string = "%replace" then
	      return (percent_replace_statement);
        else    if first_token_string = "%set" then
	      return (percent_set_statement);
        else    if first_token_string = "%skip" then
	      return (percent_skip_statement);
        else    if first_token_string = "%warn" then
	      return (percent_warn_statement);
        else
	      do;
	      call error (3, "Unknown macro.", first_token);
	      return (percent_statement);
	      end;
        end percent_statement_type;

        end statement_type;

find_end_of_statement:
        procedure (stmt_type, first_token, last_token);

        declare stmt_type		fixed binary (8);
					      /* (Input) type of the statement */
        declare first_token		fixed binary;   /* (Input) first token of the statement */
        declare last_token		fixed binary;   /* (Output) last token of the statement */

        declare last_token_string	char (token (last_token).string_size)
				based (token (last_token).string_ptr);

        if stmt_type = on_statement then
	      do;
	      last_token = first_token + 1;

	      call condition_name (last_token);
	      do while (token (last_token).type = comma);
		    last_token = last_token + 1;
		    call condition_name (last_token);
	      end;

	      if token (last_token).type = identifier then
		    if last_token_string = "snap" then
			  if is_snap (last_token) then
				last_token = last_token + 1;

	      last_token = last_token - 1;
	      end;

        else    if stmt_type = if_statement then
	      do;
	      last_token = first_token;
	      call find_then (first_token, last_token);

	      if token (last_token).type ^= identifier
		& token (last_token).type ^= percent then
		    call error (3, "Missing ""then"" in if statement.",
		        first_token);

	      if token (last_token).type = percent
		| token (last_token).type = no_token then
		    last_token = last_token - 1;
	      end;

        else    if stmt_type = percent_if_statement
		| stmt_type = percent_elseif_statement then
	      begin;
	      declare found_percent_then      bit (1) aligned;

	      do last_token = first_token + 1 by 1
		while (^is_end_of_statement (token (last_token).type));
	      end;

	      if token (last_token).type = percent then
		    found_percent_then = last_token_string = "%then";
	      else
		    found_percent_then = "0"b;

	      if ^found_percent_then then
		    do;
		    call error (3,
		        "Missing ""%then"" in %if or %elseif macro.",
		        first_token);

		    if token (last_token).type ^= semi_colon then
			  last_token = last_token - 1;
		    end;
	      end;

        else    if stmt_type = else_clause
		| stmt_type = percent_else_statement
		| stmt_type = percent_endif_statement then
	      last_token = first_token;

        else
	      do last_token = first_token by 1
		while (token (last_token).type ^= semi_colon
		& token (last_token + 1).type ^= percent
		& token (last_token + 1).type ^= no_token);
	      end;

        return;

condition_name:
        procedure (tokenx);

        declare tokenx		fixed binary;   /* (Updated) current token position */

        if token (tokenx).type = identifier then
	      do;
	      tokenx = tokenx + 1;

	      if token (tokenx).type = left_parn then
		    begin;
		    declare tx		      fixed binary;

		    tx = tokenx;
		    call skip_parens (tx);

		    if token (tx).type ^= colon then
			  tokenx = tx;
		    end;
	      end;

        else    if token (last_token).type ^= percent then
	      call error (3, "Missing identifier in condition name.", tokenx);
        end condition_name;

is_snap:
        procedure (snap_token) returns (bit (1) aligned);

        declare snap_token		fixed binary;   /* (Input) token containing "snap" */

        declare tokenx		fixed binary;

        tokenx = snap_token + 1;

        if token (tokenx).type = identifier | token (tokenx).type = semi_colon
	  then
	      return ("1"b);

        if token (tokenx).type ^= left_parn then
	      return ("0"b);

        call skip_parens (tokenx);

        return (token (tokenx).type = colon);
        end is_snap;

        end find_end_of_statement;

fix_up_tokens:
        procedure (stmt_type, first_token, last_token);

        declare stmt_type		fixed binary (8);
					      /* (Input) type of the current statement */
        declare first_token		fixed binary;   /* (Input) first token of the statement */
        declare last_token		fixed binary;   /* (Input) last token of the statement */

        declare tokenx		fixed binary;
        declare paren_depth		fixed binary;
        declare skip_assignment	bit (1) aligned;

        declare tokenx_token_string	char (token (tokenx).string_size)
				based (token (tokenx).string_ptr);

        if stmt_type = if_statement then
	      do;
	      skip_assignment = "0"b;
	      token (first_token).type = keyword_token;

	      if token (last_token).type = identifier then
		    token (last_token).type = keyword_token;
	      end;

        else    if stmt_type = assignment_statement then
	      skip_assignment = "1"b;

        else    if stmt_type = do_statement then
	      do;
	      tokenx = first_token + 1;

	      if tokenx >= last_token then
		    skip_assignment = "0"b;	      /* <noniterative do> */
	      else
		    do;
		    skip_assignment = "1"b;

		    if token (tokenx).type = identifier then
			  if tokenx_token_string = "while"
			      & token (tokenx + 1).type = left_parn then
				do;
				tokenx = tokenx + 1;
				call skip_parens (tokenx);

				if tokenx >= last_token then
				        skip_assignment = "0"b;
					      /* <do while> */
				end;

		    if skip_assignment	      /* <multiple do> */
		        then
			  do tokenx = tokenx + 1 to last_token - 1;
				if token (tokenx).type = identifier then
				        if tokenx_token_string = "while"
					  | tokenx_token_string = "to"
					  | tokenx_token_string = "by"
					  | tokenx_token_string
					  = "repeat" then
					      if could_end_an_expression
						(token (tokenx - 1)
						.type) then
						    token (tokenx)
						        .type =
						        keyword_token
						        ;
					      else
						    ;
				        else
					      ;

				else    if token (tokenx).type
					  = left_parn then
				        do;
				        call skip_parens (tokenx);
				        tokenx = tokenx - 1;
				        end;
			  end;
		    end;
	      end;

        else    if stmt_type = percent_replace_statement then
	      do;
	      tokenx = first_token + 2;
	      if tokenx <= last_token then
		    if token (tokenx).type = identifier then
			  if tokenx_token_string = "by" then
				token (tokenx).type = keyword_token;
	      end;

        else    if stmt_type = percent_set_statement
		| stmt_type = percent_default_statement then
	      do;
	      tokenx = first_token + 2;
	      if tokenx <= last_token then
		    if token (tokenx).type = identifier then
			  if tokenx_token_string = "to" then
				token (tokenx).type = keyword_token;
	      end;

        else
	      skip_assignment = "0"b;

        paren_depth = 0;
        do tokenx = first_token to last_token;
	      if token (tokenx).type = left_parn then
		    paren_depth = paren_depth + 1;

	      else    if token (tokenx).type = right_parn then
		    paren_depth = paren_depth - 1;

	      else    if token (tokenx).type = assignment then
		    if paren_depth = 0 & skip_assignment then
			  skip_assignment = "0"b;
		    else
			  token (tokenx).type = eq;

	      else    if token (tokenx).type = comma
		        & stmt_type = assignment_statement
		        & skip_assignment & paren_depth = 0 then
		    token (tokenx).type = target_comma;

	      else    if token (tokenx).type = percent
		        & length (tokenx_token_string) > length ("%") then
		    token (tokenx).type = keyword_token;

	      else    if token (tokenx).type = plus
		        | token (tokenx).type = minus then
		    if ^could_end_an_expression (token (tokenx - 1).type)
		        then
			  if token (tokenx).type = minus then
				token (tokenx).type = prefix_minus;
			  else
				token (tokenx).type = prefix_plus;
        end;
        end fix_up_tokens;

find_then:
        procedure (first_token, tokenx);

        declare first_token		fixed binary;   /* (Input) first token of the statement */
        declare tokenx		fixed binary;   /* (Updated) current token on input,
					         then token or end of statement on output */

        declare tokenx_token_string	char (token (tokenx).string_size)
				based (token (tokenx).string_ptr);

        do tokenx = tokenx + 1 by 1
	  while (^is_end_of_statement (token (tokenx).type));
	      if token (tokenx).type = identifier then
		    if tokenx_token_string = "then" then
			  if could_end_an_expression (token (tokenx - 1)
			      .type) & first_token < tokenx - 1 then
				return;
			  else
				;
		    else
			  ;

	      else    if token (tokenx).type = left_parn then
		    do;
		    call skip_parens (tokenx);
		    tokenx = tokenx - 1;
		    end;
        end;
        end find_then;

skip_parens:
        procedure (tokenx);

        declare tokenx		fixed binary;   /* (Updated) on input, index of left_parn token,
					         on output, index of end of statement token or token
					         after matching right_parn, whichever comes first */

        declare paren_depth		fixed binary;

        paren_depth = 1;
        do tokenx = tokenx + 1 by 1
	  while (paren_depth > 0 & ^is_end_of_statement (token (tokenx).type))
	  ;
	      if token (tokenx).type = left_parn then
		    paren_depth = paren_depth + 1;

	      else    if token (tokenx).type = right_parn then
		    paren_depth = paren_depth - 1;
        end;
        end skip_parens;

could_end_an_expression:
        procedure (type) returns (bit (1) aligned);

        declare type		fixed binary (8) unaligned;
					      /* (Input) token type which might end an expression */

        return (type = identifier | type = isub | type = right_parn
	  | min_constant_token <= type & type <= max_constant_token);
        end could_end_an_expression;

is_end_of_statement:
        procedure (type) returns (bit (1) aligned);

        declare type		fixed binary (8) unaligned;
					      /* (Input) token type which might end a statement */

        return (type = semi_colon | type = percent | type = no_token);
        end is_end_of_statement;

statement_subtype:
        procedure (stmt_type, first_token, last_token)
	  returns (fixed binary (8));

        declare stmt_type		fixed binary (8);
					      /* (Input) type of the statement */
        declare first_token		fixed binary;   /* (Input) first token of the statement */
        declare last_token		fixed binary;   /* (Input) last token of the statement */

        if stmt_type = do_statement then
	      if token (last_token).type = semi_colon
		& last_token = first_token + 1 then
		    return (subtype_noniterative_do);

        return (subtype_none);
        end statement_subtype;

        end type_one_statement;

/* Make a stmt entry. */

make_stmt:
        procedure (type, subtype, start, end);

        declare type		fixed binary (8);
					      /* (Input) statement type */
        declare subtype		fixed binary (8);
					      /* (Input) statement subtype */
        declare start		fixed binary;   /* (Input) first token of statement */
        declare end			fixed binary;   /* (Input) last token of statement */

        if stmtx >= hbound (stmt, 1) then
	      call error (4, "Too many statements.", start);

        stmtx = stmtx + 1;
        unspec (stmt (stmtx)) = ""b;
        stmt (stmtx).type = type;
        stmt (stmtx).subtype = subtype;
        stmt (stmtx).start = start;
        stmt (stmtx).end = end;
        end make_stmt;

/* Print an error message. */

error:
        procedure (severity, error_string, tokenx);

        declare severity		fixed binary (35);
					      /* (Input) severity of the error */
        declare error_string		char (*);	      /* (Input) error message */
        declare tokenx		fixed binary;   /* (Input) token on which error occurred */

        call format_pl1_error_ (temp_segs (*), severity, error_string,
	  (token (tokenx).string_ptr));

        if severity >= 4 then
	      goto unrecoverable_error;
        end error;

        end format_pl1_stmt_type_;




		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
