



		    PNOTICE_compose.alm             04/23/85  1059.2r w 04/17/85  1104.0        3555



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

	aci	"C1DF0M0B0000"
	aci	"C2DF0M0B0000"
	aci	"C3DF0M0B0000"
	end




		    comp_.pl1                       04/23/85  1059.2rew 04/23/85  0908.5      225486



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

/* compose subroutine to process input files */

/* This routine is recursive since the controls processor must call it
   to process inserted files. */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_:
  proc;

/* LOCAL STORAGE */

    dcl ascii_width	   fixed bin;	/* width of ctl line in chars */
    dcl blank_count	   fixed bin init (0);
    dcl BREAK	   bit (1) static options (constant) init ("1"b);
    dcl break_type	   fixed bin;
    dcl CBARS	   bit (1) static options (constant) init ("1"b);
				/* count of blanks inserted */
    dcl char_index	   (1020) fixed bin (9)
				/* for width measurement */
		   unsigned unaligned based (char_index_ptr);
    dcl char_index_ptr ptr;
    dcl col_space	   fixed bin (31);	/* to advance table columns */
    dcl EMPTY	   bit (1) static options (constant) init ("1"b);
    dcl endinput	   bit (1);	/* local copy of shared flag */
    dcl EPILOGUE	   fixed bin static options (constant) init (4);
    dcl ercd	   fixed bin (35);	/* error code */
    dcl fill_count	   fixed bin;	/* tab fill count */
    dcl head_used	   fixed bin (31);	/* space taken by page header */
    dcl htab_shift	   char (7) based (DCxx_p);
				/* ctl string for htabbing */
    dcl 1 htab_space   like dclong_val; /* for inserting htab WS */
    dcl (i, j)	   fixed bin;	/* working index and string index */
    dcl (ii, jj, k)	   fixed bin;	/* working index */
				/* for htab measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl strndx	   fixed bin;	/* working line scan index */
    dcl TEXT	   bit (1) static options (constant) init ("1"b);
    dcl text_added	   bit (1) aligned; /* text added to output buffer */
    dcl text_flag	   bit (1);	/* current block is in-line text */
    dcl TRIM	   bit (1) static options (constant) init ("1"b);
    dcl txtwidth	   fixed bin (31) init (0);
				/* measured text width */

/* EXTERNAL STORAGE */

    dcl (addrel, before, bin, copy, divide, index, length, max, min, mod, null,
        rtrim, search, substr)
		   builtin;
    dcl (comp_abort, end_output)
		   condition;

    dcl iox_$put_chars entry (ptr, ptr, fixed (24), fixed (35));

    if shared.bug_mode
    then call ioa_ ("comp_: (^d ^d ^a pass=^d)", call_stack.index,
	    insert_data.index, shared.input_filename, shared.pass_counter);

    htab_space.mark = DC1;
    htab_space.type = type_slx;	/* setup for htabbing */
    htab_space.leng = 4;
    DCxx_p = addr (htab_space);
    call_box_ptr = call_stack.ptr (call_stack.index);
				/* set ctl line overlay pointer */
    char_index_ptr = addrel (ctl.ptr, 1);

    call_box.lineno = 0;		/* clear line counter for this file */
    if call_stack.index = 0		/* set source file lineno */
    then call_box.lineno0 = 0;
    else call_box.lineno0 = call_box0.lineno;

    endinput = shared.end_input;	/* copy shared flag for recursion */
    shared.end_input = "0"b;		/* and reset it */
    on end_output goto end_output_;	/* end_output signal chain ends here */

read:
    if shared.end_input		/* did somebody signal? */
    then goto end_input_;
    if shared.end_output
    then goto end_output_;		/**/
				/* read an input line */
    call comp_read_$line (call_stack.ptr (call_stack.index), ctl_line, "0"b);
    ctl.info = call_box.info;

    if shared.end_input		/* input EOF? */
    then goto end_input_;

    if shared.literal_mode		/* a literal block? */
    then
      do;
        if shared.lit_count = 0	/* if thats all, reset the flag */
        then shared.literal_mode = "0"b;
        else			/* count lines */
	   shared.lit_count = shared.lit_count - 1;
      end;

    ctl.DVctl = "0"b;		/* reset device ctl flag */
    ctl.font = ctl.cur.font;		/* propagate any font changes */

    if index (ctl_line, "	") ^= 0	/* if any HTs in the line */
    then
      do;
        ascii_width = 0;		/* set up loop counters */
        i, j = 1;			/* and control indices */
        do while (j > 0);		/* as long as HTs are found */
	j = index (substr (ctl_line, i), "	");
				/* look for an HT */

	if j > 0			/* if one was found */
	then
	  do;

	    if j > 1		/* measure preceding text */
	    then
	      do;
	        do k = i to i + j - 2;
		if char_index (k) >= 32 & char_index (k) <= 126
		then ascii_width = ascii_width + 1;
		else if char_index (k) = 8
		then ascii_width = ascii_width - 1;
	        end;
	        ii = i + j - 1;	/* position of HT in line */
	      end;
	    else ii = i;		/* HT is the next character */

	    blank_count =		/* blanks to next Multics tab */
	         10 - mod (ascii_width, 10);
	    ctl_line = substr (ctl_line, 1, ii - 1) ||
				/* insert them */
	         copy (" ", blank_count) || substr (ctl_line, ii + 1);
	    i = ii + blank_count;	/* adjust counters */
	    ascii_width = ascii_width + blank_count;
	  end;
        end;
      end;

    if shared.table_mode
    then
      do;				/* record current table column */
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        tblcolndx = tblfmt.ccol;
        tblcolptr = tblfmt.colptr (tblcolndx);
        if tblcolndx = 0
        then break_type = block_break;
        else break_type = format_break;
      end;

    text_added = "1"b;		/* preset text flag */

    if length (ctl_line) = 0		/* special handling for null lines */
    then
      do;
null_line:
        if shared.blkptr ^= null	/* if there is an active block */
        then
	do;
	  if text.parms.title_mode	/* a title block? */
	  then
	    do;			/* count lines */
	      text.hdr.eqn_line_count = text.hdr.eqn_line_count - 1;
				/* if thats all, reset flag */
	      if text.hdr.eqn_line_count = 0
	      then text.parms.title_mode = "0"b;
	    end;			/**/
				/* is there a header pending? */
	  if text.parms.hdrptr ^= null & ^shared.inserting_hfc
	  then call comp_title_block_ (text.parms.hdrptr);
	end;

        call comp_space_ (current_parms.linespace, shared.blkptr, TEXT, ^TRIM,
	   CBARS, "0"b);
        if shared.table_mode
        then call comp_break_ (break_type, -1);
        else if ^text.parms.art
        then call comp_break_ (block_break, 0);

        goto read;
      end;			/**/
				/* indented controls? then */
				/* find first nonblank */
    if shared.indctl.stk (shared.indctl.ndx)
    then ctl.index = verify (ctl_line, " ");
    else ctl.index = 1;		/* else start a 1 */

/* control line? */
    if index (substr (ctl_line, ctl.index), ".") = 1
         & index (substr (ctl_line, ctl.index), ". ") ^= 1
         & substr (ctl_line, ctl.index) ^= "."
         & index (substr (ctl_line, ctl.index), ".. ") ^= 1
         & substr (ctl_line, ctl.index) ^= ".."
         & index (substr (ctl_line, ctl.index), "...") ^= 1
    then
      do;
        if ^shared.literal_mode	/* if not in literal mode */
	   | (shared.literal_mode & shared.lit_count < 0
				/* or a non-cntng literal */
	   & (ctl_line = ".bel"	/* and end literal */
	   | ctl_line = ".be"))	/* or end all */
        then
	do;
tbl_:
	  if shared.table_mode	/* table mode? */
	  then if tblfmt.context	/* and format in context mode */
	       then
	         do;		/**/
				/* if there is a column index */
		 if index ("1234567890", substr (ctl_line, 2, 1)) ^= 0
		 then
		   do;
		     ctl.index = ctl.index + 1;
				/* bad column? */
		     if bin (substr (ctl_line, ctl.index, 1))
			> tblfmt.ncols
		     then
		       do;
		         call comp_report_ (2, 0,
			    "Column undefined for this format.",
			    addr (ctl.info), ctl_line);
		         goto read;
		       end;	/**/
				/* changing? */
		     if substr (ctl_line, ctl.index, 1) = "0"
			& tblfmt.ccol ^= 10
			| substr (ctl_line, ctl.index, 1) ^= "0"
			& bin (substr (ctl_line, ctl.index, 1))
			^= tblfmt.ccol
		     then call comp_tbl_ctls_ (tac_ctl_index);
				/* assure context mode */
		     tblfmt.context = "1"b;
				/* strip column off input line */
		     if length (ctl_line) > 2
		     then ctl_line = substr (ctl_line, 3);
		     else ctl_line = "";
				/* if changing columns */
		     if tblfmt.ccol ^= tblcolndx
		     then
		       do;	/* leaving column 0? */
		         if tblcolndx = 0
		         then
			 do i = 1 to tblfmt.ncols;
			   tblfmt.colptr (i) -> tblcol.depth =
			        tblcol0.depth;
			 end;	/**/
				/* set to new column */
		         tblcolndx = tblfmt.ccol;
		         tblcolptr = tblfmt.colptr (tblcolndx);
		         ctl.font, ctl.cur.font =
			    tblcol.parms.fntstk
			    .entry (tblcol.parms.fntstk.index);

		         if shared.blkptr ^= null ()
		         then
			 do;
			   text.input.font, text.input.cur.font,
			        ctl.font, ctl.cur.font =
			        tblcol.parms.fntstk
			        .entry (tblcol.parms.fntstk.index);
			   text.input.quad, ctl.quad = tblcol.parms.quad;
			 end;
		       end;	/**/
				/* for a null line */
		     if ctl_line = ""
		     then goto null_line;
		     else goto text_;
		   end;		/**/
				/* a real control line */
		 else if substr (ctl_line, 1, 3) ^= ".ur"
		 then
		   do;		/* clean up */
		     if shared.blkptr ^= null ()
		     then if text.input_line ^= ""
			then call comp_break_ (format_break, 0);
		   end;
	         end;		/**/
				/* call control processor */
	  call comp_ctls_ (text_added);

	  if text_added & shared.table_mode & substr (ctl_line, 1, 1) = "."
	       & index ("1234567890", substr (ctl_line, 2, 1)) ^= 0
	  then if tbldata.fmt (tbldata.ndx).ptr -> tblfmt.context
	       then goto tbl_;
	end;
      end;

    if shared.table_mode & text_added	/* text line in table mode? */
    then if tblfmt.context		/* and format in context mode? */
         then
	 do;
	   tblcolndx = tblfmt.ccol;
	   if tblcolndx ^= 0	/* going back to column 0? */
	   then
	     do;			/* clean up */
	       if shared.blkptr ^= null ()
	       then if text.input_line ^= ""
		  then call comp_break_ (format_break, 0);
				/* switch to column 0 */
	       tblcolndx, tblfmt.ccol = 0;
	       tblcolptr = tblfmt.colptr (0);
	       current_parms = tblcol.parms;

	       if shared.blkptr ^= null ()
	       then
	         do;
		 text.parms = current_parms;
		 text.input.quad, ctl.quad = current_parms.quad;
	         end;		/**/
				/* advance short columns */
	       do i = 0 to tblfmt.ncols;
	         tblfmt.colptr (i) -> tblcol.depth = tblfmt.maxdepth;
	       end;
	     end;
	 end;

/* text line */
text_:
    if text_added			/* if there's text to be added */
    then
      do;
        if shared.blkptr = null ()	/* get a text block if one is needed */
        then
	do;			/**/
				/* head page if needed */
	  if ^option.galley_opt & ^page.hdr.headed & page.hdr.col_index >= 0
	  then call comp_head_page_ (head_used);

	  call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	       addr (current_parms), ^EMPTY);
	end;

        if (text.blktype = "oh" | text.blktype = "eh" | text.blktype = "of"
	   | text.blktype = "ef" | text.blktype = "tf"
	   | text.blktype = "th" | "0"b)
				/* NAMED BLOCKS REPLACE "0"b */
        then text_flag = "0"b;
        else text_flag = "1"b;	/**/
				/* is there a header pending? */
        if text.parms.hdrptr ^= null & ^shared.inserting_hfc
        then if ^text.parms.title_mode
	   then call comp_title_block_ (text.parms.hdrptr);

        text.input.lmarg = text.parms.left.indent - text.parms.left.undent;
        text.input.rmarg =
	   text.parms.measure - text.parms.right.indent
	   + text.parms.right.undent;
        text.input.net = text.input.rmarg - text.input.lmarg;

        if shared.table_mode & ^text.parms.footnote
        then
	do;
	  text.input.lmarg = text.input.lmarg + tblcol.margin.left;
	  text.input.rmarg = text.input.rmarg + tblcol.margin.left;
	end;

        if ctl_line = ""		/* a null line */
        then goto null_line;		/**/
				/* if a filled block with leading */
        if text.parms.fill_mode	/* white space & there are leftovers */
        then if index (" ", substr (ctl_line, 1, 1)) ^= 0
	        & length (text.input_line) > 0
	   then
	     do;
	       call comp_break_ (format_break, 0);
	       if text.input.oflo & ^text.parms.keep & text.hdr.colno >= 0
		  & ^shared.table_mode
	       then call comp_break_ (need_break, -2);

	       if shared.end_output
	       then goto return_;
	     end;			/**/
				/* any active htabs? */
        if shared.htab_ptr ^= null ()
        then if htab.chars ^= ""
	   then call do_htabs;

        if ctl_line = ""		/* if its empty after all that */
        then goto null_line;

/* title block */
        if text.parms.title_mode
        then
	do;			/* count lines */
	  text.hdr.eqn_line_count = text.hdr.eqn_line_count - 1;
				/* if thats all, reset flag */
	  if text.hdr.eqn_line_count = 0
	  then text.parms.title_mode = "0"b;
				/* a <title> line? */
	  if index (ctl_line, shared.ttl_delim) = 1
	  then
	    do;			/* clean up leftovers */
	      if length (text.input_line) > 0
	      then call comp_break_ (format_break, 0);

	      text.input_line = ctl_line;
	      text.input.info = ctl.info;

/****	      if text.hdr.colno >= 0
/****	      then */
	      call comp_hft_ctls_$title (shared.blkptr, addr (text.input),
		 text.input_line, text.parms.linespace);
/****	      else call comp_util_$add_text (shared.blkptr, "0"b, "0"b, "0"b,
/****		 (text.input.quad ^= quadl), ^text.input.art, "0"b,*/
/****		      "0"b,	/* text.input.oflo, */
/****		      addr (text.input));*/

	      text.input.art = text.input.art | text.parms.art;
	      if text.input.art	/* if an artwork line */
	      then
	        do;
		text.hdr.art_count = text.hdr.art_count - 1;
		if text.hdr.art_count = 0
		then current_parms.art, text.parms.art = "0"b;
	        end;
	    end;

	  else goto plain;		/* free line in a formatted block */
	end;

/* column aligned table? */
        else if shared.table_mode & tblcol.align.posn > 0
        then
	do;			/* find the string */
	  strndx = index (ctl_line, tblcol.align.str);

	  if strndx > 0		/* if its there */
	  then
	    do;			/* measure preceding text */
	      unspec (meas1) = "0"b;
	      call comp_measure_ (substr (ctl_line, 1, strndx - 1),
		 addr (text.input.font), "0"b, text.input.art,
		 text.input.quad, 0, addr (meas1), addr (meas2),
		 addr (ctl.info));	/* add to left margin undent */
	      text.parms.left.undent =
		 text.parms.left.undent + meas1.width + meas1.avg;
	      text.input.lmarg =
		 text.input.lmarg + text.parms.left.indent
		 - text.parms.left.undent;
	      text.input.net = text.input.rmarg - text.input.lmarg;
	      text.input.quad = quadl;
	    end;
	  goto plain;
	end;

/* plain text */
        else
	do;
plain:
	  text.input.art = text.input.art | text.parms.art;
	  if text.input.art		/* if an artwork line */
	  then
	    do;
	      text.hdr.art_count = text.hdr.art_count - 1;
	      if text.hdr.art_count = 0
	      then current_parms.art, text.parms.art = "0"b;
	    end;			/**/
				/* if not building a formatted block */
	  if ^text.parms.title_mode	/* insert pending text heading */
	       & text.parms.hdrptr ^= null () & ^shared.inserting_hfc
	  then if text.parms.hdrptr -> hfcblk.hdr.count > 0
	       then call comp_title_block_ (text.parms.hdrptr);

	  if ^ctl.DVctl
	  then ctl.linespace = text.parms.linespace;
	  else
	    do;
	      text_flag = "0"b;
	      if ctl_line ^= wait_signal
	      then ctl.linespace = 0;
	    end;

/* if filling */
	  if text.parms.fill_mode & length (ctl_line) > 0
	       & ^text.parms.htab_mode
	  then
	    do;
	      call comp_fill_;
	      if shared.end_output
	      then goto return_;
	    end;

/* not filling */
	  else
	    do;
	      if (text.input.quad & just) | text.parms.htab_mode
	      then text.input.quad = quadl;

	      if ctl.DVctl
	      then text.input.linespace = 0;

	      if text.input.hanging
	      then
	        do;
		unspec (meas1) = "0"b;
		call comp_measure_ (ctl_line, addr (text.input.font), "0"b,
		     text.input.art, text.input.quad, 0, addr (meas1),
		     addr (meas2), addr (ctl.info));
		if meas1.width + meas1.avg <= text.parms.left.undent
		then text.input.linespace = 0;
		else text.input.linespace = text.parms.linespace;
	        end;

	      text.input_line = ctl_line;
	      text.input.info = ctl.info;
	      text.input.cbar = text.parms.cbar;
	      text.parms.cbar.del = "0"b;

	      call comp_util_$add_text (shared.blkptr,
		 (text.input.quad ^= quadl), ^text.input.art, "0"b,
		 text.input.oflo, addr (text.input));
	      text.input_line = "";

	      if text.input.oflo & text.hdr.colno >= 0
		 & ^(shared.table_mode | text.parms.keep | text.parms.art)
	      then call comp_break_ (need_break, -2);

	      if shared.end_output
	      then goto end_output_;

	      if shared.blkptr ^= null/* is there still an active block? */
	      then
	        do;
		text.input_line = "";
				/* erase */
				/* undents are used */
		text.parms.left.undent, text.parms.right.undent = 0;
		text.input.hanging, text.input.und_prot, ctl.hanging =
		     "0"b;
		text.input.linespace, ctl.linespace = text.parms.linespace;

		text.hdr.nofill_count = text.hdr.nofill_count - 1;
		if text.hdr.nofill_count = 0
		then call comp_format_ctls_ (fin_ctl_index);
	        end;
	    end;
	end;
      end;
    goto read;
%page;
end_input_:
    if shared.bug_mode
    then call ioa_ ("end_input: (^d ^d ^a)", call_stack.index,
	    insert_data.index, shared.input_filename);

    if call_stack.index > 0
    then
      do;
        shared.end_input = endinput;	/* restore the shared flag */
        goto return_;
      end;
%page;
end_output_:
    if option.db_line_end = -1	/* debugging end_output? */
    then shared.bug_mode = "1"b;

    if shared.bug_mode
    then call ioa_ ("end_output: (^a,^d)", shared.source_filename, ctl.lineno);

    if shared.if_nest.ndx > 0		/* open if nest? */
    then
      do;
        call comp_report_$ctlstr (2, 0,
	   addr (shared.if_nest (shared.if_nest.ndx).info),
	   shared.if_nest (shared.if_nest.ndx).line,
	   "Unterminated conditional execution (if) group.");
        shared.if_nest.ndx = 0;
      end;

    ctl_line = "";			/* erase a possible control line */
    if option.galley_opt		/* force the flag in galley */
    then shared.end_output = "1"b;

    if shared.blkptr ^= null ()	/* if there is a block */
    then
      do;
        if text.parms.title_mode	/* unterminated special block */
        then
	do;			/**/
				/* clean it up */
	  call comp_break_ (format_break, 0);

	  if text.blktype = "tx"
	  then
	    do;
	      call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		 "Unterminated equation block.");
	    end;
	  else
	    do;
	      const.current_parms_ptr = text.hdr.parms_ptr;
	      shared.blkptr = text.hdr.blkptr;
	    end;
	end;

        if shared.ftn_mode		/* unclosed footnote */
        then
	do;
	  ctl_line = ".bef";
	  call comp_block_ctls_ (bef_ctl_index);
	end;

        if shared.blkptr ^= null
        then
	do;
	  if shared.table_mode	/* exit table mode */
	  then
	    do;
	      ctl.index = 5;
	      ctl_line = ".taf";
	      call comp_tbl_ctls_ (taf_ctl_index);
	    end;

	  else if text.blktype = "pi" /* unterminated picture? */
	  then call comp_block_ctls_ (bep_ctl_index);

	  else			/* reset mode switches */
	    do;			/* and finish the block */
	      text.parms.keep, text.parms.art = "0"b;
	      text.input.lmarg =
		 text.parms.left.indent - text.parms.left.undent;
	      text.input.rmarg =
		 text.parms.measure - text.parms.right.indent
		 + text.parms.right.undent;
	      text.input.net = text.input.rmarg - text.input.lmarg;

	      if shared.table_mode & ^text.parms.footnote
	      then
	        do;
		text.input.lmarg = text.input.lmarg + tblcol.margin.left;
		text.input.rmarg = text.input.rmarg + tblcol.margin.left;
	        end;

	      call comp_break_ (block_break, 0);
	    end;
	end;
      end;

    if current_parms.cbar.del		/* orphan delete mark? */
    then
      do;
        call comp_space_ (current_parms.linespace, shared.blkptr, "1"b, "1"b,
	   "1"b, "0"b);
        call comp_break_ (block_break, 0);
      end;

    if shared.picture.count > 0	/* put any pictures */
    then call comp_util_$pictures (shared.blkptr);
				/* are footnotes held? */
    if shared.ftnblk_data_ptr ^= null () & shared.ftn_reset = "hold"
    then if ftnblk_data.highndx > 0
         then
	 do;
	   shared.purge_ftns = "1"b;
	   ctl_line = ".ift";
	   call comp_ctls_ ("0"b);
	 end;			/**/
				/* any leftovers? */
    if page.hdr.used + col0.hdr.ftn.ct ^= 0 | shared.blkptr ^= null ()
    then call comp_break_ (page_break, 0);

    if shared.pass_counter <= 1 & ^option.check_opt & page.image_ptr ^= null
    then
      do;
        page_record_ptr = addr (page_image.text_ptr -> record.page_record);
        page_record.leng = 0;
        call comp_dvt.outproc (EPILOGUE, 0);

        if page_record.leng > 0
        then
	do;
	  call iox_$put_chars ((shared.compout_ptr), addr (page_record.text),
	       page_record.leng, ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_ (2, ercd, "Writing epilogue.",
		 addr (ctl.info), "");
	      signal comp_abort;
	      return;
	    end;
	end;
      end;

return_:
    if shared.bug_mode
         & (shared.input_filename = option.db_file
         | option.db_file = "ALLFILES")
    then call ioa_ ("^5x(comp_: ^a)", shared.input_filename);
%page;
do_htabs:
  proc;
    txtwidth =			/* set loop counters */
         text.parms.left.indent - text.parms.left.undent;
    i, j = 1;			/* set line scan controls */

    if length (ctl_line) > 0		/* adjust tabs */
    then
      do while (j > 0);
        j = search (substr (ctl_line, i), htab.chars);
        if j > 0			/* if a tab char was found */
        then
	do;
	  if j > 1		/* measure the preceding text */
	  then
	    do;
	      unspec (meas1) = "0"b;
	      call comp_measure_ (substr (ctl_line, i, j - 1),
		 addr (text.input.font), "0"b, text.input.art,
		 text.input.quad, 0, addr (meas1), addr (meas2),
		 addr (ctl.info));
	      txtwidth = txtwidth + meas1.width + meas1.avg;
	      ii = i + j - 1;
	    end;
	  else ii = i;		/* tab char is next, no new text */
				/* which tab character? */
	  jj = index (htab.chars, substr (ctl_line, ii, 1));
	  jj = htab.pats (jj);	/* pattern index for that character */
				/* find the stop column */
	  do k = 1 to htab.pattern (jj).count
	       while (txtwidth
	       >= htab.pattern (jj).stop (k) - shared.EN_width);
	  end;

	  if k <= htab.pattern (jj).count
				/* if within given stops */
	  then
	    do;
	      htab_space.v1 =	/* space needed */
		 htab.pattern (jj).stop (k) - txtwidth - shared.EN_width;

	      if htab_space.v1 > 0	/* if any to be inserted */
	      then
	        do;
		if htab.pattern (jj).fill (k) = ""
				/* if no given fill string */
		then
		  do;
		    ctl_line =
		         substr (ctl_line, 1, ii - 1) || htab_shift
		         || substr (ctl_line, ii + 1);
		    ii = ii + 7;
		  end;

		else
		  do;		/* construct the fill string */
		    unspec (meas1) = "0"b;
		    call comp_measure_ ((htab.pattern (jj).fill (k)),
		         addr (text.input.font), "0"b, "0"b, "0"b, 0,
		         addr (meas1), addr (meas2), addr (ctl.info));
		    fill_count =	/* number of fill strings needed */
		         divide (htab_space.v1, meas1.width + meas1.avg,
		         17, 0);
		    htab_space.v1 = htab_space.v1 -
				/* extra space */
		         fill_count * (meas1.width + meas1.avg);
		    if htab_space.v1 > 0
		    then
		      do;
		        ctl_line =
			   substr (ctl_line, 1, ii - 1) || htab_shift
			   || substr (ctl_line, ii);
		        ii = ii + 7;
		      end;
		    ctl_line = substr (ctl_line, 1, ii - 1) ||
				/* insert fill string */
		         copy (htab.pattern (jj).fill (k), fill_count)
		         || substr (ctl_line, ii + 1);
		    ii = ii
		         + fill_count
		         * length (htab.pattern (jj).fill (k));
		  end;

		i = ii;		/* adjust counters */
		txtwidth = htab.pattern (jj).stop (k) - shared.EN_width;
	        end;

	      else		/* htab char is next, just remove it */
		 ctl_line =
		      substr (ctl_line, 1, ii - 1)
		      || substr (ctl_line, ii + 1);
	    end;

	  else i = ii + 1;		/* not within given stops, step over it */
	end;
      end;
  end do_htabs;
%page;
%include comp_brktypes;
%include comp_ctl_index;
%include comp_text;
%include comp_column;
%include comp_DCdata;
%include comp_dvid;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_htab;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_output;
%include comp_page;
%include comp_shared;
%include comp_table;
%include compstat;

  end comp_;




		    comp_art_.pl1                   04/23/85  1059.2rew 04/23/85  0908.6      718875



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

/* compose subroutine to expand artwork. */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_art_:
  proc (blkptr, page_art);

/* PARAMETERS */

    dcl blkptr	   ptr;		/* pointer to source text block */
    dcl page_art	   bit (1);	/* 1 if page mode art */

/* LOCAL STORAGE */

    dcl art_str	   char (1020) var; /* constructed artwork line */
    dcl art_symbol_width
		   fixed bin (31) static options (constant) init (7200);
    dcl bad_char	   char (4);	/* octal representation of an
				   invalid overstrike character */
    dcl base	   fixed bin (31);	/* baseline offset (millipoints) */
    dcl cflags	   bit (72) based (cptr);
				/* symbol character cflags */
    dcl copen	   fixed bin init (0);
				/* count of open semi-circles */
    dcl cptr	   ptr init (null ());
				/* pointer to current entry */
    dcl crl	   fixed bin;	/* current line index */
    dcl crla	   fixed bin;	/* current line area index */
    dcl crs	   fixed bin;	/* current symbol index */
    dcl crs_pos	   fixed bin (31);	/* current output position */
    dcl crx	   fixed bin;	/* input index for current symbol */
    dcl debug_sw	   bit (1) init ("0"b);
				/* effective debug switch */
    dcl detail_sw	   bit (1) init ("0"b);
				/* effective detail debug switch */
    dcl EN3	   fixed bin (31);	/* 2 plot incrs for diablos */
    dcl EN6	   fixed bin (31);	/* 1 plot incrs for diablos */
    dcl half_size	   fixed bin;	/* half size of math symbol */
    dcl hcnt	   fixed bin (31);	/* length of horizontal rules */
    dcl hopen	   bit (1) init ("0"b);
				/* 1 = horiz rule is open */
    dcl hterm_pos	   fixed bin (31);	/* position of Hvec terminator */
    dcl 1 hor_sft	   like dclong_val; /* horizontal shifts */
    dcl hor_sft_str	   char (dclong1_len + 3) based (addr (hor_sft));
    dcl 1 hor_vec	   like dclong_val; /* horizontal vectors */
    dcl hor_vec_str	   char (dclong1_len + 3) based (addr (hor_vec));
    dcl (i, k)	   fixed bin;	/* working index */
    dcl isym	   fixed bin;	/* working symbol index */
    dcl j		   fixed bin (21);	/* working index and string index */
    dcl last_symb	   bit (1);	/* control for overstrike loop */
				/* 1= building lozenge top */
    dcl loztop	   bit (1) init ("0"b);
				/* for text measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl mini_size	   fixed bin;	/* minipos movement value */
    dcl oneEN	   fixed bin (31);	/* current EN width */
    dcl pad_adj	   fixed bin;
    dcl pflags	   bit (72) based (pptr);
				/* symbol character pflags */
    dcl pptr	   ptr init (null ());
				/* a previous table entry */
    dcl prlct	   fixed bin;	/* symbol count for previous line */
    dcl prs_pos	   fixed bin (31);	/* previous output position */
    dcl prs_width	   fixed bin (31);	/* width of previous symbol */
    dcl prx	   fixed bin;	/* input index for previous symbol */
    dcl scndx	   fixed bin;	/* overstrike loop scan index */
    dcl size_char	   char (1);	/* symbol size character */
    dcl ssym	   fixed bin;	/* symbol counter for searching */
    dcl swaps	   fixed bin;	/* swap counter for symbol sorting */
    dcl symbndx	   fixed bin;	/* current symbol index */
    dcl symbstr	   char (100) varying;
				/* symbol string for debug */
    dcl syntax_error   bit (1) init ("0"b);
				/* syntax error flag */
    dcl 1 temp_entry   like ctb.e;	/* entry holder for symbol sorting */
    dcl text_pos	   fixed bin (31) init (0);
				/* current position in output line */
    dcl trans_str	   char (36) var;	/* art construct translation string */
    dcl twoEN	   fixed bin (31);	/* twice current EN width */
    dcl 1 vert_sft	   like dclong_val;
    dcl vert_sft_ptr   ptr;
    dcl vert_sft_str   char (dclong1_len + 3) based (vert_sft_ptr);
    dcl zer_adj	   fixed bin;	/* adjustment for 0 width symbol */

/* SYMBOL/FLAG STRING INDEX VALUES */
    dcl (
        boxtl_ndx	   init (38),
        boxl_ndx	   init (41),
        boxbl_ndx	   init (44),
        daro_ndx	   init (17),	/* down arrow */
        first_mini_pos init (16),	/* first mini-positioning symbol */
        horiz_ndx	   init (21),	/* horizontal element */
        last_graphic   init (21),	/* number of symbols having graphics */
        last_math	   init (15),	/* last math symbol */
        last_mini_pos  init (19),	/* last minipos symbol */
        last_ml_math   init (8),	/* last multiline math symbol */
        lprn_ndx	   init (5),	/* left paren */
        lslnt_ndx	   init (20),	/* left slant */
        rprn_ndx	   init (6),	/* right paren */
        rslnt_ndx	   init (10),	/* right slant */
        star_ndx	   init (12),	/* star */
        uparo_ndx	   init (16),	/* up arrow */
        vert_ndx	   init (7),	/* vertical element */
        vterm_ndx	   init (26)	/* vertical terminator */
        )		   fixed bin static options (constant);

/* EXTERNAL STORAGE */

    dcl 1 block	   aligned like text based (blkptr);
				/* the input block */
				/* current line art symbol table */
    dcl 1 ctb	   aligned,
	2 depth	   fixed bin (31),	/* depth of line */
	2 dopen	   fixed bin,	/* count of open diamonds */
	2 lmarg	   fixed bin (31),	/* left margin value */
	2 lopen	   fixed bin,	/* count of open left slant lines */
	2 line_width fixed bin (31),	/* line width */
	2 open	   fixed bin,	/* count of open vertical art constructs */
	2 ropen	   fixed bin,	/* count of open right slant lines */
	2 scnt	   fixed bin,	/* count of symbols in the line */
	2 vopen	   fixed bin,	/* count of open vertical lines */
	2 e	   (100),		/* the entries */
	( 3 lbrk	   bit (1),	/*  1 - left bracket */
	  3 rbrk	   bit (1),	/*  2 - right bracket */
	  3 lbrc	   bit (1),	/*  3 - left brace */
	  3 rbrc	   bit (1),	/*  4 - right brace */
	  3 lprn	   bit (1),	/*  5 - left paren & left semicircle */
	  3 rprn	   bit (1),	/*  6 - right paren */
	  3 vert	   bit (1),	/*  7 - Boolean OR & vertical rule */
	  3 concat   bit (1),	/*  8 - concatenation */
	  3 bullet   bit (1),	/*  9 - bullet */
	  3 rslnt	   bit (1),	/* 10 - right slant */
	  3 mult	   bit (1),	/* 11 - multiplication */
	  3 star	   bit (1),	/* 12 - asterisk & horizontal terminator */
	  3 cbar	   bit (1),	/* 13 - change bar */
	  3 cm	   bit (1),	/* 14 - copyright */
	  3 tm	   bit (1),	/* 15 - trademark */
	  3 uparo	   bit (1),	/* 16 - up arrow */
	  3 daro	   bit (1),	/* 17 = down arrow */
	  3 laro	   bit (1),	/* 18 = left arrow */
	  3 raro	   bit (1),	/* 19 = right arrow */
	  3 lslnt	   bit (1),	/* 20 = left slant */
	  3 horiz	   bit (1),	/* 21 = horizontal rule */
	  3 hlup	   bit (1),	/* 22 = half-line up */
	  3 hldn	   bit (1),	/* 23 = half-line down */
	  3 supscr   bit (1),	/* 24 = superscript */
	  3 subscr   bit (1),	/* 25 = subscript */
	  3 vterm	   bit (1),	/* 26 = vertical & slant-line terminator */
	  3 repl	   bit (2),	/* 27 = replicators */
	  3 diam	   bit (1),	/* 29 = diamond part */
	  3 text	   bit (1),	/* 30 = text */
	  3 lstrt	   bit (1),	/* 31 - left slant start */
	  3 rstrt	   bit (1),	/* 32 - right slant start */
	  3 lterm	   bit (1),	/* 33 - left slant terminator */
	  3 rterm	   bit (1),	/* 34 - right slant terminator */
	  3 vstrt	   bit (1),	/* 35 - OBSOLETE */
	  3 loz	   bit (1),	/* 36 - lozenge part */
	  3 blind	   bit (1),	/* 37 - do not display this symbol */
	  3 boxtl	   bit (1),	/* 38 - box top left corner */
	  3 boxt	   bit (1),	/* 39 - box top line intersection */
	  3 boxtr	   bit (1),	/* 40 - box top right corner */
	  3 boxl	   bit (1),	/* 41 - box lefts edge intersection */
	  3 boxx	   bit (1),	/* 42 - box interior intersection */
	  3 boxr	   bit (1),	/* 43 - box right edge intersection */
	  3 boxbl	   bit (1),	/* 44 - box bottom left corner */
	  3 boxb	   bit (1),	/* 45 - box bottom line intersection */
	  3 boxbr	   bit (1),	/* 46 - box bottom right corner */
	  3 loztl	   bit (1),	/* 47 - lozenge top left corner */
	  3 loztr	   bit (1),	/* 48 - lozenge top right corner */
	  3 lozl	   bit (1),	/* 49 - lozenge left vertex */
	  3 lozr	   bit (1),	/* 50 - lozenge right vertex */
	  3 lozbl	   bit (1),	/* 51 - lozenge bottom left corner */
	  3 lozbr	   bit (1),	/* 52 - lozenge bottom right corner */
	  3 MBZ	   bit (20)	/* = 72 bits */
	  )	   unal,
	  3 base	   fixed bin (31),	/* baseline offset (millipoints) */
	  3 hadj	   fixed bin (31),	/* horizontal position adjustment */
	  3 len	   fixed bin (21),	/* length of input text string */
	  3 lndx	   fixed bin,	/* line position index */
	  3 pos	   fixed bin (31),	/* position of char in target line */
	  3 size	   fixed bin (31),	/* size of math symbol */
	  3 tstrt	   fixed bin (21),	/* input starting text position */
	  3 width	   fixed bin (31),	/* width of text */
	  3 wsp	   fixed bin (31);	/* wordspace for text */

    dcl 1 ctbe	   like ctb.e based (cptr);
				/* the current table entry */
				/* previous line art symbol table */
    dcl 1 ptb	   aligned like ctb;
    dcl 1 ptbe	   like ctb.e based (pptr);
				/* any previous table entry */
    dcl tmpstr	   char (1020) var; /* working text line */

    dcl (addr, char, dec, divide, index, length, ltrim, max, min, mod, null,
        search, substr, translate, unspec, verify)
		   builtin;

    dcl ioa_$rsnnl	   entry options (variable);
%page;
/* INITIALIZE */
    if shared.bug_mode
    then call ioa_ ("art: (blk=^d,^d)", block.blkndx, block.hdr.count);

    vert_sft.mark, hor_sft.mark, hor_vec.mark = DC1;
    vert_sft.type = type_sly;
    vert_sft.leng = dclong1_len;
    vert_sft_ptr = addr (vert_sft);
    hor_sft.type = type_slx;
    hor_sft.leng = dclong1_len;
    hor_vec.type = type_vlx;
    hor_vec.leng = dclong1_len;
    oneEN = shared.EN_width;
    twoEN = 2 * oneEN;

    if comp_dvt.devclass = "diablo"
    then
      do;
        EN6 = oneEN / 6;
        EN3 = oneEN / 3;
      end;
    else EN6, EN3 = 0;

    unspec (ctb), unspec (ptb) = "0"b;
%page;
/* SCAN THE SOURCE, LINE BY LINE */

    crl = 0;
line_loop:
    do line_area_ptr = block.line_area.first repeat (line_area.next)
         while (line_area_ptr ^= null);
      do crla = 1 to line_area.ndx;	/* for the given lines */
        crl = crl + 1;		/**/
				/* set local line pointers */
        txtlinptr = line_area.linptr (crla);
        txtstrptr = txtlin.ptr;

        if shared.bug_mode | db_sw	/* check line range if debugging */
        then
	do;
	  if (option.line_1 <= txtlin.lineno0
	       & (txtlin.lineno0 <= option.line_2 | option.db_line_end = -1))
	  then debug_sw = "1"b;
	  else debug_sw = "0"b;

	  if crl >= db_line
	  then
	    do;
	      debug_sw = "1"b;
	      if dt_sw
	      then detail_sw = "1"b;
	      else detail_sw = "0"b;
	    end;
	end;			/**/
				/* no art in this line? */
        if ^txtlin.art & ctb.vopen = 0 | (unspec (txtlin.spcl) ^= "0"b)
        then goto end_line_loop;

        if detail_sw
        then
	do;
	  call ioa_ ("^5xSCAN (lin=^d ^d/^d d^f ld^f w^f g^d mrg^f/^f/^f"
	       || " set=^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]^[L^])^/^-""^a""", crl,
	       block.blkndx, txtlin.lineno, show (txtlin.depth, 12000),
	       show (txtlin.linespace, 12000), show (txtlin.width, 12000),
	       txtlin.cur.gaps, show (txtlin.lmarg, 12000),
	       show (txtlin.rmarg, 12000), show (txtlin.net, 12000),
	       (txtlin.quad = quadi), (txtlin.quad = quado),
	       (txtlin.quad = quadl), (txtlin.quad = quadc),
	       (txtlin.quad = quadr), (txtlin.quad = just),
	       (txtlin.quad = "0"b), comp_util_$display (txtstr, 0, "0"b));
	  call ioa_ ("^-open-v^d l^d r^d d^d=^d", ctb.vopen, ctb.lopen,
	       ctb.ropen, ctb.dopen, ctb.open);
	end;

        tmpstr = txtstr;		/* copy the line */
        unspec (ctb) = "0"b;		/* set up current table */
        ctb.depth = txtlin.depth;

        ctb.open = ptb.open;		/* propagate open counts */
        ctb.vopen = ptb.vopen;
        ctb.lopen = ptb.lopen;
        ctb.ropen = ptb.ropen;
        ctb.dopen = ptb.dopen;

        ctb.lmarg = ptb.lmarg;	/* propagate margin setting */
        if txtlin.lmarg ^= ctb.lmarg & ptb.open = 0
        then
	do;
	  if detail_sw
	  then call ioa_ ("^- 0- Left margin shift - ^f to ^f",
		  show (ctb.lmarg, 12000), show (txtlin.lmarg, 12000));

	  ctb.lmarg = txtlin.lmarg;
	end;

/* look for a symbol */
        crx, crs = 1;		/* set up for scan */
        cptr = addr (ctb.e (crs));	/* point to table entry */
        base, prx, scndx, crs_pos, prs_width, pad_adj, zer_adj = 0;
        prs_pos = txtlin.lmarg - ctb.lmarg;

/* if any BSPs, then scan for symbols */
        if index (tmpstr, BSP) > 0
        then
	do;			/* find BSP or DC1 */
find:
	  j = search (substr (tmpstr, crx), BSP || DC1);

	  if j = 0		/* nothing interesting? */
	  then crx = length (tmpstr) + 1;

	  else
	    do;
	      if substr (tmpstr, crx + j - 1, 1) = DC1
	      then
	        do;		/* step over dev ctl string */
		crx = crx + rank (substr (tmpstr, crx + j + 1, 1)) + j + 2;
		goto find;	/* and keep looking */
	        end;

	      crx = crx + j - 2;	/* set crx to first artwork char */

	      if crx = 0		/* if BSP starts the line */
	      then
	        do;
		crx = 2;		/* start again with 2nd line char */
		goto find;
	        end;
	    end;

scan_loop:
	  do while (crx <= length (tmpstr) & ctb.scnt < 100);
	    trans_str = BSP || "'"""; /* initialize translation string */
	    size_char = NUL;
	    last_symb = "0"b;	/**/
				/* skip control sequences */
	    if index (substr (tmpstr, crx), DC1) = 1
	    then
	      do;
	        DCxx_p = addr (substr (tmpstr, crx));
	        scndx = crx + 3 + dcxx.leng;
	        goto scan_continue;
	      end;		/**/
				/* ignore underscores */
				/* and slashed symbols */
(nostrg):
	    if index (substr (tmpstr, crx), "_") = 1
	         | index (substr (tmpstr, crx), "_") = 3
	         | (substr (tmpstr, crx, 1) = "/"
	         & index ("0Oocsb=", substr (tmpstr, crx + 2, 1)) ^= 0)
	         | (substr (tmpstr, crx + 2, 1) = "/"
	         & index ("0Oocsb=", substr (tmpstr, crx, 1)) ^= 0)
	    then
	      do;
	        scndx = crx + 2;	/* step over it */
	        goto scan_continue;	/* and continue */
	      end;

overstrike_loop:			/* do all BSP chars */
	    do scndx = crx by 2
	         while (scndx < length (tmpstr) & ^last_symb
	         & substr (tmpstr, scndx + 1, 1) = BSP);

last_symb_:
	      if substr (tmpstr, scndx, 1) = "1"
	      then size_char = "1";	/* one-highs are special */

	      else
	        do;		/* which symbol? */
		isym =
		     index (const.art_symbols, substr (tmpstr, scndx, 1));

		if isym > 0	/* if found, set symbol flag */
		then
		  do;
		    symbndx = isym;
		    substr (cflags, symbndx, 1) = "1"b;

		    if size_char = NUL
				/* could it also be a valid size? */
		         &
		         index (
		         "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
		         , substr (tmpstr, scndx, 1)) ^= 0
		    then size_char = substr (tmpstr, scndx, 1);
		  end;

		else if isym = 0	/* not in art symbol set */
		then
		  do;
		    if size_char = NUL
				/* could it also be a valid size? */
		         &
		         index (
		         "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
		         , substr (tmpstr, scndx, 1)) ^= 0
		    then size_char = substr (tmpstr, scndx, 1);

		    else
		      do;
		        call ioa_$rsnnl ("\^3.3b", bad_char, 0,
			   unspec (substr (tmpstr, scndx, 1)));
		        call comp_report_ (2, 0,
			   "Bad overstrike, " || bad_char
			   || ", at character "
			   || ltrim (char (scndx)) || " of input line.",
			   addr (txtlin.info), txtstr);
		        syntax_error = "1"b;
		        if substr (tmpstr, scndx + 1, 1) = BSP
		        then scndx = scndx + 2;
				/* step over bad pair */
		        goto scan_continue;
		      end;
		  end;
	        end;
	    end overstrike_loop;

	    if ^last_symb		/* once more for last symbol */
	    then
	      do;
	        last_symb = "1"b;
	        goto last_symb_;
	      end;
	    else scndx = scndx - 2;	/* back out last scan */

	    if detail_sw		/* make debug string */
	    then symbstr =		/* translating BS's to ,'s */
		    translate (substr (tmpstr, crx, scndx - crx + 1), ",",
		    BSP);		/* is symbol multiline math? */
	    if index (cflags, "1"b) <= last_ml_math
	    then if (substr (cflags, last_ml_math + 1)
		    & "01010001011110000111"b) = "0"b
	         then ctbe.size = rank (size_char);
	         else ;		/* set symbol size */
				/* is it another 1-high? */
	    else if index (cflags, "1"b) <= last_math
	         & substr (cflags, last_math + 1) = "0"b
	    then ctbe.size = 49;	/* set symbol size */

	    else
	      do;			/* all other flags */
	        i, j = 1;
	        do while (j ^= 0);
		j = index (substr (cflags, i), "1"b);
		if j > 0
		then
		  do;
		    i = i + j;
		    trans_str =
		         trans_str || substr (const.art_symbols, i - 1, 1);
		  end;
	        end;
	      end;
/**** any preceding text? scan for 1st non-blank since last symbol */
	    j = verify (substr (tmpstr, prx + 1, crx - prx - 1), " " || PAD);

	    if j > 0		/* found one */
	    then
	      do;			/* move to insert text */
	        ctb.e (crs + 1) = ctb.e (crs);
				/* clear vacated entry */
	        unspec (ctb.e (crs)) = ""b;
	        ctbe.base = base;	/* baseline offset */
	        ctbe.text = "1"b;	/* text entry flag */
				/* input text start */
	        prx, ctbe.tstrt = prx + j;
	        ctbe.len, k = crx - prx;
				/* input length */
	        prs_pos, ctbe.pos =	/* output position */
		   prs_pos + prs_width
		   + oneEN * (j - 1 + zer_adj - pad_adj);
	        zer_adj, pad_adj, prs_width = 0;

	        unspec (meas1) = "0"b;
	        call comp_measure_ (rtrim (substr (tmpstr, prx, k)),
		   addr (txtlin.font), (txtlin.quad = just), "1"b,
		   txtlin.quad, bin (txtlin.quad = just) * txtlin.net,
		   addr (meas1), addr (meas2), addr (txtlin.info));
				/* output width */
	        ctbe.width = meas1.width;
	        ctbe.wsp = meas1.avg;
	        ctbe.len, k = meas1.chrct;
	        prx = prx + k - 1;	/* step to end of text */
				/* new position */
	        prs_pos = prs_pos + ctbe.width + ctbe.wsp;

	        if detail_sw
	        then
		do;
		  call ioa_ ("^-^2d- ^f (b^f w^f) ^d ""^a""", crs,
		       show (ctbe.pos, 12000), show (ctbe.base, 12000),
		       show (ctbe.width, 12000), ctbe.len,
		       comp_util_$display (
		       substr (tmpstr, ctbe.tstrt, ctbe.len), 0, "0"b));
		end;

	        crs = crs + 1;	/* we have a valid text entry */
				/* point to symbol just moved */
	        cptr = addr (ctb.e (crs));
	      end;

/* set position */
	    ctbe.pos =
	         prs_pos + prs_width + oneEN * (crx - prx - 1 + zer_adj);
	    ctbe.base = base;
	    zer_adj = 0;
%page;
/* CHECK SYNTAX OF GIVEN SYMBOLS */

/* MATH SYMBOLS */
	    if ctbe.size ^= 0
	    then
	      do;
	        if ctbe.size = 48	/* normalize symbol size */
	        then ctbe.size = 10;
	        else if ctbe.size > 96
	        then ctbe.size = ctbe.size - 86;
	        else if ctbe.size > 64
	        then ctbe.size = ctbe.size - 34;
	        else ctbe.size = ctbe.size - 48;

	        if substr (cflags, 1, last_ml_math) ^= "0"b
	        then
		do;
		  if ctbe.size > 56 /* symbol size too big? */
		  then
		    do;
bad_math_size:
		      call comp_report_ (2, 0,
			 "Math symbol size too big at column "
			 ||
			 ltrim (char (divide (ctbe.pos, 7200, 17, 0))),
			 addr (txtlin.info), txtstr);
		      syntax_error = "1"b;
		      goto scan_continue;
		    end;
		end;

	        else if substr (cflags, 1, last_math) ^= "0"b
	        then if ctbe.size > 1
		   then goto bad_math_size;
				/* which symbol */
	        i = index (cflags, "1"b);
				/* add to translate string */
	        trans_str = trans_str || substr (const.art_symbols, i, 1);
				/* size char, too */
	        trans_str = trans_str || size_char;
				/* all ML math are fixed width */
	        ctbe.width = art_symbol_width;

	        if ctbe.size > 1	/* position according */
	        then		/* to symbol size */
		do;		/* odds move down */
		  if mod (ctbe.size, 2) ^= 0
		  then ctbe.base = base + 3000;
				/* evens move up */
		  else ctbe.base = base - 3000;
		end;		/**/
				/* set symbol's line index */
	        if crl = 1 | ctbe.size = 1
	        then ctbe.lndx = 1;	/* first line or one-high */
				/* search previous line for this */
	        else if crl > 1	/* symbol in this position */
	        then
		do;
		  do i = 1 to ptb.scnt
		       while (
		       ^(substr (addr (ptb.e (i)) -> pflags, symbndx, 1)
		       = "1"b & ptb.pos (i) = ctbe.pos
		       & ptb.size (i) = ctbe.size
		       & ptb.lndx (i) ^= ptb.size (i)));
		  end;
		  if i > ptb.scnt	/* if not found, then this is a top */
		  then ctbe.lndx = 1;
		  else
		    do;		/* record symbol continuation */
		      ctbe.lndx = ptb.lndx (i) + 1;
		    end;
		end;
	        else ctbe.lndx = 1;	/* no symbols in previous line */
	      end;		/* math symbol syntax check */

/* SUB/SUPERSCRIPTS */
	    else if ctbe.supscr	/* superscript? */
	    then
	      do;
	        if ctbe.daro	/* if subscript */
	        then
		do;
		  ctbe.supscr = "0"b;
				/* change flag */
		  ctbe.subscr = "1"b;
		  ctbe.daro = "0"b; /* reset daro flag */
		  base = base + 4500;
				/* drop baseline by a third */
		end;

	        else
		do;
		  ctbe.uparo = "0"b;/* reset uparo flag */
		  base = base - 4500;
				/* raise baseline by a third */
		end;

/*	        zer_adj = 1;	/* account for zero width symbol */
	      end;

	    else if ctbe.subscr	/* subscript? */
	    then
	      do;
	        if ctbe.uparo
	        then
		do;		/* if superscript */
		  ctbe.supscr = "1"b;
				/* change flag */
		  ctbe.subscr = "0"b;
		  ctbe.uparo = "0"b;/* reset uparo flag */
		  base = base - 4500;
				/* raise baseline by a third */
		end;

	        else
		do;
		  ctbe.daro = "0"b; /* reset daro flag */
		  base = base + 4500;
				/* drop baseline by a third */
		end;

/*	        zer_adj = 1;	/* account for zero width symbol */
	      end;

/* HALF LINES */
	    else if ctbe.hlup	/* up? */
	    then
	      do;
	        if ctbe.daro	/* if hline down */
	        then
		do;
		  ctbe.hlup = "0"b; /* change flag */
		  ctbe.hldn = "1"b;
		  ctbe.daro = "0"b; /* reset daro flag */
		  base = base + 6000;
				/* drop baseline by a half */
		end;

	        else
		do;
		  ctbe.uparo = "0"b;/* reset uparo flag */
		  base = base - 6000;
				/* raise baseline by a half */
		end;

/*	        zer_adj = 1;	/* account for zero width symbol */
	      end;

	    else if ctbe.hldn	/* down? */
	    then
	      do;
	        if ctbe.uparo	/* if hline up */
	        then
		do;
		  ctbe.hlup = "1"b; /* change flag */
		  ctbe.hldn = "0"b;
		  ctbe.uparo = "0"b;/* reset uparo flag */
		  base = base - 6000;
				/* raise baseline by a half */
		end;

	        else
		do;
		  ctbe.daro = "0"b; /* reset daro flag */
		  base = base + 6000;
				/* drop baseline by a half */
		end;
	      end;

/* MINIPOSITIONING */
	    else if index (cflags, "1"b) >= first_mini_pos
	         & index (cflags, "1"b) <= last_mini_pos
	         & substr (cflags, last_mini_pos + 1) = "0"b
	    then
	      do;
	        ctbe.size = rank (size_char) - 48;
	        trans_str = trans_str || size_char;
				/* bad count? */
	        if ctbe.size < 0 | ctbe.size > 9
	        then
		do;
		  call comp_report_ (2, 0, "Invalid miniposition count.",
		       addr (txtlin.info), txtstr);
		  syntax_error = "1"b;
		  goto scan_continue;
		end;

	        if ctbe.uparo
	        then base = base - 1500 * ctbe.size;
	        else if ctbe.daro
	        then base = base + 1500 * ctbe.size;
	        else if ctbe.raro
	        then ctbe.hadj = ctbe.hadj + 1200 * ctbe.size;
	        else if ctbe.laro
	        then ctbe.hadj = ctbe.hadj - 1200 * ctbe.size;
				/* what direction? */
				/*	      i = index (substr (cflags, first_mini_pos, 4), "1"b);
				/* add to trans str */
				/*	      trans_str = trans_str || substr (const.art_symbols, i, 1);
				/* clear flags */
	        substr (cflags, first_mini_pos, 4) = "0000"b;
	      end;

/* LINE ART SYNTAX */

	    else
	      do;
	        if ctbe.horiz	/* if horiz start */
	        then
		do;

/* starting horizontal rules, boxes, and lozenges */
		  trans_str =
		       trans_str
		       || substr (const.art_symbols, horiz_ndx, 1);

		  if ^ctbe.star	/* if NOT also horiz term */
		  then
		    do;

/* check all box left parts */
		      if ctbe.vert	/* first, tops & interior Ts */
		      then
		        do;
			trans_str =
			     trans_str
			     || substr (const.art_symbols, vert_ndx, 1);

			if crl > 1/* symbol count of previous line */
			then prlct = ptb.scnt;
			else prlct = 0;
				/* find ptbe having a vertical, a */
				/* box part, or a continued */
				/* vertical in this col */
			do ssym = 1 to prlct
			     while (
			     ^
			     ((ptb.vert (ssym)
			     |
			     substr (addr (ptb.e (ssym)) -> pflags,
			     boxtl_ndx, 6) ^= "0"b) & ^ptb.vterm (ssym)
			     & ptb.pos (ssym) = ctbe.pos));
			end;

/* box top left corners */
			if ssym > prlct
			then	/* cant be an interior corner, */
			  do;	/* so open a new rule */
			    ctb.vopen = ctb.vopen + 1;
			    ctb.open = ctb.open + 1;

			    if hopen
				/* if there's already a rule, */
			    then	/* its a top intersection */
			         ctbe.boxt = "1"b;

			    else	/* its a top left corner */
			         ctbe.boxtl = "1"b;

			    ctbe.width = oneEN;
			  end;

/* box interior left corners */
			else
			  do;
			    if hopen
				/* a box + */
			    then ctbe.boxx = "1"b;
				/* else a left T */
			    else ctbe.boxl = "1"b;
			    ctbe.width = oneEN;
			  end;
			ctbe.vert, ctbe.horiz = "0"b;
		        end;

/* box bottom left corners */
		      if ctbe.vterm & ^(ctbe.lslnt | ctbe.rslnt)
		      then
		        do;
			trans_str =
			     trans_str
			     || substr (const.art_symbols, vterm_ndx, 1);
				/* get symbol count of previous line */
			if crl > 1
			then prlct = ptb.scnt;
			else prlct = 0;
				/* skip ptbe having a vertical, a box */
				/* part or a continued vertical */
				/* in this col */
			do ssym = 1 to prlct
			     while (
			     ^
			     ((ptb.vert (ssym)
			     |
			     substr (addr (ptb.e (ssym)) -> pflags,
			     boxtl_ndx, 6) ^= "0"b) & ^ptb.vterm (ssym)
			     & abs (ptb.pos (ssym) - ctbe.pos)
			     < comp_dvt.min_WS));
			end;	/* oops! an orphan */
			if ssym > prlct
			then call comp_report_$ctlstr (2, 0,
				addr (txtlin.info), txtstr,
				"Orphan box corner at column ^d",
				divide (ctbe.pos, 12000, 17, 0));

			else	/* we have a matching box part */
			  do;	/* close a rule */
			    ctb.vopen = ctb.vopen - 1;
			    ctb.open = ctb.open - 1;

			    if hopen
				/* if theres already a rule */
			    then ctbe.boxb = "1"b;
				/* bottom intersection */
			    else ctbe.boxbl = "1"b;
				/* bottom left corner */
			    ctbe.width = oneEN;

			    ctbe.vterm, ctbe.horiz = "0"b;
			  end;
		        end;

/* upper left lozenge corner? */
		      if ctbe.rslnt & ^ctbe.vterm
		      then
		        do;
			trans_str =
			     trans_str
			     || substr (const.art_symbols, rslnt_ndx, 1);
			ctbe.loztl, loztop = "1"b;
			ctbe.rslnt, ctbe.horiz = "0"b;
			ctb.ropen = ctb.ropen + 1;
			ctb.open = ctb.open + 1;
			ctbe.width = oneEN;
		        end;

/* lower left lozenge corner? */
		      if ctbe.lslnt & ctbe.vterm & ^ctbe.rslnt
		      then
		        do;	/* scan previous line for ... */
			do ssym = 1 to ptb.scnt
				/* loz left ... */
			     while (^(((ptb.lslnt (ssym)
				/* slant ... */
			     & ptb.pos (ssym) = ctbe.pos - twoEN)
			     | (ptb.lozl (ssym)
				/* or left vertex ... */
			     & ptb.pos (ssym) = ctbe.pos - oneEN))
			     & ^ptb.lterm (ssym)));
				/* without a terminator */
			end;

			if ssym <= ptb.scnt
				/* if found, its a lower left */
			then
			  do;
			    trans_str =
			         trans_str
			         ||
			         substr (const.art_symbols, lslnt_ndx, 1)
			         ;
			    ctbe.lozbl = "1"b;
			    ctbe.lslnt, ctbe.horiz, ctbe.vterm = "0"b;
			    ctb.lopen = ctb.lopen - 1;
			    ctbe.width = oneEN;
			    ctb.open = ctb.open - 1;
			  end;
		        end;

		      hopen = "1"b; /* rule is open */
		      if ctbe.horiz
			 & ^(ctbe.lslnt & ctbe.vterm & ctbe.rslnt)
		      then zer_adj = 1;
				/* just a plain hrule starter */
		    end;
		end;

	        if ctbe.star	/* if horiz term */
		   & (hopen | ctbe.horiz)
				/* and there is a rule */
	        then
		do;
		  trans_str =
		       trans_str
		       || substr (const.art_symbols, star_ndx, 1);

/* check all box right parts */
		  if ctbe.vert	/* first, check tops and interiors */
		  then
		    do;
		      trans_str =
			 trans_str
			 || substr (const.art_symbols, vert_ndx, 1);

		      if crl > 1	/* symbol count of previous line */
		      then prlct = ptb.scnt;
		      else prlct = 0;
				/**/
				/* skip ptbe having a vertical, */
				/* a box part, or a continued */
				/* vertical in this col */
		      do ssym = 1 to prlct
			 while (
			 ^
			 ((ptb.vert (ssym)
			 |
			 substr (addr (ptb.e (ssym)) -> pflags,
			 boxtl_ndx, 6) ^= "0"b) & ^ptb.vterm (ssym)
			 & ptb.pos (ssym) = ctbe.pos));
		      end;

/* box top right corners */
		      if ssym > prlct
		      then
		        do;
			ctb.vopen = ctb.vopen + 1;
			ctb.open = ctb.open + 1;
			ctbe.boxtr = "1"b;
			zer_adj = 1;
			ctbe.vert, ctbe.horiz, hopen = "0"b;
		        end;

/* box interior right corners */
		      else
		        do;
			ctbe.boxr = "1"b;
			zer_adj = 1;
			ctbe.vert, ctbe.star, hopen = "0"b;
		        end;
		    end;

/* box bottom right corners */
		  else if ctbe.vterm & ^(ctbe.lslnt | ctbe.rslnt)
		  then
		    do;
		      trans_str =
			 trans_str
			 || substr (const.art_symbols, vterm_ndx, 1);
				/* symbol count of previous line */
		      if crl > 1
		      then prlct = ptb.scnt;
		      else prlct = 0;

		      do ssym = 1 to prlct
			 while (
			 ^
			 ((ptb.vert (ssym)
			 | substr (addr (ptb.e (ssym)) ->
				/* box part.. */
			 pflags, boxtl_ndx, 6) ^= "0"b)
			 & ^ptb.vterm (ssym)
			 & abs (ptb.pos (ssym) - ctbe.pos)
			 < comp_dvt.min_WS));
		      end;	/**/
				/* oops! an orphan */
		      if ssym > prlct
		      then call comp_report_$ctlstr (2, 0,
			      addr (txtlin.info), txtstr,
			      "Orphan box corner at column ^d",
			      divide (ctbe.pos, 12000, 17, 0));
				/* we have a matching box part */
		      else
		        do;
			ctb.vopen = ctb.vopen - 1;
			ctb.open = ctb.open - 1;
			ctbe.boxbr = "1"b;
			zer_adj = 1;
			ctbe.vterm, ctbe.horiz, hopen = "0"b;
		        end;
		    end;

/* upper right lozenge corner? */
		  else if ctbe.lslnt & loztop
		  then
		    do;
		      ctbe.lslnt, ctbe.star, loztop = "0"b;
		      ctbe.loztr = "1"b;
		      zer_adj = 1;
		      ctb.open = ctb.open + 1;
		      ctb.lopen = ctb.lopen + 1;
		    end;

/* lower right lozenge corner? */
		  else if ctbe.rslnt & ctbe.vterm
		  then
		    do;
		      do ssym = 1 to ptb.scnt while
				/* look for ... */
			 (^(((ptb.rslnt (ssym) &
				/* right slant */
			 ptb.pos (ssym) - twoEN = ctbe.pos)
			 | (ptb.lozr (ssym) &
				/* or right vertex */
			 ptb.pos (ssym) - oneEN = ctbe.pos))
			 & ^ptb.rterm (ssym)));
		      end;

		      if ssym <= ptb.scnt
				/* if found */
		      then
		        do;	/* its a lower right */
			trans_str =
			     trans_str
			     || substr (const.art_symbols, rslnt_ndx, 1);
			ctbe.lozbr = "1"b;
			zer_adj = 1;
			ctbe.rslnt, ctbe.star, ctbe.vterm = "0"b;
			ctb.ropen = ctb.ropen - 1;
			ctb.open = ctb.open - 1;
		        end;
		    end;		/**/
				/* if none of the above */
		  else
		    do;
		      if ctbe.star
		      then if ctbe.raro
			 then ctbe.width = oneEN;
			 else zer_adj = 1;
		    end;		/**/
				/* close the rule */
		  hopen = "0"b;
		end;

/* left slants */
	        if ctbe.lslnt
	        then
		do;
		  if ctbe.pos = 0
		  then		/* cant be in column 1 */
		    do;
		      call comp_report_ (2, 0,
			 "Left slant line violates left margin.",
			 addr (txtlin.info), txtstr);
		      syntax_error = "1"b;
		      goto scan_continue;
		    end;

/* lozenge vertices */
		  if crl > 1 & ctbe.rslnt & ctbe.vterm
		  then
		    do;		/**/
				/* first try left vertex */
		      do ssym = 1 to ptb.scnt
			 while (
			 ^((ptb.rslnt (ssym) | ptb.loztl (ssym))
			 & ptb.pos (ssym) - oneEN = ctbe.pos));
		      end;	/**/
				/* if found */
		      if ssym <= ptb.scnt
		      then
		        do;
			pptr = addr (ptb.e (ssym));
				/* set adjustment */
			if ptbe.loztl
			then ctbe.hadj = ptbe.hadj - EN6;
			else ctbe.hadj = ptbe.hadj - EN3;
				/* change flags */
			ctbe.lslnt, ctbe.vterm, ctbe.rslnt = "0"b;
			ctbe.lozl = "1"b;
			ctbe.width = art_symbol_width;
			zer_adj = 0;
			ctb.ropen = ctb.ropen - 1;
			ctb.lopen = ctb.lopen + 1;
				/* Note that ALL right slant */
				/* logic is skipped */
			goto end_given_rs;
		        end;	/* try right vertex */
		      do ssym = 1 to ptb.scnt
			 while (
			 ^((ptb.lslnt (ssym) | ptb.loztr (ssym))
			 & ptb.pos (ssym) + oneEN = ctbe.pos));
		      end;	/**/
				/* if found */
		      if ssym <= ptb.scnt
		      then
		        do;	/* set adjustment */
			ctbe.hadj = ptb.hadj (ssym) + EN3;
				/* change flags */
			ctbe.rslnt, ctbe.lslnt, ctbe.vterm = "0"b;
			ctbe.lozr = "1"b;
			ctbe.width = oneEN;
				/* adjust open slant counts */
			ctb.lopen = ctb.lopen - 1;
			ctb.ropen = ctb.ropen + 1;
				/* Note that ALL right slant logic */
				/* is skipped */
			goto end_given_rs;
		        end;
		    end;

/* lozenge corners */

		  else if crl = 1	/* first line? */
		  then
		    do;
		      ctb.lopen = ctb.lopen + 1;
				/* open a left slant rule */
		      ctb.open = ctb.open + 1;
		      goto check_ls_term;
		    end;		/* look for a continued rule */
		  do ssym = 1 to ptb.scnt
		       while (
		       ^((ptb.lslnt (ssym) | ptb.lstrt (ssym))
		       & ptb.pos (ssym) + oneEN = ctbe.pos));
		  end;

		  if ssym <= ptb.scnt
				/* found one? */
		  then
		    do;
		      ctbe.loz = ptb.loz (ssym);
		      ctbe.hadj = ptb.hadj (ssym) + EN3;
		      goto check_ls_term;
		    end;

		  ctb.lopen = ctb.lopen + 1;
				/* count a new slant rule */
		  ctb.open = ctb.open + 1;

check_ls_term:
		  ctbe.width = oneEN;

		  if ctb.lopen > 0 & ctbe.vterm
		  then
		    do;
		      ctb.open = ctb.open - 1;
				/* if a terminator, adjust rule count */
		      ctb.lopen = ctb.lopen - 1;
		      ctbe.vterm = "0"b;
				/* change flag */
		      ctbe.lterm = "1"b;
		    end;
end_given_ls:			/* end given left slant syntax */
		end;

/* right slants */
	        if ctbe.rslnt
	        then
		do;

		  if ctbe.pos = 0	/* if in column 1 */
		  then
		    do;
		      call comp_report_ (2, 0,
			 "Right slant line violates left margin.",
			 addr (txtlin.info), txtstr);
		      syntax_error = "1"b;
		      goto scan_continue;
		    end;

		  if crl = 1	/* if first line of an art block */
		  then
		    do;
		      ctb.ropen = ctb.ropen + 1;
				/* open a right slant rule */
		      ctb.open = ctb.open + 1;
		      goto check_rs_term;
		    end;

		  do ssym = 1 to ptb.scnt
				/* look for a continued rule */
		       while (
		       ^((ptb.rslnt (ssym) | ptb.rstrt (ssym))
		       & ptb.size (ssym) = 0
		       & ptb.pos (ssym) - oneEN = ctbe.pos));
		  end;

		  if ssym <= ptb.scnt
				/* found one? */
		  then
		    do;
		      ctbe.loz = ptb.loz (ssym);
		      ctbe.hadj = ptb.hadj (ssym) - EN3;
		      goto check_rs_term;
		    end;

		  ctb.ropen = ctb.ropen + 1;
				/* count a new right slant rule */
		  ctb.open = ctb.open + 1;

check_rs_term:
		  if ctb.ropen > 0 & ctbe.vterm
		  then
		    do;
		      ctb.open = ctb.open - 1;
				/* if a terminator, adjust rule count */
		      ctb.ropen = ctb.ropen - 1;
		      ctbe.vterm = "0"b;
				/* change flag */
		      ctbe.rterm = "1"b;
		    end;
end_given_rs:			/* end given right slant syntax */
		end;

/* vertical rules */
	        if ctbe.vert	/* if a vertical rule */
	        then
		do;
		  trans_str =
		       trans_str
		       || substr (const.art_symbols, vert_ndx, 1);

		  if crl = 1	/* if first line of an art block */
		  then
		    do;		/* open a vertical rule */
		      ctb.vopen = ctb.vopen + 1;
		      ctb.open = ctb.open + 1;
		    end;

		  else
		    do;		/* check for a redundant symbol */
		      do ssym = 1 to ptb.scnt
			 while (
			 ^
			 ((ptb.vert (ssym)
			 |
			 substr (addr (ptb.e (ssym)) -> pflags,
			 boxtl_ndx, 6) ^= "0"b) & ^ptb.vterm (ssym)
			 & ptb.pos (ssym) = ctbe.pos));
		      end;	/**/
				/* if not redundant */
		      if ssym > ptb.scnt
		      then
		        do;	/* open a new rule */
			ctb.vopen = ctb.vopen + 1;
			ctb.open = ctb.open + 1;
		        end;
		    end;

		  ctbe.width = 0;
		  zer_adj = 1;

		  if ctbe.daro
		  then trans_str =
			  trans_str
			  || substr (const.art_symbols, daro_ndx, 1);
		  if ctbe.uparo
		  then trans_str =
			  trans_str
			  || substr (const.art_symbols, uparo_ndx, 1);
		end;

	        if ctbe.vterm & ^ctbe.lslnt & ^ctbe.rslnt
	        then
		do;
		  trans_str =
		       trans_str
		       || substr (const.art_symbols, vterm_ndx, 1);
				/* check for an overprint */
		  if crl > 1 & ctb.vopen > 0 & ctb.depth = ptb.depth
		  then
		    do;
		      do ssym = 1 to ptb.scnt
			 while (
			 ^
			 ((ptb.vert (ssym)
			 |
			 substr (addr (ptb.e (ssym)) -> pflags,
			 boxbl_ndx, 3) = "0"b) & ^ptb.vterm (ssym)
			 & ptb.pos (ssym) = ctbe.pos));
		      end;
		      if ssym <= ptb.scnt
				/* if it overprints */
		      then ctbe.blind = "1"b;
				/* make this one blind */
		    end;

		  ctb.open = ctb.open - 1;
		  ctb.vopen = ctb.vopen - 1;
		  ctbe.width = 0;
		  zer_adj = 1;
		  ctbe.vert = "1"b; /* assure vert is set */
		end;

/* circles */
	        if (ctbe.lprn | ctbe.rprn) & ctbe.size = 0
				/* not a math symbol */
	        then
		do;
		  if copen = 0 & ctbe.lprn & ^ctbe.rprn
		  then copen = copen + 1;

		  if copen > 0 & ctbe.rprn
		  then copen = copen - 1;
		  ctbe.width = oneEN;
		  if ctbe.lprn
		  then trans_str =
			  trans_str
			  || substr (const.art_symbols, lprn_ndx, 1);
		  if ctbe.rprn
		  then trans_str =
			  trans_str
			  || substr (const.art_symbols, rprn_ndx, 1);
		end;

/* diamonds */
	        if ctbe.uparo & ^ctbe.vert
	        then
		do;
		  if ctbe.pos = 0	/* if column 1 */
		  then
		    do;
		      call comp_report_ (2, 0,
			 "Diamond top vertex in column 1",
			 addr (txtlin.info), txtstr);
		      syntax_error = "1"b;
		    end;

		  else
		    do;		/* open a new diamond */
		      ctbe.diam = "1"b;
		      ctb.open = ctb.open + 1;
		      ctb.dopen = ctb.dopen + 1;
		      ctbe.width = oneEN;
		    end;
		end;

	        if ctb.dopen > 0	/* other diamond parts */
	        then
		do;
		  if ctbe.laro	/* if a left arrow */
		       & ^(ctbe.star | ctbe.horiz
				/* and not horiz */
		       | ctbe.raro) /* or point-to-point arrows */
		  then
		    do;		/* then a diamond left vertex */
		      ctbe.diam = "1"b;

		      if ctb.dopen > 0
				/* if any open,  */
			 & crl > 1/* and this not the first line, */
		      then
		        do;	/* scan previous line for a */
				/* diamond right slant */
			do ssym = 1 to ptb.scnt
			     while (
			     ^(ptb.rslnt (ssym) & ptb.diam (ssym)
			     & ctbe.pos = ptb.pos (ssym) - oneEN));
			end;	/**/
				/* if a right slant was found */
			if ssym <= ptb.scnt
			then ctbe.hadj = ptb.hadj (ssym) - EN6;
		        end;
		      ctbe.width = oneEN;
		    end;		/**
				/* if a right arrow */
		  if ctbe.raro	/* & not horiz */
		       & ^ctbe.star & ^ctbe.horiz
		  then
		    do;		/* its a diamond right vertex */
		      ctbe.diam = "1"b;
				/* if any diamonds open, and */
				/* this isnt the first line, */
				/* scan previous line for a */
				/* for a diamond left slant */
		      if ctb.dopen > 0 & crl > 1
		      then
		        do;
			do ssym = 1 to ptb.scnt
			     while (
			     ^((ptb.lslnt (ssym)) & ptb.diam (ssym)
			     & ctbe.pos = ptb.pos (ssym) + oneEN));
			end;	/**/
				/* if one was found */
			if ssym <= ptb.scnt
			then ctbe.hadj = ptb.hadj (ssym) - EN6;
		        end;
		      ctbe.width = oneEN;
		    end;

		  if ctb.dopen > 0 & ctbe.daro & ^ctbe.vert
		  then
		    do;
		      ctbe.diam = "1"b;
		      ctbe.width = oneEN;
		      ctb.open = ctb.open - 1;
		      ctb.dopen = ctb.dopen - 1;
		    end;
		end;
	      end;		/* line art syntax check */

db_pr:				/* its a valid symbol */
	    prs_pos = ctbe.pos;	/* + ctbe.hadj;*/
	    prs_width = ctbe.width;	/**/
				/* translate art construct to PADs */
	    substr (tmpstr, crx, scndx - crx + 1) =
	         translate (substr (tmpstr, crx, scndx - crx + 1),
	         high (length (trans_str)), trans_str);
				/* is there an overstrike? */
	    if substr (tmpstr, crx, scndx - crx + 1)
	         ^= high (scndx - crx + 1)
	    then pad_adj = 1;
	    if verify (substr (tmpstr, crx), PAD) > 0
	    then prx = crx + verify (substr (tmpstr, crx), PAD) - 2;

	    if detail_sw
	    then call ioa_ ("^-^2d- ^f (h^f b^f w^f z^d p^d) ^a", crs,
		    show (prs_pos, 12000), show (ctbe.hadj, 12000),
		    show (ctbe.base, 12000), show (ctbe.width, 12000),
		    zer_adj, pad_adj, symbstr);
	    ctb.scnt = crs;
	    crs = crs + 1;		/* advance to next entry */
	    cptr = addr (ctb.e (crs));
	    unspec (ctb.e (crs)) = ""b;

scan_continue:			/* find next BSP or DC1 */
	    j = search (substr (tmpstr, scndx + 1), BSP || DC1);

	    if j > 0		/* if there is one */
	    then
	      do;			/**/
				/* if its DC1 */
	        if substr (tmpstr, scndx + j, 1) = DC1
	        then
		do;		/* step over dev ctl string */
		  scndx = scndx
		       + rank (substr (tmpstr, scndx + j + 2, 1)) + j + 2;
		  goto scan_continue;
		end;

	        scndx, crx = scndx + j - 1;
				/* set index to next artwork char */
	      end;

	    else crx = length (tmpstr) + 1;
				/* aint no more */
	  end scan_loop;
	end;

        if crx > 1 & crx < length (tmpstr)
				/* check symbol count limit */
        then
	do;
	  call comp_report_ (2, 0,
	       "Implementation restriction. "
	       || "No more than 100 symbols in a line.", addr (txtlin.info),
	       txtstr);
	  syntax_error = "1"b;
	  goto build;		/* go build what we have */
	end;

/* any trailing text? */
        if length (tmpstr) > prx	/* anything after the last symbol? */
        then
	do;
	  j = verify (substr (tmpstr, /* scan for 1st non-blank since */
	       prx + 1), " " || PAD); /* last symbol */

	  if j > 0
	  then
	    do;			/* add entry for trailing text */
	      crs, ctb.scnt = ctb.scnt + 1;
	      cptr = addr (ctb.e (crs));
	      unspec (ctb.e (crs)) = ""b;
				/* and clear it */
	      ctbe.text = "1"b;	/* set text entry flag */
	      ctbe.base = base;	/* set baseline offset */

	      ctbe.tstrt = prx + j;	/* input start */
	      ctbe.len = length (tmpstr) - prx - j + 1;

	      if ^(ctb.scnt = 1 & ctbe.text) | ctbe.width = 0
	      then
	        do;
		unspec (meas1) = "0"b;
		call comp_measure_ (substr (tmpstr, ctbe.tstrt),
		     addr (txtlin.font), (txtlin.quad = just), "1"b,
		     txtlin.quad, bin (txtlin.quad = just) * txtlin.net,
		     addr (meas1), addr (meas2), addr (txtlin.info));
		ctbe.width = meas1.width + meas1.avg;
	        end;
	      else meas1 = txtlin.cur;

	      ctbe.width = meas1.width;
				/* effective text width */
	      ctbe.wsp = meas1.avg;	/**/
				/* set output position */
	      if txtlin.quad = quadr	/* setting right */
	      then ctbe.pos = prs_pos + txtlin.net - ctbe.width - ctbe.wsp;
				/* setting center */
	      else if txtlin.quad = quadc
	      then ctbe.pos =
		      prs_pos
		      + comp_dvt.min_WS
		      *
		      round (
		      divide (txtlin.net - meas1.width - ctbe.wsp,
		      2 * comp_dvt.min_WS, 17, 1), 0);

	      else ctbe.pos =	/* setting left or justfifying */
		      prs_pos + prs_width
		      + oneEN * (j - 1 + zer_adj - pad_adj);

	      if ctb.scnt > 1 | ctb.open > 0
	      then if txtlin.quad ^= just
		 then txtlin.quad = quadl;

	      if detail_sw
	      then call ioa_ ("^-^2d- ^f (h^f w^f) ^d ""^a""", crs,
		      show (ctbe.pos, 12000), show (ctbe.hadj, 12000),
		      show (ctbe.width, 12000), ctbe.len,
		      comp_util_$display (
		      substr (tmpstr, ctbe.tstrt, ctbe.len), 0, "0"b));
	    end;
	end;
%page;
/* FINAL SYNTAX CHECK FOR LINE ART */

/* horizontals */
        if hopen
        then
	do;
	  call comp_report_ (2, 0, "Unterminated horizonal line.",
	       addr (txtlin.info), txtstr);
	  ctbe.star = "1"b;		/* term it */
	  syntax_error = "1"b;
	  hopen = "0"b;		/* close the open line */
	end;

/* circles */
        if copen > 0
        then
	do;
	  call comp_report_ (2, 0, "Missing right semi-circle(s).",
	       addr (txtlin.info), txtstr);
	  syntax_error = "1"b;
	  copen = 0;		/* close it */
	end;

/* empty line - all lines continued */
        if ctb.scnt = 0
        then
	do;
	  cptr = addr (ctb.e (1));	/* clear 1st text entry */
	  unspec (ctbe) = "0"b;

	  if detail_sw
	  then call ioa_ ("^-1- ^f Blank line", show (ctbe.pos, 12000));
	end;

/* if any open lineart stuff */
        if ctb.open > 0 & crl > 1
        then
	do;

/* verticals */
	  if ctb.vopen > 0		/* if there are still some open */
	  then
	    do ssym = 1 to ptb.scnt;	/* scan previous line */

	      if (ptb.vert (ssym)
		 | substr (addr (ptb.e (ssym)) -> pflags, boxtl_ndx, 6)
		 ^= "0"b) & ^ptb.vterm (ssym)
	      then
	        do;		/* for each one found, look for a */
				/* matching one in current line */
		do i = 1 to ctb.scnt
		     while (
		     ^
		     ((ctb.vert (i)
		     | substr (addr (ctb.e (i)) -> cflags, boxl_ndx, 6)
		     ^= "0"b) & ctb.pos (i) = ptb.pos (ssym)));
		end;

		if i > ctb.scnt	/* if no match, add a vertical */
		then
		  do;
		    crs, ctb.scnt = i;
		    cptr = addr (ctb.e (crs));
		    unspec (ctb.e (crs)) = ""b;
				/* clear an entry */
		    ctbe.vert = "1"b;
		    ctbe.pos = ptb.pos (ssym);
		    ctbe.base = ptb.base (ssym);
		    ctbe.blind =	/* make it blind if it overprints */
		         ctb.depth = ptb.depth;
		  end;
	        end;
	    end;

/* diamonds */
	  if ctb.dopen > 0		/* if there are still diamonds open */
	  then
	    do ssym = 1 to ptb.scnt;	/* search previous line for */
	      if ptb.diam (ssym)	/* diamond parts */
	      then
	        do;

/* diamond top vertices */
		if ptb.uparo (ssym) & ^ptb.daro (ssym)
		then
		  do;
		    if ctb.scnt > 0 /* look for redundant */
		    then		/* left side symbol */
		      do i = 1 to ctb.scnt
			 while (
			 ^((ctb.rslnt (i) | ctb.laro (i))
			 & ctb.pos (i) = ptb.pos (ssym) - oneEN)
			 &
			 ^(ctb.daro (i) & ctb.pos (i) = ptb.pos (ssym)));
		      end;
		    else i = 1;

		    if i > ctb.scnt /* if a new symbol is needed */
		    then
		      do;
		        crs, ctb.scnt = i;
		        cptr = addr (ctb.e (crs));
		        unspec (ctbe) = ""b;

		        if txtlin.linespace = 0
		        then
			do;
			  ctbe = ptb.e (ssym);
			  ctbe.blind = "1"b;
			end;

		        else
			do;	/* upper left side */
			  ctbe.rslnt, ctbe.diam = "1"b;
			  ctbe.pos = ptb.pos (ssym) - oneEN;
			  ctbe.hadj = ptb.hadj (ssym) - EN6;
			end;
		      end;	/**/
				/* look for redundant */
		    if ctb.scnt > 0 /* right side symbol */
		    then
		      do i = 1 to ctb.scnt
			 while (
			 ^((ctb.lslnt (i) | ctb.raro (i))
			 & ctb.pos (i) = ptb.pos (ssym) + oneEN)
			 &
			 ^(ctb.daro (i) & ctb.pos (i) = ptb.pos (ssym)));
		      end;
		    else i = 1;

		    if i > ctb.scnt /* if a new symbol is needed */
		    then
		      do;
		        crs, ctb.scnt = i;
		        cptr = addr (ctb.e (crs));
		        unspec (ctbe) = ""b;

		        if txtlin.linespace = 0
		        then
			do;
			  ctbe = ptb.e (ssym);
			  ctbe.blind = "1"b;
			end;

		        else
			do;	/* upper right side */
			  ctbe.lslnt, ctbe.diam = "1"b;
			  ctbe.pos = ptb.pos (ssym) + oneEN;
			  ctbe.hadj = ptb.hadj (ssym) + EN3;
			end;
		      end;
		  end;

/* diamond right slants */
		if ptb.rslnt (ssym)
		then
		  do;
		    if ctb.scnt > 0
		    then
		      do i = 1 to ctb.scnt
			 while (
			 ^((ctbe.rslnt | ctb.laro (i) | ctb.daro (i))
			 & ctb.pos (i) = ptb.pos (ssym) - oneEN));
		      end;
		    else i = 1;

		    if i > ctb.scnt /* new symbol */
		    then
		      do;
		        crs, ctb.scnt = i;
		        cptr = addr (ctb.e (crs));

		        if txtlin.linespace = 0
		        then
			do;
			  ctbe = ptb.e (ssym);
			  ctbe.blind = "1"b;
			end;

		        else
			do;
			  unspec (ctb.e (crs)) = ""b;
				/* clear an entry */
			  if ptb.pos (ssym) = 0
			  then
			    do;
			      call comp_report_ (2, 0,
				 "Diamond violates left margin.",
				 addr (txtlin.info), txtstr);
			      ctb.dopen = ctb.dopen - 1;
			      ctb.open = ctb.open - 1;
			      syntax_error = "1"b;
			    end;

			  else
			    do;
			      ctbe.rslnt, ctbe.diam = "1"b;
			      ctbe.pos = ptb.pos (ssym) - oneEN;
			      ctbe.hadj = ptb.hadj (ssym) - EN3;
			      ctbe.base = ptb.base (ssym);
			    end;
			end;
		      end;
		  end;

/* diamond left slants */
		if ptb.lslnt (ssym)
		then
		  do;

		    if ctb.scnt > 0
		    then		/* look for previous left slant */
		      do i = 1 to ctb.scnt
			 while (
			 ^((ctb.lslnt (i) | ctb.raro (i) | ctb.daro (i))
			 & ctb.pos (i) = ptb.pos (ssym) + oneEN));
		      end;
		    else i = 1;

		    if i > ctb.scnt /* new symbol */
		    then
		      do;
		        crs, ctb.scnt = i;
		        cptr = addr (ctb.e (crs));

		        if txtlin.linespace = 0
		        then
			do;
			  ctbe = ptb.e (ssym);
			  ctbe.blind = "1"b;
			end;

		        else
			do;
			  unspec (ctb.e (crs)) = ""b;
				/* clear an entry */
			  ctbe.lslnt, ctbe.diam = "1"b;
			  ctbe.pos = ptb.pos (ssym) + oneEN;
			  ctbe.hadj = ptb.hadj (ssym) + EN3;
			  ctbe.base = ptb.base (ssym);
			end;
		      end;
		  end;

/* diamond left vertices */
		if ssym < ptb.scnt
		then if ptb.laro (ssym) & ^ptb.horiz (ssym)
			&
			^(ptb.raro (ssym + 1)
			& ptb.pos (ssym) = ptb.pos (ssym + 1) - oneEN)
		     then
		       do;
		         if ctb.scnt > 0
		         then	/* look for bottom vertex */
				/* in this line */
			 do i = 1 to ctb.scnt
			      while (
			      ^(ctb.daro (i)
			      & ctb.pos (i) = ptb.pos (ssym) + oneEN));
			 end;
		         else i = 1;/**/
				/* no bottom, add a left slant */
		         if i > ctb.scnt
		         then
			 do;
			   crs, ctb.scnt = i;
			   cptr = addr (ctb.e (crs));
			   unspec (ctbe) = ""b;

			   if txtlin.linespace = 0
			   then
			     do;
			       ctbe = ptb.e (ssym);
			       ctbe.blind = "1"b;
			     end;

			   else
			     do;
			       ctbe.lslnt, ctbe.diam = "1"b;
			       ctbe.pos = ptb.pos (ssym) + oneEN;
			       ctbe.hadj = ptb.hadj (ssym) + EN3;
			       ctbe.base = ptb.base (ssym);
			     end;
			 end;
		       end;

/* diamond right vertices */
		if ssym > 1	/* must be left vertex on same line */
		then if ptb.raro (ssym) & ^ptb.horiz (ssym)
			&
			^(ptb.laro (ssym - 1)
			& ptb.pos (ssym) = ptb.pos (ssym - 1) + oneEN)
		     then
		       do;	/**/
				/* look for bottom vertex */
				/* on this line */
		         if ctb.scnt > 0
		         then
			 do i = 1 to ctb.scnt
			      while (
			      ^(ctb.daro (i)
			      & ctb.pos (i) = ptb.pos (ssym) - oneEN));
			 end;
		         else i = 1;/**/
				/* if no bottom add a right slant */
		         if i > ctb.scnt
		         then
			 do;
			   crs, ctb.scnt = i;
			   cptr = addr (ctb.e (crs));
			   unspec (ctb.e (crs)) = ""b;

			   if txtlin.linespace = 0
			   then
			     do;
			       ctbe = ptb.e (ssym);
			       ctbe.blind = "1"b;
			     end;

			   else
			     do;
			       ctbe.rslnt, ctbe.diam = "1"b;
			       ctbe.pos = ptb.pos (ssym) - oneEN;
			       ctbe.hadj = ptb.hadj (ssym) - EN6;
			       ctbe.base = ptb.base (ssym);
			     end;
			 end;
		       end;
	        end;
	    end;

/* left slants */
	  if ctb.lopen > 0		/* if there are still some open */
	  then
	    do ssym = 1 to ptb.scnt;	/* scan previous line */
	      if (ptb.lslnt (ssym) | ptb.loztr (ssym) | ptb.lozl (ssym))
		 & ^ptb.lterm (ssym) & ^ptb.diam (ssym)
	      then
	        do;

		if ctb.scnt > 0	/* look for a redundant symbol */
		then
		  do i = 1 to ctb.scnt
		       while (
		       ^
		       ((ctb.lslnt (i) | ctb.lozr (i)
		       | ctb.lozbl (i) & ptb.lozl (ssym))
		       & ctb.pos (i) = ptb.pos (ssym) + oneEN
		       | ctb.lozbl (i) & ptb.lslnt (ssym)
		       & ctb.pos (i) = ptb.pos (ssym) + 2 * oneEN));
		  end;
		else i = 1;

		if i > ctb.scnt	/* need an added symbol */
		then
		  do;
		    crs, ctb.scnt = i;
				/* count the new symbol */
		    cptr = addr (ctb.e (crs));

		    if txtlin.linespace = 0
		    then
		      do;
		        ctbe = ptb.e (ssym);
		        ctbe.blind = "1"b;
		      end;

		    else
		      do;
		        unspec (ctb.e (crs)) = ""b;
				/* clear an entry */
		        ctbe.lslnt = "1"b;
				/* set flags */
		        ctbe.loz = ptb.loz (ssym);

		        if ptb.lozl (ssym)
				/* a lozenge vertex? */
		        then
			do;
			  ctbe.pos = ptb.pos (ssym);
				/* vertex */
			  ctbe.hadj = ptb.hadj (ssym) + EN6;
			end;

		        else
			do;
			  ctbe.pos = ptb.pos (ssym) + oneEN;
			  ctbe.hadj = ptb.hadj (ssym) + EN3;
			end;
		        ctbe.base = ptb.base (ssym);
				/* set baseline */
		      end;
		  end;
	        end;
	    end;

/* right slants */
	  if ctb.ropen > 0		/* if there are still some open */
	  then
	    do ssym = 1 to ptb.scnt;	/* search previous line */
	      if (ptb.rslnt (ssym) | ptb.loztl (ssym) | ptb.lozr (ssym))
		 & ^(ptb.rterm (ssym) | ptb.diam (ssym))
	      then
	        do;

		if ctb.scnt > 0	/* check for redundant symbols */
		then
		  do i = 1 to ctb.scnt
		       while (
		       ^
		       ((ctb.rslnt (i) | ctb.lozbr (i) & ptb.lozr (ssym)
		       | ctb.lozl (i))
		       & ctb.pos (i) = ptb.pos (ssym) - oneEN
		       | ctb.lozbr (i) & ptb.rslnt (ssym)
		       & ctb.pos (i) = ptb.pos (ssym) - 2 * oneEN));
		  end;
		else i = 1;

		if i > ctb.scnt	/* if a new entry is needed */
		then
		  do;
		    if ptb.pos (ssym) <= oneEN
		    then
		      do;
		        call comp_report_ (2, 0,
			   "Right slant line violates "
			   || "left margin.", addr (txtlin.info), txtstr)
			   ;
		        ctb.ropen = ctb.ropen - 1;
		        ctb.open = ctb.open - 1;
		        syntax_error = "1"b;
		        goto synchk_continue;
		      end;

		    crs, ctb.scnt = i;
				/* count new symbol */
		    cptr = addr (ctb.e (crs));

		    if txtlin.linespace = 0
		    then
		      do;
		        ctbe = ptb.e (ssym);
		        ctbe.blind = "1"b;
		      end;

		    else
		      do;
		        unspec (ctb.e (crs)) = ""b;
				/* clear new entry */
		        ctbe.rslnt = "1"b;
				/* set flags */
		        ctbe.loz = ptb.loz (ssym);

		        if ptb.lozr (ssym)
				/* loz right vertex? */
		        then
			do;
			  ctbe.pos = ptb.pos (ssym);
			  ctbe.hadj = ptb.hadj (ssym) - EN6;
			end;

		        else
			do;
			  ctbe.pos = ptb.pos (ssym) - oneEN;
			  if ptb.loztl (ssym)
			  then ctbe.hadj = ptb.hadj (ssym) - EN6;
			  else ctbe.hadj = ptb.hadj (ssym) - EN3;
			end;
		        ctbe.base = ptb.base (ssym);
		      end;
		  end;
	        end;
	    end;
synchk_continue:
	end;			/* vertical stuff */
%page;
/* PREPARE OUTPUT FROM LINES GATHERED */

build:
        if ctb.scnt > 0		/* if there are any symbols */
        then
build_loop:
	do;
	  ctb.line_width = 0;	/* preset width */

/* sort symbols */
	  i = 0;
	  do j = 1 to ctb.scnt;	/* go thru all symbols */
	    if addr (ctb.e (j)) -> cflags
				/* if the entry does */
	    then
	      do;			/* something, then keep it */
	        i = i + 1;
	        ctb.e (i) = ctb.e (j);
	      end;
	  end;
	  ctb.scnt = i;		/* new symbol count */

pass:
	  swaps = 0;
	  do j = 1 to ctb.scnt - 1;	/* linear sort so that order
				   within a column is not lost */
	    if ctb.pos (j) > ctb.pos (j + 1)
	    then
	      do;
	        swaps = swaps + 1;
	        temp_entry = ctb.e (j);
	        ctb.e (j) = ctb.e (j + 1);
	        ctb.e (j + 1) = temp_entry;
	      end;
	  end;
	  if swaps > 0
	  then goto pass;

	  if detail_sw
	  then call ioa_ ("^5xBUILD (lin=^d/^d,#sym=^d)", crl, txtlin.lineno,
		  ctb.scnt);

	  text_pos = 0;		/* start at left margin */
	  base = 0;		/* reset baseline offset */
	  art_str = "";		/* clear the target line */

	  if ctb.scnt = 1 & ctb.e (1).text
	  then
	    do;
	      if detail_sw
	      then call ioa_ ("^- 1- ^f Text only line",
		      show (ctbe.pos, 12000));
	      goto end_line_loop;
	    end;

	  do crs = 1 to ctb.scnt;	/* scan line table */
	    cptr = addr (ctb.e (crs));/* set entry pointer */
				/* symbol position */
	    crs_pos = ctbe.pos + ctbe.hadj;

/* position adjustments */
	    if ctbe.base ^= base	/* baseline change needed? */
	    then call vtab_ (ctbe.base);

/* text */
	    if ctbe.text
	    then
	      do;
	        if crs_pos ^= text_pos
	        then call htab_;

	        if detail_sw
	        then call ioa_ ("^-^2d- Text at ^f b^f w^f (^d) ""^a^vx""",
		        crs, show (crs_pos, 12000), show (base, 12000),
		        show (ctbe.width, 12000), ctbe.len,
		        comp_util_$display (
		        substr (tmpstr, ctbe.tstrt, ctbe.len), 0, "0"b),
		        ctbe.len
		        -
		        length (
		        rtrim (substr (tmpstr, ctbe.tstrt, ctbe.len))));

	        if shared.trans.in ^= ""
	        then art_str =
		        art_str
		        ||
		        comp_util_$translate (
		        substr (tmpstr, ctbe.tstrt, ctbe.len));
	        else art_str =
		        art_str || substr (tmpstr, ctbe.tstrt, ctbe.len);

	        if txtlin.quad = just /* a justified line? */
	        then
		do;
		  if crs = ctb.scnt /* trailing text? */
		  then text_pos = txtlin.rmarg;

		  else		/* embedded text */
		    do;
		      if ctbe.wsp > 0
		      then text_pos =
			      min (txtlin.rmarg, ctb.e (crs + 1).pos);
		      else text_pos =
			      min (crs_pos + ctbe.width,
			      ctb.e (crs + 1).pos);
		    end;

		  ctb.line_width = ctb.line_width + ctbe.width;
		end;

	        else		/* not justified */
		do;
		  text_pos = crs_pos + ctbe.width + ctbe.wsp;
		  ctb.line_width = ctb.line_width + ctbe.width + ctbe.wsp;
		end;
	      end;

/* SYMBOLS */
	    if ctbe.size > 0	/* reset minipos flags */
	    then substr (cflags, first_mini_pos, 4) = "0000"b;

/* math symbols */
	    if substr (cflags, 1, last_math) ^= "0"b & ctbe.size > 0
				/* with a valid size */
	         & ^option.noart_opt
	    then
	      do;			/* symbol half size */
	        half_size = divide (ctbe.size, 2, 17, 0) + 1;
	        symbndx = index (cflags, "1"b);
				/* set symbol index */
	        if crs_pos ^= text_pos
	        then call htab_;

/* tops & one-highs */
	        if ctbe.lndx = 1
	        then
		do;
		  if ctbe.size = 1
		  then
		    do;
		      art_str = art_str || art.one (symbndx);
		      ctb.line_width = ctb.line_width + ctbe.width;

		      if detail_sw
		      then call ioa_ (
			      "^-^2d- ^a^i 1-high at ^f b^f w^f ^a", crs,
			      substr (const.art_symbols, symbndx, 1),
			      ctbe.size, show (crs_pos, 12000),
			      show (base, 12000),
			      show (ctbe.width, 12000),
			      comp_util_$display ((art.one (symbndx)), 0,
			      "0"b));
		    end;

		  else
		    do;
		      if mod (ctbe.size, 2) = 1
		      then
		        do;
			art_str = art_str || char (art.top (symbndx));

			if detail_sw
			then call ioa_ (
				"^-^2d- ^a^i top at ^f (b^f w^f)", crs,
				substr (const.art_symbols, symbndx, 1),
				ctbe.size, show (crs_pos, 12000),
				show (base, 12000),
				show (ctbe.width, 12000));
		        end;

		      else
		        do;
			art_str =
			     art_str || char (art.half_top (symbndx));
			if detail_sw
			then call ioa_ (
				"^-^2d- ^a^i half-top at ^f (^f)", crs,
				substr (const.art_symbols, symbndx, 1),
				ctbe.size, show (crs_pos, 12000),
				show (base, 12000));
		        end;
		    end;
		end;

/* middles */
	        else if (ctbe.lndx = half_size)
	        then
		do;
		  if ctbe.lndx = ctbe.size
		  then		/* if two-high */
		    do;
		      art_str =
			 art_str || char (art.half_bottom (symbndx))
			 || char (art.middle (symbndx));
		      if detail_sw
		      then call ioa_ (
			      "^-^2d- ^a^d half-bottom & middle at ^f (^f)"
			      , crs,
			      substr (const.art_symbols, symbndx, 1),
			      ctbe.size, show (crs_pos, 12000),
			      show (base, 12000));
		    end;

		  else
		    do;
		      art_str = art_str || char (art.middle (symbndx));
		      if detail_sw
		      then call ioa_ ("^-^2d- ^a^d middle at ^d (^d)", crs,
			      substr (const.art_symbols, symbndx, 1),
			      ctbe.size, crs_pos, base);
		    end;
		end;

/* bottoms */
	        else if ctbe.lndx = ctbe.size
	        then
		do;
		  if mod (ctbe.size, 2) = 1
		  then
		    do;
		      art_str = art_str || char (art.bottom (symbndx));
		      if detail_sw
		      then call ioa_ ("^-^2d- ^a bottom at ^d (^d)", crs,
			      substr (const.art_symbols, symbndx, 1),
			      crs_pos, base);
		    end;

		  else if ctbe.size > 2
		  then
		    do;
		      art_str =
			 art_str || char (art.half_bottom (symbndx))
			 || char (art.other_part (symbndx));
		      if detail_sw
		      then call ioa_ (
			      "^-^2d- ^a half-bottom & other part at ^f (^f)"
			      , crs,
			      substr (const.art_symbols, symbndx, 1),
			      show (crs_pos, 12000), show (base, 12000));
		    end;
		end;

/* other parts */
	        else if ctbe.lndx > 1
	        then
		do;
		  art_str = art_str || char (art.other_part (symbndx));
		  if detail_sw
		  then call ioa_ ("^-^2d- ^a other part at ^d (^d)", crs,
			  substr (const.art_symbols, symbndx, 1),
			  crs_pos, base);
		end;
	        else art_str = art_str || EN;
				/* all math symbols take one column */
	        text_pos = crs_pos + oneEN;
	      end;

/* Build line art */

	    else if ^option.noart_opt
	    then
	      do;

/* lozenge tops */
	        if ctbe.loztl
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;	/* search for terminator */
		  do i = crs to ctb.scnt while (^ctb.loztr (i));
		  end;
		  hcnt = ctb.e (i).pos - crs_pos;
		  hor_vec.v1 = hcnt - oneEN;

		  if detail_sw
		  then call ioa_ ("^-^2d- lozenge top left corner at ^f"
			  || "^/^-^4xlozenge top from ^f to ^f ^a"
			  || "^/^-^2d- lozenge top right corner at ^f",
			  crs, show (crs_pos, 12000),
			  show (crs_pos, 12000),
			  show (crs_pos + hcnt, 12000),
			  comp_util_$display ((hor_vec_str), 0, "0"b), i,
			  show (crs_pos + hcnt, 12000));

		  art_str =
		       art_str || art.loz.tl || hor_vec_str || art.loz.tr;
		  text_pos = crs_pos + hcnt;
				/* update text position */
		end;

/* lozenge vertices */
	        if ctbe.lozl	/* left vertex */
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  if detail_sw
		  then call ioa_ ("^-^2d- lozenge left vertex at ^f", crs,
			  show (crs_pos, 12000));

		  art_str = art_str || art.loz.l;
		  text_pos = crs_pos + ctbe.width;
		  ctb.line_width = ctb.line_width + ctbe.width;
		end;

	        if ctbe.lozr	/* right vertex */
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  if detail_sw
		  then call ioa_ ("^-^2d- lozenge right vertex at ^f", crs,
			  show (crs_pos, 12000));

		  art_str = art_str || art.loz.r;
		  text_pos = crs_pos + ctbe.width;
		  ctb.line_width = ctb.line_width + ctbe.width;

		  if ctbe.horiz	/* also starting hrule? */
		  then goto hrule;
		end;

/* lozenge bottoms */
	        if ctbe.lozbl
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;	/* search for terminator */
		  do i = crs to ctb.scnt while (^ctb.lozbr (i));
		  end;
		  hcnt = ctb.e (i).pos - crs_pos;
		  hor_vec.v1 = hcnt - oneEN;

		  if detail_sw
		  then call ioa_ ("^-^2d- lozenge bottom left corner at ^f"
			  || "^/^-^4xlozenge bottom from ^f to ^f ^a"
			  ||
			  "^/^-^2d- lozenge bottom right corner at ^f",
			  crs, show (crs_pos, 12000),
			  show (crs_pos, 12000),
			  show (crs_pos + hcnt, 12000),
			  comp_util_$display ((hor_vec_str), 0, "0"b), i,
			  show (crs_pos + hcnt, 12000));

		  art_str =
		       art_str || art.loz.bl || hor_vec_str || art.loz.br;
		  text_pos = crs_pos + hcnt;
				/* update text position */
		end;

/* verticals */
	        if ctbe.vert & ctbe.size = 0 & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  art_str = art_str || art.vpart;

		  if detail_sw
		  then call ioa_ (
			  "^-^2d- vertical at ^f (w^f b^f)  ""^a""", crs,
			  show (crs_pos, 12000),
			  show (ctbe.width, 12000), show (base, 12000),
			  comp_util_$display ((art.vpart), 0, "0"b));
		end;

/* down arrows */
	        if ctbe.daro & ^ctbe.diam & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || char (art.daro);
		  if detail_sw
		  then call ioa_ ("^-^2d- down arrow at ^f", crs,
			  show (crs_pos, 12000));
		end;

/* up arrows */
	        if ctbe.uparo & ^ctbe.diam & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || char (art.uparo);
		  if detail_sw
		  then call ioa_ ("^-^2d- up arrow at ^d", crs,
			  show (crs_pos, 12000));
		end;

/* diamond parts */
	        if ctbe.diam & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

/* diamond tops */
		  if ctbe.uparo
		  then
		    do;
		      art_str = art_str || art.diam.top;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond top at ^f", crs,
			      show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;

/* diamond left vertices */
		  if ctbe.laro
		  then
		    do;
		      art_str = art_str || art.diam.lvert;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond left vertex at ^f",
			      crs, show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;

/* diamond right vertices */
		  if ctbe.raro
		  then
		    do;
		      art_str = art_str || art.diam.rvert;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond right vertex at ^f",
			      crs, show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;

/* diamond left slants */
		  if ctbe.lslnt
		  then
		    do;
		      art_str = art_str || art.lslnt;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond left slant at ^f",
			      crs, show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;

/* diamond right slants */
		  if ctbe.rslnt
		  then
		    do;
		      art_str = art_str || art.rslnt;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond right slant at ^f",
			      crs, show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;

/* diamond bottoms */
		  if ctbe.daro
		  then
		    do;
		      art_str = art_str || art.diam.bottom;
		      if detail_sw
		      then call ioa_ ("^-^2d- diamond bottom at ^f", crs,
			      show (crs_pos, 12000));
		      text_pos = crs_pos + oneEN;
		    end;
		end;

/* left slants */
	        if ctbe.lslnt & ^ctbe.diam & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || art.lslnt;
		  if detail_sw
		  then call ioa_ ("^-^2d- left slant at ^f", crs,
			  show (crs_pos, 12000));
		  text_pos = crs_pos + oneEN;
		end;

/* right slants */
	        if ctbe.rslnt & ^ctbe.diam & ctbe.size = 0 & ^ctbe.blind
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || art.rslnt;
		  if detail_sw
		  then call ioa_ ("^-^2d- right slant at ^f", crs,
			  show (crs_pos, 12000));
		  text_pos = crs_pos + oneEN;
		end;

/* left arrows */
	        if ctbe.laro & ^ctbe.diam
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  art_str = art_str || art.laro;

		  if detail_sw
		  then call ioa_ ("^-^2d- left arrow at ^d", crs,
			  show (crs_pos, 12000));

		  if ctbe.horiz	/* also starting hrule? */
		  then goto hrule;
		end;

/* right arrows */
	        if ctbe.raro & ^ctbe.diam
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || char (art.raro);
		  if detail_sw
		  then call ioa_ ("^-^2d- right arrow at ^f", crs,
			  show (crs_pos, 12000));
		  text_pos = crs_pos + oneEN;
		end;

/* circles */
	        if ctbe.lprn
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || art.lcirc;
		  if detail_sw
		  then call ioa_ ("^-^2d- left circle at ^d", crs, crs_pos)
			  ;
		  text_pos = crs_pos + oneEN;
		end;

	        if ctbe.rprn
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;
		  art_str = art_str || art.rcirc;
		  if detail_sw
		  then call ioa_ ("^-^2d- right circle at ^d", crs,
			  crs_pos);
		  text_pos = crs_pos + oneEN;
		end;

/* box tops */
	        if ctbe.boxtl	/* corners */
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;	/* search for terminator */
		  do i = crs to ctb.scnt
		       while (
		       ^(ctb.boxbr (i) | ctb.boxr (i) | ctb.boxtr (i)
		       | ctb.star (i)));
		  end;
		  hcnt = ctb.e (i).pos + ctb.e (i).hadj - crs_pos;
		  hor_vec.v1 = hcnt - oneEN;

		  if detail_sw
		  then
		    do;
		      if ctb.boxtr (i)
		      then j = 1;
		      else if ctb.boxr (i)
		      then j = 2;
		      else if ctb.boxbr (i)
		      then j = 3;
		      else j = 4;

		      call ioa_ ("^-^2d- box top left corner at ^f ""^a"""
			 || "^/^-^4xbox top from ^f to ^f ""^a"""
			 ||
			 "^/^-^2d- ^[box top right corner^;box right T^;"
			 ||
			 "box bottom right corner^;horiz terminator^] "
			 || "at ^f ""^[^a^;^s^a^;^2s^a^;^3s^a^]""", crs,
			 show (crs_pos, 12000),
			 comp_util_$display ((art.box.tl), 0, "0"b),
			 show (crs_pos, 12000),
			 show (crs_pos + hcnt, 12000),
			 comp_util_$display ((hor_vec_str), 0, "0"b), i,
			 j, show (crs_pos + hcnt, 12000), j,
			 comp_util_$display ((art.box.tr), 0, "0"b),
			 comp_util_$display ((art.box.r), 0, "0"b),
			 comp_util_$display ((art.box.br), 0, "0"b),
			 comp_util_$display ((art.horiz.term), 0, "0"b));
		    end;

		  art_str = art_str || art.box.tl || hor_vec_str;
		  if ctb.boxtr (i)
		  then art_str = art_str || art.box.tr;
		  else if ctb.boxr (i)
		  then art_str = art_str || art.box.r;
		  else if ctb.boxbr (i)
		  then art_str = art_str || art.box.br;
		  else art_str = art_str || art.horiz.term;

		  text_pos = crs_pos + hcnt;
				/* update text position */
		end;

	        if ctbe.boxt	/* top Ts */
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  if detail_sw
		  then call ioa_ ("^-^2d- box top T at ^f", crs,
			  show (crs_pos, 12000));

		  art_str = art_str || art.box.t;
		  text_pos = crs_pos + ctbe.width;
		  ctb.line_width = ctb.line_width + ctbe.width;
				/* update text position */
		end;

/* box left Ts */
	        if ctbe.boxl
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;	/* search for terminator */
		  do i = crs to ctb.scnt
		       while (
		       ^(ctb.boxtr (i) | ctb.boxr (i) | ctb.boxbr (i)
		       | ctb.star (i)));
		  end;
		  hcnt = ctb.e (i).pos - crs_pos;
		  hor_vec.v1 = hcnt - oneEN;

		  if detail_sw
		  then
		    do;
		      if ctb.boxtr (i)
		      then j = 1;
		      else if ctb.boxr (i)
		      then j = 2;
		      else if ctb.boxbr (i)
		      then j = 3;
		      else j = 4;

		      call ioa_ ("^-^2d- box left T at ^f"
			 || "^/^-^4xbox line from ^f to ^f ^a"
			 || "^/^-^2d- box ^[top right corner^;right T^;"
			 ||
			 "bottom right corner^;horiz terminator^] at ^f",
			 crs, show (crs_pos, 12000),
			 show (crs_pos, 12000),
			 show (crs_pos + hcnt, 12000),
			 comp_util_$display ((hor_vec_str), 0, "0"b), i,
			 j, show (crs_pos + hcnt, 12000));
		    end;

		  art_str = art_str || art.box.l || hor_vec_str;
		  if ctb.boxtr (i)
		  then art_str = art_str || art.box.tr;
		  else if ctb.boxr (i)
		  then art_str = art_str || art.box.r;
		  else if ctb.boxbr (i)
		  then art_str = art_str || art.box.br;
		  else art_str = art_str || art.horiz.term;

		  text_pos = crs_pos + hcnt;
				/* update text position */
		end;

/* box interior +s */
	        if ctbe.boxx
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  if detail_sw
		  then
		    do;
		      call ioa_ ("^-^2d- box interior + at ^f", crs,
			 show (crs_pos, 12000));
		    end;

		  art_str = art_str || art.box.x;
		  text_pos = crs_pos + ctbe.width;
		  ctb.line_width = ctb.line_width + ctbe.width;
		end;

/* box bottoms */
	        if ctbe.boxbl
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;	/* search for terminator */
		  do i = crs to ctb.scnt
		       while (
		       ^(ctb.boxbr (i) | ctb.boxr (i) | ctb.boxtr (i)
		       | ctb.star (i)));
		  end;
		  hcnt = ctb.e (i).pos - crs_pos;
		  hor_vec.v1 = hcnt - oneEN;

		  if detail_sw
		  then
		    do;
		      if ctb.boxtr (i)
		      then j = 1;
		      else if ctb.boxr (i)
		      then j = 2;
		      else if ctb.boxbr (i)
		      then j = 3;
		      else j = 4;

		      call ioa_ (
			 "^-^2d- box bottom left corner at ^f ""^a"""
			 || "^/^-^4xbox bottom from ^f to ^f ""^a"""
			 || "^/^-^2d- box ^[top right corner^;right T^;"
			 ||
			 "bottom right corner^;horiz terminator^] at ^f "
			 || """^[^a^;^s^a^;^2s^a^;^3s^a^]""", crs,
			 show (crs_pos, 12000),
			 comp_util_$display ((art.box.bl), 0, "0"b),
			 show (crs_pos, 12000),
			 show (crs_pos + hcnt, 12000),
			 comp_util_$display ((hor_vec_str), 0, "0"b), i,
			 j, show (crs_pos + hcnt, 12000), j,
			 comp_util_$display ((art.box.tr), 0, "0"b),
			 comp_util_$display ((art.box.r), 0, "0"b),
			 comp_util_$display ((art.box.br), 0, "0"b),
			 comp_util_$display ((art.horiz.term), 0, "0"b));
		    end;

		  art_str = art_str || art.box.bl || hor_vec_str;
		  if ctb.boxtr (i)
		  then art_str = art_str || art.box.tr;
		  else if ctb.boxr (i)
		  then art_str = art_str || art.box.r;
		  else if ctb.boxbr (i)
		  then art_str = art_str || art.box.br;
		  else art_str = art_str || art.horiz.term;

		  text_pos = crs_pos + hcnt;
				/* update text position */
		end;

	        if ctbe.boxb	/* bottom Ts */
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

		  art_str = art_str || art.box.b;
				/* update text position */
		  text_pos = crs_pos + ctbe.width;
		  ctb.line_width = ctb.line_width + ctbe.width;

		  if detail_sw
		  then call ioa_ ("^-^2d- box bottom T^3( ^f^)", crs,
			  show (crs_pos, 12000),
			  show (ctbe.width, 12000),
			  show (text_pos, 12000));
		end;

/* horizontal rules */
	        if ctbe.horiz
	        then
		do;
		  if crs_pos ^= text_pos
		  then call htab_;

hrule:
		  art_str = art_str || art.horiz.start;
				/* start the rule */

		  do i = crs to ctb.scnt while
				/* search for terminator */
		       (
		       ^(ctb.star (i) | (ctb.raro (i) & ^ctb.laro (i))
		       | ctb.boxtr (i) | ctb.boxr (i) | ctb.boxbr (i)));
		  end;
		  ctb.star (i), ctb.horiz (i) = "0"b;
				/* reset flags */

		  if i > ctb.scnt	/* if no terminator, rule to measure */
		  then hterm_pos = block.parms.measure;
				/* otherwise, rule to the terminator */
		  else hterm_pos = ctb.e (i).pos;

		  hor_vec.v1 = hterm_pos - text_pos;
		  art_str = art_str || hor_vec_str;
		  if ctb.boxtr (i)
		  then art_str = art_str || art.box.tr;
		  else if ctb.boxr (i)
		  then art_str = art_str || art.box.r;
		  else if ctb.boxbr (i)
		  then art_str = art_str || art.box.br;
		  else art_str = art_str || art.horiz.term;

		  if detail_sw
		  then
		    do;
		      if ctb.boxtr (i)
		      then j = 1;
		      else if ctb.boxr (i)
		      then j = 2;
		      else if ctb.boxbr (i)
		      then j = 3;
		      else j = 4;

		      call ioa_ ("^-^2d- horizontal from ^f to ^f ^a"
			 ||
			 "^[^/^-^2d- ^[box top right corner^;box right T^;box "
			 ||
			 "bottom right corner^] at ^f^;^3s^]^/^2-Hvec^3( ^f^) ^a"
			 , crs, show (text_pos, 12000),
			 show (hterm_pos, 12000),
			 comp_util_$display ((hor_vec_str), 0, "0"b),
			 (j < 4), i, j, show (hterm_pos, 12000),
			 show (text_pos, 12000),
			 show ((hor_vec.v1), 12000),
			 show (hterm_pos, 12000),
			 comp_util_$display ((hor_vec_str), 0, "0"b));
		    end;		/**/
				/* update text position */
		  text_pos = hterm_pos;
		end;
	      end;

/* if not at baseline */
	    if base ^= 0 & crs = ctb.scnt
	    then
	      do;
	        if detail_sw
	        then call ioa_ ("^- $- Baseline from ^f to 0 at EOL.",
		        show (base, 12000));
	        call vtab_ (0);
	        ctbe.base = 0;
	      end;
	  end;

	  txtlin.width = ctb.line_width;
	  txtlin.white, txtlin.no_trim = "0"b;
	  txtlin.lmarg = ctb.lmarg;

	  call comp_util_$replace_text (blkptr, "0"b, txtlinptr,
	       addr (art_str));

	  ptb = ctb;		/* copy current to previous */
	end build_loop;
end_line_loop:
      end;
    end line_loop;

return_:
    block.hdr.art = "0"b;		/* art in this block is done */

    if shared.bug_mode
    then call ioa_ ("     (art)");
    return;
%page;
htab_:
  proc;

    dcl move	   fixed bin (31);	/* working value */

    move = crs_pos - text_pos;

    hor_sft.v1 = move;
    art_str = art_str || hor_sft_str;
    text_pos = crs_pos;
/****    if txtlin.quad = just
/****    then ctb.line_width = ctb.line_width + move;*/

    if detail_sw
    then call ioa_ ("^2-Hshft^3( ^f^) ^a", show (text_pos, 12000),
	    show (move, 12000), show (crs_pos, 12000),
	    comp_util_$display ((hor_sft_str), 0, "0"b));

  end htab_;
%page;
vtab_:
  proc (new_base);

    dcl new_base	   fixed bin (31);	/* new baseline offset */

    if new_base = base		/* if no actual movement */
    then return;

    vert_sft.v1 = new_base - base;	/* set amount in millipoints */
    art_str = art_str || vert_sft_str;

    if detail_sw
    then call ioa_ ("^2-Vshft (^f ^f ^f) ^a", show (base, 12000),
	    show ((vert_sft.v1), 12000), show (new_base, 12000),
	    comp_util_$display ((vert_sft_str), 0, "0"b));
    base = new_base;		/* set new baseline */
  end vtab_;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;

/* DEBUGGING STUFF */
dtn:
  entry;
    dt_sw = "1"b;
    goto db_join;
dtf:
  entry;
    dt_sw = "0"b;
    return;
    dcl dt_sw	   bit (1) static init ("0"b);

dbn:
  entry;
    db_sw = "1"b;
    goto db_join;
dbf:
  entry;
    db_sw = "0"b;
    return;
    dcl db_sw	   bit (1) static init ("0"b);

alln:
  entry;
    db_sw, dt_sw = "1"b;
db_join:
    dcl db_line	   fixed bin static init (0);
    dcl com_err_	   entry options (variable);
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin, fixed bin (35));
    dcl arg	   char (argl) based (argp);
    dcl argl	   fixed bin;
    dcl argp	   ptr;
    dcl ercd	   fixed bin (35);
    dcl error_table_$noarg
		   fixed bin (35) ext static;

    db_line = 0;
    call cu_$arg_ptr (1, argp, argl, ercd);
    if ercd ^= 0
    then
      do;
        if ercd ^= error_table_$noarg
        then call com_err_ (ercd, "&device&._writer_");
        return;
      end;
    db_line = convert (db_line, arg);
    return;

allf:
  entry;
    db_sw, dt_sw = "0"b;
    return;
%page;
%include comp_art_parts;
%include comp_brktypes;
%include comp_DCdata;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_text;
%include compstat;

  end comp_art_;




		    comp_block_ctls_.pl1            04/23/85  1059.2rew 04/23/85  0908.7      282915



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

/* compose subroutine for processing all block-begin and block-end controls */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_block_ctls_:
  proc (ctl_index);

/* PARAMETERS */

    dcl ctl_index	   fixed;		/* index value for desired control */

/* LOCAL STORAGE */

    dcl blkptr	   ptr;		/* local value */
    dcl blkusd	   fixed bin (31);
    dcl 1 block	   aligned like text based (blkptr);
    dcl col_space	   fixed bin (31);	/* for table mode column runout */
    dcl ctl_info_ptr   ptr;
    dcl current_fcs	   char (8);
    dcl EMPTY	   bit (1) static options (constant) init ("1"b);
    dcl exit_str	   char (256) var;	/* for debugging */
    dcl footref_array  (3) char (48) var static;
    dcl footrefstr	   char (256) var static;
    dcl ftnblkptr	   ptr;		/* footnote block */
    dcl 1 ftnblk	   aligned like text based (ftnblkptr);
    dcl ftncolptr	   ptr static;	/* column holding the note */
    dcl ftncolndx	   fixed bin static;/* footnote block index */
    dcl ftnct	   fixed bin;	/* line footnote count for debug */
    dcl ftndx	   fixed bin static;/* for footref measuring */
    dcl head_used	   fixed bin (31);	/* space used by page header */
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl ipic	   fixed bin;	/* local picture block index */
    dcl LOAD	   bit (1) static options (constant) init ("1"b);
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl orphan	   bit (1) static;	/* note is an orphan */
    dcl pagenote	   bit (1) init ("0"b);
    dcl 1 pline	   aligned like text_entry;
    dcl pptr	   ptr;
    dcl ptxt	   char (1020) var; /* referencing block */
    dcl refblkptr	   ptr static init (null);
    dcl 1 refblk	   aligned like text based (refblkptr);
    dcl refcolndx	   fixed bin static;/* referencing column */
    dcl reflin	   fixed bin;	/* index of ftn refline */
    dcl save_colno	   fixed bin static;/* to save current column */
    dcl unscaled	   (1) fixed bin (31) static options (constant) init (1);
    dcl vscales	   (7) fixed bin (31) static options (constant)
		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);

    dcl (addr, addrel, char, divide, fixed, length, ltrim, max, min, null,
        size, substr)  builtin;

    dcl comp_error_table_$limitation
		   fixed bin (35) ext static;
    dcl comp_error_table_$usage_error
		   fixed bin (35) ext static;

    dcl ioa_$rs	   entry options (variable);
    dcl ioa_$rsnnl	   entry options (variable);

    if shared.bug_mode
    then call ioa_ ("block_ctls: (^d) ""^a""", ctl_index, ctl_line);

    exit_str = "";
    goto ctl_ (ctl_index);

ctl_ (7):				/* ".bb" = block-begin OBSOLETE */
    goto bblk_ctl;

ctl_ (8):				/* ".bart" = begin-artwork */
ctl_ (9):				/* ".bba" = block-begin-artwork */
    if shared.blkptr = null ()	/* needed now to set art line count */
    then
      do;				/**/
				/* head page, if needed */
        if ^(option.galley_opt | page.hdr.headed)
        then call comp_head_page_ (head_used);

        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	   addr (current_parms), ^EMPTY);
      end;			/**/
				/* text with a pending header? */
    if ^text.parms.title_mode & text.parms.hdrptr ^= null ()
         & ^shared.inserting_hfc
    then if text.parms.hdrptr -> hfcblk.hdr.count > 0
         then call comp_title_block_ (text.parms.hdrptr);

    if ctl.index > length (ctl_line)	/* set artline counter */
    then text.hdr.art_count = -1;
    else text.hdr.art_count =
	    comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    addr (ctl.info), 0);	/**/
				/* set flags */
    text.hdr.art, text.parms.art, current_parms.art = "1"b;

    goto return_;

ctl_ (10):			/* ".bblk" = begin-block */
bblk_ctl:				/* SUSPEND A NAMED BLOCK HERE */
    if shared.ftn_mode
    then call comp_block_ctls_ (bef_ctl_index);
				/* reset shared block modes */
    current_parms.art, current_parms.keep, current_parms.title_mode,
         shared.literal_mode = "0"b;

    if shared.blkptr ^= null ()
    then
      do;
        text.parms.art,		/* reset active block modes */
	   text.parms.keep, text.parms.title_mode = "0"b;
				/* finish current block */
        call comp_break_ (block_break, 0);
      end;

    goto return_;

ctl_ (12):			/* ".bbe" = block-begin-equations */
    goto bbt_ctl;

ctl_ (13):			/* ".bbf" = block-begin-footnote */
    if shared.ftn_mode		/* if nested .bbfs */
    then
      do;
        call comp_report_ (2, 0, "Nested footnotes.", addr (ctl.info),
	   ctl_line);
        goto return_;
      end;

    footrefstr = "X";		/* preset footref as a signal */
				/* assume a column note */
    save_colno, ftncolndx, refcolndx = page.hdr.col_index;

    if ctl.index <= length (ctl_line)	/* if any parameters are given */
    then
      do;				/**/
				/* suppress reference? */
        if substr (ctl_line, ctl.index, 1) = "s"
	   | substr (ctl_line, ctl.index, 1) = "u"
        then
	do;
	  footrefstr = "";		/* reset the footref signal */
	  ctl.index = ctl.index + 1;
	end;			/**/
				/* step over possible comma */
        if ctl.index <= length (ctl_line)
        then if substr (ctl_line, ctl.index, 1) = ","
	   then ctl.index = ctl.index + 1;
				/* if there's still more */
        if ctl.index <= length (ctl_line)
        then
	do;
	  if substr (ctl_line, ctl.index, 1) = "c"
	  then pagenote = "0"b;

	  else if substr (ctl_line, ctl.index, 1) = "p"
	  then
	    do;
	      pagenote = "1"b;
	      ftncolndx = 0;
	      if footrefstr = ""
	      then refcolndx = 0;
	      else refcolndx = page.hdr.col_index;
	    end;
	  else			/* that's all we know about */
	       call comp_report_ (2, 0,
		  "Unknown footnote format keyword,"
		  || "  default will be used.", addr (ctl.info), ctl_line);
	end;
      end;			/**/

/*				/* insert text header in case */
/*    if text.parms.hdrptr ^= null ()	/* footnote is for it */
/*         & shared.blkptr ^= text.parms.hdrptr & ^shared.inserting_hfc
/*    then if text.parms.hdrptr -> hfcblk.hdr.count > 0
/*         then
/*	 do;
/*	   if shared.blkptr = null ()
/*	   then call comp_util_$getblk (page.hdr.col_index, shared.blkptr,
/*		   "tx", addr (current_parms), ^EMPTY);
/*	   call comp_title_block_ (text.parms.hdrptr);
/*	 end;*/

    if shared.blkptr = null ()	/* an orphan? */
    then
      do;
        orphan, pagenote = "1"b;
        refcolndx = 0;
      end;
    else orphan, pagenote = "0"b;

    if shared.ftnblk_data_ptr = null	/* allocate block data */
    then
      do;
        shared.ftnblk_data_ptr =
	   allocate (const.global_area_ptr, size (ftnblk_data));
        ftnblk_data.highndx = 0;
        ftnblk_data.blkptr (*) = null;	/* assure footnote fonts are loaded */
        call comp_font_ (LOAD, "footnote", "");
        call comp_font_ (LOAD, "footref", shared.footref_fcs);
      end;			/**/
				/* if no footnote header block */
    if shared.footnote_header_ptr = null
    then
      do;				/* get one */
        call comp_util_$getblk (-1, shared.footnote_header_ptr, "fh",
	   const.footnote_parms_ptr, ^EMPTY);
        ftnhdr.parms.page = pagenote;
        ftnhdr.parms.footnote = "1"b;
        ftnhdr.parms.left, ftnhdr.parms.right = 0;
        ftnhdr.hdr.tblblk = "0"b;
        ftnhdr.hdr.colno = -1;	/**/
				/* put in a null line */
        call comp_util_$add_text (shared.footnote_header_ptr, "0"b, "0"b, "0"b,
	   "0"b, addr (ftnhdr.input));

        txtlinptr = ftnhdr.line_area.cur -> line_area.linptr (1);
        txtlin.title, txtlin.default = "1"b;
        ftnhdr.hdr.used, txtlin.linespace = 12000;
        txtlin.font =
	   footnote_parms.fntstk (footnote_parms.fntstk.index).entry;
        txtlin.lmarg, txtlin.depth = 0;
        if pagenote
        then txtlin.rmarg = page.parms.measure;
        else txtlin.rmarg = col.parms.measure;
      end;

    if shared.suppress_footref	/* if unreferenced mode */
    then footrefstr = "";		/* reset the footref signal */
				/* check limit for paged notes */
    if shared.ftn_reset = "paged" & shared.ftnrefct > 9 & ^option.galley_opt
    then
      do;				/* report the error */
        call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	   addr (ctl.info), ctl_line,
	   "More than nine footnotes given for this page."
	   || " This note will be unreferenced.");
        footrefstr = "";		/* reset the footref signal */
      end;

/*				/* head page if necessary */
/*    if ^(option.galley_opt | page.hdr.headed)
/*    then call comp_head_page_ (head_used);*/
/* count a new footnote */
    ftndx, ftnblk_data.highndx = ftnblk_data.highndx + 1;
				/* get a block for the note */
    call comp_util_$getblk (-1, ftnblk_data.blkptr (ftndx), "fn",
         const.footnote_parms_ptr, ^EMPTY);
    ftnblkptr = ftnblk_data.blkptr (ftndx);
    ftnblk.parms.page = pagenote;
    ftnblk.parms.footnote = "1"b;	/* show it a footnote */

    if pagenote			/* use page parms? */
    then ftnblk.parms.measure = page.parms.measure;
    else				/* use column parms */
      do;
        ftncolptr = page.column_ptr (ftncolndx);
        ftnblk.parms.measure = ftncol.parms.measure;
      end;

    ftnblk.hdr.tblblk = "0"b;		/* not a table block */
    ftnblk.hdr.orphan = orphan;	/**/
				/* save refblk for exit */
    ftnblk.hdr.blkptr, refblkptr = shared.blkptr;

    if shared.table_mode		/* set table mode stuff */
    then
      do;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        tblcolptr = tblfmt.colptr (tblfmt.ccol);
      end;

    current_fcs = ctl.font.fcs_str;
    ftnblk.input.linespace = footnote_parms.linespace;
    ctl.font, ctl.cur.font, ftnblk.input.font =
         footnote_parms.fntstk (footnote_parms.fntstk.index).entry;

    if footrefstr = "X"		/* is the reference signal still on? */
    then
      do;
        footref_array (2) = ltrim (char (shared.ftnrefct));
        call comp_dvt.footproc (footref_array, addr (comp_dvt));

        footrefstr =
	   shared.footref_fcs || footref_array (1) || footref_array (2)
	   || footref_array (3) || current_fcs;

        unspec (meas1) = "0"b;
        call comp_measure_ ((footrefstr), addr (ftnblk.input.font), "0"b, "0"b,
	   "0"b, ftnblk.parms.measure, addr (meas1), addr (meas2),
	   addr (ftnblk.input.info)); /**/

        ftnblk.input_line =		/* set reference into footnote */
	   shared.footref_fcs || footref_array (1) || footref_array (2)
	   || footref_array (3)
	   || footnote_parms.fntstk.entry (footnote_parms.fntstk.index)
	   .fcs_str || EN;		/**/
				/* set indent, user may change it */
        footnote_parms.left.indent, ftnblk.parms.left.indent =
	   max (ftnblk.parms.left.indent, meas1.width + meas1.avg + 7200);
        ftnblk.input.hanging = "1"b;	/* make it a hanger */
        ftnblk.input.lmarg = 0;	/* set at col lmarg */
        ftnblk.input.linespace = 0;	/* no lead for hangers */
        ftnblk.input.quad = quadl;	/* set left */
				/* place the reference */
        call comp_util_$add_text (ftnblkptr, "0"b, "0"b, "0"b, "0"b,
	   addr (ftnblk.input));	/**/
				/* restore lead */
        ftnblk.input.linespace = ftnblk.parms.linespace;
        ftnblk.input.hanging = "0"b;	/* reset hanging switch */
				/* restore alignment */
        ftnblk.input.quad = ftnblk.parms.quad;
        ftnblk.input_line = "";	/* erase the reference */
      end;

    else
      do;
        ftnblk.hdr.unref = "1"b;	/* show an unreffed note */
        ftnblk.parms.left.indent, footnote_parms.left.indent = 0;
      end;

    ftnblk.hdr.blkptr = shared.blkptr;	/* save pointers for end */
    ftnblk.hdr.parms_ptr = const.current_parms_ptr;
    shared.blkptr = ftnblkptr;	/* switch to footnote block */
    const.current_parms_ptr = addr (ftnblk.parms);

    text.hdr.refer = refcolndx;	/* set ref col */
    shared.ftn_mode = "1"b;		/* we're now in ftn mode */

    if shared.bug_mode
    then call ioa_$rsnnl ("ftndx=^d^[ orph^]^[ unref^s^; refno=^d^] "
	    || "refcol=^d ftncol=^d", exit_str, 0, ftndx, orphan,
	    text.hdr.unref, shared.ftnrefct, refcolndx, ftncolndx);

    goto return_;

ctl_ (14):			/* ".bbi" = block-begin-inline */
    goto bblk_ctl;

ctl_ (15):			/* ".bbk" = block-begin-keep */
				/* head page if necessary */
    if ^(option.galley_opt | page.hdr.headed)
    then call comp_head_page_ (head_used);

    if shared.blkptr = null ()	/* need block now to count keep */
    then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	    addr (current_parms), ^EMPTY);
				/* is there a header waiting? */
    if text.parms.hdrptr ^= null () & ^shared.inserting_hfc
    then if text.parms.hdrptr -> hfcblk.hdr.count > 0
         then call comp_title_block_ (text.parms.hdrptr);

    if length (text.input_line) > 0	/* any leftovers? */
    then call comp_break_ (format_break, 0);

    text.parms.keep = "1"b;		/* set flag */

    if shared.table_mode
    then
      do;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        do i = 0 to tblfmt.ncols;
	tblfmt.colptr (i) -> tblcol.parms.keep = "1"b;
        end;
      end;

    if ctl.index > length (ctl_line)	/* if no parameter */
    then text.hdr.keep_count = -1;	/* keep count is indeterminant */
    else text.hdr.keep_count =
	    comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    addr (ctl.info), 0);

    goto return_;

ctl_ (16):			/* ".bbl" = block-begin-literal */
    shared.literal_mode = "1"b;

    if ctl.index > length (ctl_line)
    then shared.lit_count = -1;
    else shared.lit_count =
	    max (
	    comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    addr (ctl.info), 0), 1);

    goto return_;

ctl_ (17):			/* ".bbn" = block-begin-named - UNIMPLEMENTED */
				/* if ctl.index > length (ctl_line)
   then call comp_report_ (2,0, "Block name must be given.",
   addr(ctl.info), ctl_line);
   else do;
   call comp_break_ (block_break,0);
   end; */
    goto return_;

ctl_ (18):			/* ".bbp" = block-begin-picture */
    if shared.blkptr ^= null
    then
      do;
        if text.blktype = "pi"	/* check for nesting */
        then
	do;
	  call comp_report_ (2, 0, "Nested pictures not allowed.",
	       addr (ctl.info), ctl_line);
	  goto return_;
	end;

        blkusd =
	   text.hdr.used + text.hdr.ftn.usd
	   + bin (text.input_line ^= "") * text.parms.linespace;
      end;

    else blkusd = 0;		/**/
				/* check count limit */
    if shared.picture.count = hbound (shared.picture.ptr, 1)
    then
      do;
        ctl_info_ptr = addr (ctl.info);
        call comp_report_$ctlstr (2, comp_error_table_$limitation,
	   ctl_info_ptr, ctl_line,
	   "Too many picture blocks; program limit is ^d",
	   hbound (shared.picture.ptr, 1));
        goto return_;
      end;			/**/
				/* head page if necessary */
    if ^(option.galley_opt | page.hdr.headed)
    then call comp_head_page_ (head_used);

    ipic, shared.picture.count = shared.picture.count + 1;

    if ctl.index <= length (ctl_line)	/* size given? */
    then if search (substr (ctl_line, ctl.index), "0123456789") = 1
         then
	 do;
	   shared.picture.blk (ipic).size =
	        comp_read_$number (ctl_line, vscales, ctl.index, ctl.index,
	        addr (ctl.info), 0);	/**/
				/* validate given size */
	   if shared.picture.blk (ipic).size > col.hdr.net - col.depth_adj
	   then
	     do;
	       call comp_report_ (2, 0,
		  "Picture size exceeds net page space.", addr (ctl.info),
		  ctl_line);
	       shared.picture.blk (ipic).size = col.hdr.net - col.depth_adj;
	     end;
	 end;			/**/
				/* create the picture */
    call comp_util_$getblk (-1, shared.picture.blk (ipic).ptr, "pi",
         addr (current_parms), ^EMPTY); /**/
				/* unformatted picture? */
    if shared.picture.blk (ipic).size > 0
    then
      do;
        call comp_space_ (shared.picture.blk (ipic).size,
	   shared.picture.blk (ipic).ptr, "1"b, "1"b, "1"b, "0"b);
        shared.picture.blk (ipic).ptr -> text.hdr.no_trim = "1"b;
        shared.picture.space =	/* count total space */
	   shared.picture.space + shared.picture.blk (ipic).size;

        if shared.blkptr = null
        then call comp_util_$pictures (shared.blkptr);

        if shared.bug_mode
        then call ioa_$rsnnl ("pi=^d ^f", exit_str, 0, shared.picture.count,
	        show (shared.picture.space, 12000));

        goto return_;
      end;			/**/
				/* formatted picture */
    shared.picture_mode = "1"b;	/* switch to picture block */
    shared.picture.blk (ipic).ptr -> text.hdr.blkptr = shared.blkptr;
    shared.picture.blk (ipic).ptr -> text.hdr.parms_ptr =
         const.current_parms_ptr;
    shared.blkptr = shared.picture.blk (ipic).ptr;
    text.parms.keep = "1"b;
    const.current_parms_ptr = addr (text.parms);

    if shared.bug_mode
    then call ioa_$rsnnl ("pi=^d ^f", exit_str, 0, shared.picture.count,
	    dec (divide (shared.picture.space, 12000, 31, 10), 11, 3));

    goto return_;

ctl_ (19):			/* ".bbt" = block-begin-title */
bbt_ctl:
    if shared.blkptr ^= null ()
    then if text.parms.title_mode
         then
	 do;
	   call comp_report_ (2, 0, "Already processing a title block.",
	        addr (ctl.info), ctl_line);
	   goto return_;
	 end;			/**/
				/* head the page if necessary */
    if ^(option.galley_opt | page.hdr.headed)
    then call comp_head_page_ (head_used);

    if shared.blkptr = null ()
    then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	    addr (current_parms), ^EMPTY);

    else if text.input_line ^= ""
    then call comp_break_ (format_break, 0);
				/* format break for current block */

    if ^text.parms.title_mode & text.parms.hdrptr ^= null ()
         & ^shared.inserting_hfc
    then if text.parms.hdrptr -> hfcblk.hdr.count > 0
         then call comp_title_block_ (text.parms.hdrptr);

    text.parms.title_mode = "1"b;	/* set the mode flag */
    if ctl.index > length (ctl_line)
    then text.hdr.eqn_line_count = -1;
    else text.hdr.eqn_line_count =
	    comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    addr (ctl.info), 0);

    goto return_;

ctl_ (22):			/* ".be" = block-end */
be_ctl:
    goto bblk_ctl;

ctl_ (23):			/* ".bea" = block-end-artwork */
    goto eart_ctl;

ctl_ (25):			/* ".bee" = block-end-equations */
    goto bet_ctl;

ctl_ (26):			/* ".bef" = block-end-footnote */
    if ^shared.ftn_mode		/* not in footnote mode? */
    then goto return_;
    else ftnblkptr = shared.blkptr;	/**/
				/* was a note given? */
    if ftnblk.hdr.count > 0 | ftnblk.input_line ^= ""
    then
      do;				/* finish the note */
        if ftnblk.hdr.count = 1	/* force lead in case only */
        then ftnblk.input.linespace =	/* footref is there */
	        max (ftnblk.input.linespace, ftnblk.parms.linespace);
        call comp_break_ (format_break, 0);

        if shared.ftn_reset ^= "hold"	/* if not holding notes */
        then
	do;
	  if orphan		/* orphans are unreffed paged notes */
	  then
	    do;
	      ftnblk.hdr.unref = "1"b;
	      ftncolndx, refcolndx = 0;
	      ftncolptr = page.column_ptr (0);
	    end;

/**** count notes in containing column */
	  ftncol.hdr.ftn.ct = ftncol.hdr.ftn.ct + 1;
				/* if first footnote, */
	  if ftncol.hdr.ftn.ct = 1	/* count space for the header */
	  then ftncol.hdr.ftn.usd = ftnhdr.hdr.used + 12000;
	  ftncol.hdr.ftn.usd =	/* extra space for separator */
	       ftncol.hdr.ftn.usd + ftnblk.hdr.used + 12000;
	  ftncol.hdr.ftn.blkndx (ftncol.hdr.ftn.ct) = ftndx;
/**** count notes in referring column */
	  if ftncolndx ^= refcolndx
	  then refcol.hdr.ftn.ct = refcol.hdr.ftn.ct + 1;
/**** count notes in containing block */
				/* count it in the page header */
	  if ftnblk.hdr.blkptr = null | ftncolndx ^= refcolndx
	  then blkptr = col0.blkptr (1);
				/* count it in the current block */
	  else blkptr = ftnblk.hdr.blkptr;

	  if blkptr ^= null
	  then
	    do;
	      block.hdr.ftn.ct = block.hdr.ftn.ct + 1;
	      block.hdr.ftn.usd =
		 block.hdr.ftn.usd + ftnblk.hdr.used + 12000;
	      block.hdr.ftn.blkndx (block.hdr.ftn.ct) = ftndx;
	    end;
/**** count notes in referring block */
	  if refblkptr ^= null & ftnblk.hdr.count > 0
	       & ftncolndx ^= refcolndx
	  then refblk.hdr.ftn.ct = refblk.hdr.ftn.ct + 1;
	end;
      end;

    footnote_parms = ftnblk.parms;	/* save current footnote parms */

    shared.ftn_mode = "0"b;		/* change back to text mode */
    const.current_parms_ptr = ftnblk.hdr.parms_ptr;
    shared.blkptr = ftnblk.hdr.blkptr;	/* recover suspended text block */

    page.hdr.col_index = save_colno;	/* recover suspended column */
    shared.colptr = page.column_ptr (page.hdr.col_index);

    ctl.linespace = current_parms.linespace;
    ctl.cur.font, ctl.font =
         current_parms.fntstk (current_parms.fntstk.index).entry;

    if ftnblk.hdr.count = 0		/* give back empty block */
    then
      do;
        call comp_util_$relblk (-1, ftnblk_data.blkptr (ftndx));
        if ftndx = ftnblk_data.highndx	/* adjust high index if last one */
        then
	do i = ftnblk_data.highndx to 1 by -1
	     while (ftnblk_data.blkptr (i) = null);
	end;
      end;

    if shared.bug_mode
    then
      do;
        call ioa_$rsnnl ("ftndx=^d/^d ftncol=^d ^d/^f ftnblk=^d ^d/^f",
	   exit_str, 0, ftndx, ftnblk_data.highndx, ftncolndx,
	   ftncol.hdr.ftn.ct,
	   dec (divide (ftncol.hdr.ftn.usd, 12000, 31, 10), 11, 3),
	   ftnblk.blkndx, ftnblk.hdr.count,
	   dec (divide (ftnblk.hdr.used, 12000, 31, 10), 11, 3));
      end;

    if footrefstr = ""		/* if no reference */
    then
      do;
        if ^orphan			/* if not an orphan */
        then
	do;			/* & notes arent held */
	  if shared.ftn_reset ^= "hold"
	  then			/* count the note and */
	    do;			/* attach to pending text, if any */
	      if refblk.parms.fill_mode & refblk.input_line ^= ""
	      then
	        do;
		ftnct, refblk.input.ftn.ct = refblk.input.ftn.ct + 1;
		refblk.input.ftn.blkndx (refblk.input.ftn.ct) = ftndx;
		if refcolndx = ftncolndx
		then refblk.input.ftn.used =
			refblk.input.ftn.used + ftnblk.hdr.used + 12000;

		if shared.bug_mode
		then call ioa_$rsnnl ("^a^-(unref refcol=^d ^d/^f"
			|| " refblk=^d ^d/^f reflin=^d ^d/^f", exit_str,
			0, exit_str, refcolndx, refcol.hdr.ftn.ct,
			dec (divide (refcol.hdr.ftn.usd, 12000, 31, 10),
			11, 3), refblk.blkndx, refblk.hdr.ftn.ct,
			dec (divide (refblk.hdr.ftn.usd, 12000, 31, 10),
			11, 3), refblk.hdr.count + 1,
			refblk.input.ftn.ct,
			dec (
			divide (refblk.input.ftn.used, 12000, 31, 10),
			11, 3));
	        end;

	      else		/* attach to last line in the block */
	        do;
		line_area_ptr = refblk.line_area.cur;
		txtlinptr = line_area.linptr (line_area.ndx);
		ftnct, txtlin.ftn.ct = txtlin.ftn.ct + 1;
		txtlin.ftn.blkndx (txtlin.ftn.ct) = ftndx;
		txtlin.ftn.used =
		     txtlin.ftn.used + ftnblk.hdr.used + 12000;

		if shared.bug_mode
		then call ioa_$rsnnl ("^a refblk=^d ^d/^f reflin=^d ^d/^f",
			exit_str, 0, exit_str, refblk.blkndx,
			refblk.hdr.ftn.ct,
			dec (divide (refblk.hdr.ftn.usd, 12000, 31, 10),
			11, 3), i, txtlin.ftn.ct,
			dec (divide (txtlin.ftn.used, 12000, 31, 10), 11,
			3));
	        end;
	    end;
	end;

        else
	do;
	  if shared.bug_mode
	  then call ioa_$rsnnl ("^a ORPH", exit_str, 0, exit_str);

	  if option.galley_opt
	  then call comp_insert_ctls_ (ift_ctl_index);
	end;

        goto return_;
      end;

    if shared.blkptr ^= null		/* is there an active block? */
    then
      do;
        if text.parms.fill_mode	/* insert reference into filled text */
        then
	do;			/* if there is pending text */
	  if text.input_line ^= ""
	  then ;			/**/

	  else if text.hdr.count > 0	/* is last line a hanger? */
	  then
	    do;
	      line_area_ptr = text.line_area.cur;
	      if line_area.linptr (line_area.ndx) -> text_entry.hanging
	      then
	        do;		/* yes, hang the ref onto the hanger */
		reflin = text.hdr.count;
		goto unfilled;
	        end;
	    end;

	  ctl_line = "";
	  call append_footref (addr (ctl));
	  reflin = text.hdr.count + 1;/* to be sure it fits */
	  call comp_fill_;		/**/
				/* if notes arent held */
	  if shared.ftn_reset ^= "hold"
	  then
	    do;
	      ftnct, text.input.ftn.ct = text.input.ftn.ct + 1;
	      if ftncolndx = refcolndx
	      then text.input.ftn.used =
		      text.input.ftn.used + ftnblk.hdr.used;
	      text.input.ftn.blkndx (text.input.ftn.ct) = ftndx;
	      text.input.ftn.refno (text.input.ftn.ct) = shared.ftnrefct;
	    end;

	  if shared.bug_mode
	  then call ioa_$rsnnl ("^a^-(refno=^d refcol=^d ^d/^f"
		  || " refblk=^d ^d/^f reflin=^d ^d/^f", exit_str, 0,
		  exit_str, shared.ftnrefct, refcolndx, refcol.hdr.ftn.ct,
		  dec (divide (refcol.hdr.ftn.usd, 12000, 31, 10), 11, 3),
		  refblk.blkndx, refblk.hdr.ftn.ct,
		  dec (divide (refblk.hdr.ftn.usd, 12000, 31, 10), 11, 3),
		  text.hdr.count + 1, text.input.ftn.ct,
		  dec (divide (text.input.ftn.used, 12000, 31, 10), 11, 3))
		  ;
	end;

        else			/* append reference to end of */
	do;			/* last unfilled output line */

/*	  reflin = text.hdr.count;
/*	  if shared.table_mode	/* back up to last */
/*	  then			/* line for this table column */
/*	    do;
/*	      tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
/*	      do reflin = text.hdr.count to 1 by -1
/*		 while (text.linptr (reflin) -> txtlin.tblcol
/*		 ^= tblfmt.ccol);
/*	      end;
/*	    end;*/

unfilled:
	  line_area_ptr = text.line_area.cur;
	  txtlinptr = line_area.linptr (line_area.ndx);
	  call append_footref (txtlinptr);

	  call comp_util_$replace_text (shared.blkptr, "0"b, txtlinptr,
	       addr (ctl_line));	/* if notes arent held */
	  if shared.ftn_reset ^= "hold"
	  then
	    do;
	      ftnct, txtlin.ftn.ct = txtlin.ftn.ct + 1;
	      txtlin.ftn.used = txtlin.ftn.used + ftnblk.hdr.used;
	      txtlin.ftn.blkndx (txtlin.ftn.ct) = ftndx;
	      txtlin.ftn.refno (txtlin.ftn.ct) = shared.ftnrefct;
	    end;

	  if shared.bug_mode
	  then call ioa_$rsnnl ("^a refblk=^d ^d/^f reflin=^d ^d/^f"
		  || " ftnblk=^d ^d/^f refno=^d", exit_str, 0, exit_str,
		  refblk.blkndx, refblk.hdr.ftn.ct,
		  dec (divide (refblk.hdr.ftn.usd, 12000, 31, 10), 11, 3),
		  reflin, txtlin.ftn.ct,
		  dec (divide (txtlin.ftn.used, 12000, 31, 10), 11, 3),
		  ftnblk.blkndx, ftnblk.hdr.count,
		  dec (divide (ftnblk.hdr.used, 12000, 31, 10), 11, 3),
		  shared.ftnrefct);
	end;
      end;			/**/
				/* step footnote reference count */
    shared.ftnrefct = shared.ftnrefct + 1;

    goto return_;

append_footref:			/* append footref string onto text */
  proc (reflineptr);

    dcl reflineptr	   ptr;		/* line to be appended */
    dcl 1 refline	   aligned like text_entry based (reflineptr);

    txtstrptr = refline.ptr;

    if refline.sws.footref		/* does line already have a footref? */
    then ctl_line =			/* add separator and new ref */
	    txtstr || refline.cur.font.fntptr -> font.footsep || footrefstr;
    else ctl_line = txtstr || footrefstr;
				/* add the reference */

    refline.sws.footref = "1"b;	/* set footref flag */

  end append_footref;

ctl_ (27):			/* ".bek" = block-end-keep */
    current_parms.keep = "0"b;	/* reset shared flag */

    if shared.table_mode		/* reset all table column flags */
    then
      do;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        do i = 0 to tblfmt.ncols;
	tblfmt.colptr (i) -> tblcol.parms.keep = "0"b;
        end;
      end;

    if shared.blkptr ^= null ()	/* is there a block? */
    then
      do;
        text.parms.keep = "0"b;	/* reset block flag */
        if text.parms.fill_mode & text.input_line ^= ""
        then text.input.end_keep = "1"b;
        else
	do;
	  line_area_ptr = text.line_area.cur;
	  if line_area.ndx > 0	/* if its not empty */
	  then line_area.linptr (line_area.ndx) -> txtlin.end_keep = "1"b;
	end;
      end;

    goto return_;

ctl_ (28):			/* ".bel" = block-end-literal */
bel_ctl:
    shared.literal_mode = "0"b;
    goto return_;

ctl_ (29):			/* ".ben" = block-end-named - UNIMPLEMENTED */
    goto return_;

ctl_ (30):			/* ".bep" = block-end-picture */
    if ^shared.picture_mode		/* if not in picture mode */
    then
      do;
        call comp_report_ (2, 0, "Not building a picture block.",
	   addr (ctl.info), ctl_line);
        goto return_;
      end;			/**/
				/* add caption(s) */
    if text.parms.ftrptr ^= null () & ^shared.inserting_hfc
    then
      do;
        if text.input_line ^= ""
        then call comp_break_ (format_break, 0);
        if text.parms.ftrptr -> hfcblk.hdr.count > 0
        then call comp_title_block_ (text.parms.ftrptr);
      end;			/**/
				/* finish it */
    call comp_break_ (format_break, 0); /**/
				/* record picture size */
    shared.picture.blk (shared.picture.count).size = text.hdr.used;
    shared.picture.space = shared.picture.space + text.hdr.used;

    shared.picture_mode = "0"b;	/* leave picture mode */
				/* recover suspended block */
    const.current_parms_ptr = text.hdr.parms_ptr;
    shared.blkptr = text.hdr.blkptr;

    if shared.blkptr = null
    then
      do;				/* head the page if necessary */
        if ^(option.galley_opt | page.hdr.headed)
        then call comp_head_page_ (head_used);
        call comp_util_$pictures (shared.blkptr);
      end;
    else if text.input_line = ""
    then call comp_util_$pictures (shared.blkptr);

    if shared.bug_mode
    then call ioa_$rsnnl ("pi=^d ^f", exit_str, 0, shared.picture.count,
	    show (shared.picture.space, 12000));

    goto return_;

ctl_ (31):			/* ".bet" = block-end-title */
bet_ctl:
    current_parms.title_mode = "0"b;	/* reset shared flag */
    if shared.blkptr ^= null ()	/* and active flag */
    then
      do;
        text.parms.title_mode = "0"b;
        call comp_break_ (format_break, 0);
				/* a format break */
      end;

    goto return_;

ctl_ (57):			/* ".eart" = end-artwork */
eart_ctl:
    current_parms.art = "0"b;		/* reset shared flag */
    if shared.blkptr ^= null ()	/* reset active flag */
    then text.parms.art = "0"b;

    goto return_;

return_:
    ctl_line = "";

    if shared.bug_mode
    then call ioa_ ("^5x(block_ctls:^[ ^a^])", (exit_str ^= ""), exit_str);

    return;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
/* DCLS THAT MUST BE NEAR INCLS DUE TO SYMBOL TABLE SIZE LIMIT */

    dcl 1 ftncol	   aligned like col based (ftncolptr);
    dcl 1 refcol	   aligned like col based (page.column_ptr (refcolndx));
    dcl 1 locol	   aligned like col based (locolptr);
    dcl locolptr	   ptr;

%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_footnotes;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include comp_dvt;
%include compstat;
%include translator_temp_alloc;

  end comp_block_ctls_;




		    comp_break_.pl1                 04/23/85  1059.2rew 04/23/85  0908.7      191205



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

/* compose subroutine implementing text breaks */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_break_:
  proc (break_type, next_col);

/* PARAMETERS */

    dcl break_type	   fixed bin;	/* break type; 0 = format, 1 = block,
				   2 = column, 3 = need, 4 = page,
				   5 = footnote, 6 = header,
				   7 = footer */
    dcl next_col	   fixed bin;	/* next column for brc;
				   -1 = step current column
				   -2 = force page makeup for need */

/* LOCAL STORAGE */

    dcl blkusd	   fixed bin (31);	/* for debug */
    dcl blkptr	   ptr;		/* local referencing */
    dcl 1 block	   aligned like text based (blkptr);
    dcl brktypes	   (0:7) char (4) var static options (constant)
		   init ("fmt", "blk", "col", "page", "need", "ftn", "hdr",
		   "ftr");
    dcl coldepth	   fixed bin (31);	/* local depth counter*/
    dcl colno	   fixed bin;	/* local column number */
    dcl colspace	   fixed bin (31);	/* for table balancing */
    dcl head_used	   fixed bin (31);	/* page header space used */
    dcl i		   fixed bin;	/* working index */
    dcl icol	   fixed bin;	/* column counter */
    dcl (j, k)	   fixed bin;	/* working index */
    dcl leader_count   fixed bin;	/* number of leader strings needed */
    dcl 1 local_font   aligned like fntstk_entry;
    dcl locolptr	   ptr;		/* for local referencing */
    dcl 1 locol	   aligned like col based (locolptr);
				/* for leader measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl 1 nullpic			/* empty picture block */
		   static options (constant),
	4 type			/* type = page/col */
		   char (4) init (""),
	4 place			/* place = top/cen/bot */
		   char (4) init (""),
	4 ptr	   ptr init (null), /* pointer to block */
	4 size			/* size of picture */
		   fixed bin (31) init (0);
    dcl nxtlin_ptr	   ptr;		/* for table line sorting */
    dcl 1 nxtlin	   aligned like text_entry based (nxtlin_ptr);
    dcl oflo	   bit (1);	/* overflow switch */
    dcl save_lead	   fixed bin (31);	/* linespace for table leader */
    dcl SHORT	   bit (1) static options (constant) init ("1"b);
    dcl ta_size	   fixed bin (31);	/* caption added to block */
				/* for expanding <title>s */
    dcl temp_line	   char (1020) var;
    dcl TEXT	   bit (1) static options (constant) init ("1"b);
    dcl thslin_ptr	   ptr;		/* for table line sorting */
    dcl 1 thslin	   aligned like text_entry based (thslin_ptr);
    dcl tptr	   ptr;		/* temp for sorting */
    dcl toss	   fixed bin;	/* count of galley lines discarded */

    dcl (addr, before, ceil, char, hbound, index, length, ltrim, max, min,
        null, search, substr)
		   builtin;
    dcl (cleanup, comp_abort, end_output)
		   condition;

    dcl continue_to_signal_
		   entry (fixed bin (35));

    blkptr = null;
    head_used, j, k, ta_size = 0;
    oflo = "0"b;

    if shared.table_mode
    then
      do;
        tblfmtndx = tbldata.ndx;
        tblfmtptr = tbldata.fmt (tblfmtndx).ptr;
        tblcolndx = tblfmt.ccol;
        tblcolptr = tblfmt.colptr (tblcolndx);
      end;

    on end_output call continue_to_signal_ (0);

    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("break: (^a^[ gal^] nxcol=^d", brktypes (break_type),
	   option.galley_opt, next_col);

        if shared.blkptr ^= null ()
        then
	do;
	  call ioa_$nnl (" ^a=^d e^d u^f(^f)", text.blktype, text.blkndx,
	       text.hdr.count, show (text.hdr.used, 12000),
	       show (text.hdr.trl_ws, 12000));

	  if shared.table_mode & text.hdr.tblblk
	  then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblcolndx, tblfmtndx,
		  show (tblcol.depth, 12000),
		  show (tblfmt.maxdepth, 12000));

	  call ioa_$nnl ("^[ ftn^d/^f^;^2s^]^[ A^]^[ K^]^[ WS^]"
	       || "^[ MOD^]^[ inp=c^d^[ m^d ^d^]^]", (text.hdr.ftn.ct > 0),
	       text.hdr.ftn.ct, show (text.hdr.ftn.usd, 12000), text.hdr.art,
	       text.parms.keep, text.hdr.white, text.hdr.modified,
	       (length (text.input_line) > 0), length (text.input_line),
	       (text.input.mod_start > 0), text.input.mod_start > 0,
	       text.input.mod_len);

	  colno = text.hdr.colno;
	end;
        else colno = page.hdr.col_index;

        call ioa_ (")^/^5x(col=^[LOOSE^s^;^d^] b^d u^f(^f)/^f(^f)"
	   || "^[ ftn=^d/^f^;^2s^] pag=^a c^d u^f(^f)/^f^[ pi=^d ^f^])",
	   (colno < 0), colno, col.hdr.blkct, show (col.hdr.used, 12000),
	   show (col.hdr.pspc, 12000), show (col.hdr.net, 12000),
	   show (col.depth_adj, 12000), col.hdr.ftn.ct > 0, col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), page.hdr.pageno,
	   page.parms.cols.count, show (page.hdr.used, 12000),
	   show (page.hdr.hdspc, 12000), show (page.hdr.net, 12000),
	   (shared.picture.count > 0), shared.picture.count,
	   show (shared.picture.space, 12000));
      end;

/* if there is a current block */
    if shared.blkptr ^= null ()
    then
blkloop:
      do;				/* text area break? */
        if break_type <= page_break & text.input_line ^= ""
        then
	do;			/* copy font stuff */
	  local_font = text.input.font;

	  if text.input.quad = just	/* a justified line? */
	  then if text.input.cur.width + text.input.cur.avg < text.input.net
	       then text.input.quad = quadl;
				/* if modified text */
/****	  if text.input.mod_start > 0
/****	       & text.input.mod_start <= length (text.input_line)
/****	  then text.input.cbar.mod = "1"b;*/
				/* do table column leadering */
	  if shared.table_mode & text.hdr.tblblk
	  then
	    do;
	      if tblcol.leader ^= ""
	      then
	        do;		/* measure what we have */
		if text.input.width = 0
		then
		  do;
		    unspec (meas2) = "0"b;
		    call comp_measure_ (text.input_line,
		         addr (text.input.font), "0"b, "1"b, quadl, 0,
		         addr (text.input.cur), addr (meas2),
		         addr (ctl.info));
		  end;		/**/
				/* record text width */
		text.input.width = text.input.width + text.input.avg;
				/* measure the leader */
		unspec (meas1) = "0"b;
		call comp_measure_ ((tblcol.leader),
		     addr (text.input.font), "0"b, "0"b, quadl, 0,
		     addr (meas1), addr (meas2), addr (ctl.info));
				/* number of leader strings needed */
		leader_count =
		     divide (text.input.rmarg - text.input.lmarg
		     - text.input.width, meas1.width, 17, 0);

		if leader_count > 0
		then
		  do;		/* save lead for leader */
		    save_lead = text.input.linespace;
				/* set text with zero lead */
		    text.input.linespace = 0;
		    call comp_util_$add_text (shared.blkptr, "0"b, "1"b,
		         "0"b, "0"b, addr (text.input));
				/* build leader string */
		    text.input_line = copy (tblcol.leader, leader_count);
				/* recover measure data */
		    text.input.width = leader_count * meas1.width;
				/* set it right, with lead */
		    text.input.quad = quadr;
		    text.input.linespace = save_lead;
		  end;
	        end;
	    end;

	  if text.parms.left.undent > 0 & text.input.hanging
	       | (text.input.fnt_chng & length (text.input_line) = 7)
	  then text.input.linespace = 0;
	  else text.input.linespace = text.parms.linespace;

	  if text.input.fnt_chng & length (text.input_line) > 7
	  then text.input.fnt_chng = "0"b;

	  if text.input_line ^= ""
	  then call comp_util_$add_text (shared.blkptr,
		  (text.input.quad ^= quadl & text.input.width = 0), "1"b,
		  "0"b, text.input.oflo, addr (text.input));

	  text.input_line = "";	/* erase the partial line */
	  text.input.ftn = text_entry.ftn;
				/* reset controls */
	  text.input.hanging, text.input.und_prot, text.input.fnt_chng,
	       text.input.punct = "0"b;
	  text.parms.left.undent, text.parms.right.undent = 0;
	  text.input.chrct, text.input.gaps, text.input.width,
	       text.input.mod_start, text.input.mod_len = 0;
	  text.input.quad = text.parms.quad;
	  unspec (text.input.cbar) = "0"b;
	end;

/* if a block is to be ended */
        if break_type > format_break	/* if other than a format break */
	   & ^text.parms.title_mode	/* and not building formatted blocks */
	   & ^shared.ftn_mode	/* and not building a footnote */
	   & ^text.parms.keep	/* and not a keep block */
        then
	do;			/* head page if needed */
	  if ^(option.galley_opt | page.hdr.headed)
	  then call comp_head_page_ (head_used);
	  else if ^option.galley_opt
	  then head_used = col0.blkptr (1) -> text.hdr.used;

	  if break_type < need_break	/* if a text area break */
	  then
	    do;			/* insert text heading */
	      if text.parms.hdrptr ^= null () & ^shared.inserting_hfc
	      then if text.parms.hdrptr -> hfcblk.hdr.count > 0
		 then call comp_title_block_ (text.parms.hdrptr);
				/* insert text caption */
	      if text.parms.ftrptr ^= null () & ^shared.inserting_hfc
	      then if text.parms.ftrptr -> hfcblk.hdr.count > 0
		 then
		   do;
		     ta_size = text.parms.ftrptr -> hfcblk.hdr.used;
		     call comp_title_block_ (text.parms.ftrptr);
		   end;
	    end;

	  if text.hdr.tblblk	/* sort table lines into page depth */
	  then			/* and column order */
sort:
	    begin;		/* to allocate pointer arrays */

	      dcl (i, j)	     fixed bin;
	      dcl loptr	     (text.hdr.count) ptr;
	      dcl swp	     bit (1);

	      i = 0;		/* copy pointers for sorting */
	      do line_area_ptr = text.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do j = 1 to line_area.ndx;
		i = i + 1;
		loptr (i) = line_area.linptr (j);
	        end;
	      end;
pass:				/* make a sorting pass */
	      swp = "0"b;
	      do j = 1 to text.hdr.count - 1;
	        thslin_ptr = loptr (j);
	        nxtlin_ptr = loptr (j + 1);
				/* if this is deeper than next */
	        if thslin.depth > nxtlin.depth
				/* or further right at same depth */
		   | (thslin.depth = nxtlin.depth
		   & thslin.lmarg > nxtlin.lmarg)
	        then		/* swap 'em */
		do;
		  tptr = loptr (j);
		  loptr (j) = loptr (j + 1);
		  loptr (j + 1) = tptr;
		  swp = "1"b;	/* show that we've swapped */
		end;
	      end;

	      if swp		/* if we swapped, try again */
	      then goto pass;	/**/
				/* fix lead for lines at same depth */
	      do i = 1 to text.hdr.count - 1;
	        thslin_ptr = loptr (i);
	        nxtlin_ptr = loptr (i + 1);
	        if thslin.depth = nxtlin.depth
	        then thslin.linespace = 0;
	      end;

	      i = 0;		/* put sorted pointers back */
	      do line_area_ptr = text.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do j = 1 to line_area.ndx;
		i = i + 1;
		line_area.linptr (j) = loptr (i);
	        end;
	      end;
	    end sort;		/**/
				/* expand <title>s */
	  do line_area_ptr = text.line_area.first
	       repeat (line_area.next) while (line_area_ptr ^= null);
	    do i = 1 to line_area.ndx;
	      txtlinptr = line_area.linptr (i);
				/* if a <title> line */
	      if txtlin.title	/* and not empty */
		 & length (txtlin.ptr -> txtstr) > 0
	      then
	        do;
		temp_line = txtlin.ptr -> txtstr;

		if index (temp_line, shared.sym_delim) ^= 0
		then
		  do;
		    call comp_use_ref_ (temp_line, txtlin.art, TEXT,
		         addr (txtlin.info));
		    call comp_util_$replace_text (shared.blkptr, "1"b,
		         txtlinptr, addr (temp_line));
		  end;
	        end;
	    end;
	  end;

/* ***************************** start GALLEY ****************************** */

	  if option.galley_opt & text.blktype ^= "pi"
	       & (^text.parms.keep | shared.end_output)
	  then
	    do;			/**/
				/* if multicolumn, set all */
				/* other columns to empty so */
				/* write_page isnt confused */
	      if page.hdr.col_count > 0
	      then
	        do icol = 0 to page.hdr.col_count;
		if icol ^= page.hdr.col_index
		then page.column_ptr (icol) -> col.hdr = colhdr;
	        end;

	      if text.hdr.art	/* expand artwork */
	      then
	        do;
		coldepth = 0;	/* artwork needs the depth */
		do line_area_ptr = text.line_area.first
		     repeat (line_area.next) while (line_area_ptr ^= null);
		  do i = 1 to line_area.ndx;
		    txtlinptr = line_area.linptr (i);
		    txtlin.depth = coldepth;
		    coldepth = coldepth + txtlin.linespace;
		  end;
		end;
		call comp_art_ (shared.blkptr, "0"b);
	        end;		/**/
				/* discard unwanted lines */
	      toss = 0;		/* clear discard count */
	      coldepth = 0;		/* to set final depth */
	      do line_area_ptr = text.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do i = 1 to line_area.ndx;
		txtlinptr = line_area.linptr (i);
				/* if before galley range or */
				/* a split header, discard it */
		if option.line_1 > txtlin.lineno0 | txtlin.blk_splt
		then
		  do;		/* throw away any footnotes */
		    text.hdr.ftn.ct = text.hdr.ftn.ct - txtlin.ftn.ct;
		    text.hdr.ftn.usd = text.hdr.ftn.usd - txtlin.ftn.used;
		    col.hdr.ftn.ct = col.hdr.ftn.ct - txtlin.ftn.ct;
		    col.hdr.ftn.usd = col.hdr.ftn.usd - txtlin.ftn.used;
		    text.hdr.used = text.hdr.used - txtlin.linespace;
		    txtlin.width, txtlin.linespace = 0;
		    txtlin.ftn = text_entry.ftn;
		    txtlin.ptr -> txtstr = "";
		    toss = toss + 1;
		  end;		/**/
				/* if after galley range, */
		else if txtlin.lineno0 > option.line_2
		then
		  do;		/* discard remaining lines */
		    do line_area_ptr = text.line_area.first
		         repeat (line_area.next)
		         while (line_area_ptr ^= null);
		      do j = i to line_area.ndx;
		        txtlinptr = line_area.linptr (j);
				/* throw away any footnotes */
		        text.hdr.ftn.ct = text.hdr.ftn.ct - txtlin.ftn.ct;
		        text.hdr.ftn.usd =
			   text.hdr.ftn.usd - txtlin.ftn.used;
		        col.hdr.ftn.ct = col.hdr.ftn.ct - txtlin.ftn.ct;
		        col.hdr.ftn.usd =
			   col.hdr.ftn.usd - txtlin.ftn.used;
		      end;
		    end;
		    text.hdr.count = i - 1;
		  end;
		else
		  do;
		    txtlin.depth = coldepth;
		    coldepth = coldepth + txtlin.linespace;
		  end;
	        end;
	      end;		/**/
				/* any lines left? */
	      if text.hdr.count > toss & shared.pass_counter <= 1
		 & ^option.check_opt
	      then
	        do;		/* col space used	 */
		col.hdr.used = text.hdr.used;
		shared.print_flag = "1"b;
				/* write the "page" */
		call comp_write_page_;
	        end;		/**/
				/* if not doing a footnote */
	      if break_type ^= footnote_break
	      then
	        do;		/* any footnotes? */
		if text.hdr.ftn.ct > 0
		then
		  do;		/* erase text lines	 */
		    do line_area_ptr = text.line_area.first
		         repeat (line_area.next)
		         while (line_area_ptr ^= null);
		      do i = 1 to line_area.ndx;
		        txtlinptr = line_area.linptr (i);
		        txtlin.width, txtlin.linespace = 0;
		        txtlin.ptr -> txtstr = "";
		      end;
		    end;

		    call comp_insert_ctls_ (ift_ctl_index);
		  end;		/**/
				/* give back text block */
		call comp_util_$relblk (page.hdr.col_index, shared.blkptr);
				/* give back unused footnotes */
		if shared.ftnblk_data_ptr ^= null ()
		then
		  do i = ftnblk_data.highndx to 1 by -1;
		    if ftnblk_data.blkptr (i) ^= null ()
		    then call comp_util_$relblk (-1,
			    ftnblk_data.blkptr (i));


		  end;		/**/
				/* give back pictures */
		if shared.picture.count > 0
		then
		  do;
		    do i = 1 to shared.picture.count;
		      call comp_util_$relblk (-1,
			 shared.picture.blk (i).ptr);
		    end;
		    shared.picture.blk = nullpic;
		    shared.picture.space = 0;
		  end;

		col.hdr = colhdr;	/* clean up column */
		page.hdr.used = 0;	/* and page */
	        end;		/**/
				/* give back text block */
	      else call comp_util_$relblk (page.hdr.col_index, shared.blkptr)
		      ;

	      goto return_;
	    end;			/**/
/***************************** END OF GALLEY ******************************* */
				/* is block ending? */
	  if break_type >= block_break & text.blktype ^= "pi"
	       & ^(shared.table_mode & tblcolndx > 0)
	  then
	    do;
	      col.hdr.used = col.hdr.used + text.hdr.used;
	      col.hdr.pspc = text.hdr.trl_ws;
				/* a footnote or a footer? */
	      if break_type = footnote_break | break_type = footer_break
	      then
	        do;		/**/
				/* fill in page depth */
		do line_area_ptr = text.line_area.first
		     repeat (line_area.next) while (line_area_ptr ^= null);
		  do i = 1 to line_area.ndx;
		    txtlinptr = line_area.linptr (i);
		    txtstrptr = txtlin.ptr;
				/* does it have symbols or escapes? */
/****		 if index (txtstr, shared.sym_delim) ^= 0
/****		      | (^txtlin.art & index (txtstr, "*") ^= 0)
/****		 then
/****		   do;
/****		     tmpline = txtstr;
/****				/* copy the text */
/****		     if index (tmpline, shared.sym_delim) ^= 0
/****		     then call comp_use_ref_ (tmpline, txtlin.art, "1"b,
/****			     addr (txtlin.info));
/****
/****		     if index (tmpline, "*") ^= 0
/****		     then call comp_util_$escape (tmpline,
/****			     addr (txtlin.info));
/****
/****		     call comp_util_$replace_text (shared.blkptr,
/****			(txtlin.quad ^= quadl & txtlin.quad ^= just),
/****			txtlinptr, addr (tmpline));
/****		   end;*/

		    txtlin.depth = col.hdr.depth;
		    col.hdr.depth = col.hdr.depth + txtlin.linespace;
		  end;
		end;

		if text.hdr.art
		then call comp_art_ (shared.blkptr, "0"b);

/****		if break_type = header_break | break_type = footnote_break
/****		then page.hdr.used = page.hdr.used + text.hdr.used;*/

		shared.blkptr = null ();
/****		if break_type ^= footer_break & shared.picture.count > 0
/****		then call comp_util_$pictures (shared.blkptr);*/
	        end;

	      else if text.colno >= 0 /* text area break? */
	      then
	        do;
		if page.hdr.col_index = 0
		then page.hdr.used = page.hdr.used + text.hdr.used;
		else page.hdr.used =
			max (page.hdr.used, col.hdr.used + col0.hdr.used)
			;	/**/
				/* has page overflowed? */
		if (page.hdr.col_index = 0
		     | page.hdr.col_index = page.parms.cols.count)
		     & (col.hdr.used + col.hdr.ftn.usd + col.depth_adj
		     > col.hdr.net | break_type = need_break)
		then oflo = "1"b;	/**/
				/* show current block used */
		shared.blkptr = null ();
	        end;
	    end;
	end;			/* end block end loop */
      end;			/* end loop for current block */

/* is page makeup needed? */
    if page.hdr.used > 0 &		/**/
         (break_type = page_break	/* a page break? */
				/* or a need break? */
         | break_type = need_break & (oflo | next_col = -2)
				/* or returning to col 0? */
         | break_type = column_break & next_col = 0
				/* or page overflow? */
         | oflo & break_type = block_break)
    then
      do;
        call comp_make_page_ (break_type,
	   break_type = column_break & next_col = 0);

        if shared.blkptr ^= null ()
        then if text.hdr.colno >= 0
	   then
	     do;
	       colno, page.hdr.col_index = text.hdr.colno;
	       shared.colptr = page.column_ptr (colno);
	       col.hdr.used = max (col.hdr.used - text.hdr.used, 0);
	       page.hdr.used =
		  max (col.hdr.used, page.hdr.used - text.hdr.used, 0);
	     end;
      end;

return_:
    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("^5x(break: ");

        if shared.blkptr ^= null ()
        then
	do;
	  call ioa_$nnl ("^a=^d e^d u^f(^f)", text.blktype, text.blkndx,
	       text.hdr.count, show (text.hdr.used, 12000),
	       show (text.hdr.trl_ws, 12000));

	  if shared.table_mode & text.hdr.tblblk
	  then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblcolndx, tblfmtndx,
		  show (tblcol.depth, 12000),
		  show (tblfmt.maxdepth, 12000));

	  call ioa_$nnl ("^[ ftn^d/^f^;^2s^]^[ A^]^[ K^]^[ MOD^])^/^-(",
	       (text.hdr.ftn.ct > 0), text.hdr.ftn.ct,
	       show (text.hdr.ftn.usd, 12000), text.hdr.art, text.parms.keep,
	       text.hdr.modified);
	end;

        call ioa_$nnl ("col=^[LOOSE^s^;^d^] b^d u^f(^f)/^f(^f)"
	   || "^[ ftn=^d/^f^;^2s^] ", (colno < 0), colno, col.hdr.blkct,
	   show (col.hdr.used, 12000), show (col.hdr.pspc, 12000),
	   show (col.hdr.net, 12000), show (col.depth_adj, 12000),
	   (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000));

        call ioa_ ("pag=^a c^d u^f(^f)/^f^[ pi=^d ^f^])", page.hdr.pageno,
	   page.parms.cols.count, show (page.hdr.used, 12000),
	   show (page.hdr.hdspc, 12000), show (page.hdr.net, 12000),
	   (shared.picture.count > 0), shared.picture.count,
	   show (shared.picture.space, 12000));
      end;

    return;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_insert;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

  end comp_break_;




		    comp_break_ctls_.pl1            04/23/85  1059.2rew 04/23/85  0908.9      209097



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

/* compose suboutine impelmenting all break forms */

/* format: style2,ind3,ll79,dclind4,idind15,comcol41,linecom */

comp_break_ctls_:
   proc (ctl_index);

/* PARAMETERS */

      dcl ctl_index	     fixed bin;	/* control index */

/* LOCAL STORAGE */

      dcl blank_count    fixed bin;	/* blank pages to be skipped */
      dcl blank_ftr	     char (1020) var;
      dcl blank_hdr	     char (1020) var;
      dcl blkusd	     fixed bin (31);
      dcl break_type     fixed bin;	/* what flavor for .brc */
      dcl fnxt	     fixed bin (21);/* next variable field char */
				/* for debug at exit */
      dcl exit_str	     char (100) var init ("");
      dcl (i, j, k)	     fixed bin;	/* working index */
      dcl mode_str	     char (128) varying;
				/* mode for page & par numbers */
      dcl ms_mode	     char (2);	/* mode extracted from mode string */
      dcl needed	     fixed bin (31);/* space needed by break-need */
      dcl new_col	     fixed bin;	/* target column */
      dcl new_pageno     char (32) var; /* new page number for .brp */
      dcl old_col	     fixed bin;	/* column we're leaving */
      dcl page_incr	     fixed bin;	/* break number increment for break-page */
      dcl save_colno     fixed bin;	/* to save colno around page breaks */
      dcl save_ctl_line  char (1020) var;
      dcl save_ctl_index fixed bin;
      dcl save_input     bit (1);
      dcl 1 save_text_input
		     aligned like text_entry;
      dcl scale	     (1) fixed bin (31) static options (constant)
		     init (1000);
      dcl unscaled	     (1) fixed bin (31) static options (constant) init (1);
      dcl val	     char (32) var; /* value extracted from val string */
      dcl val_str	     char (128) var;/* value for page & par numbers */
      dcl varfld	     char (1020) var;
      dcl vscales	     (7) fixed bin (31) static options (constant)
		     init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);

      dcl (index, length, max, mod, null)
		     builtin;
      dcl end_output     condition;
      dcl continue_to_signal_
		     entry (fixed bin (35));
      dcl ioa_$rsnnl     entry options (variable);

      if shared.bug_mode
      then call ioa_ ("break_ctls: (^d) ""^a""", ctl_index, ctl_line);

      on end_output			/* pass the buck */
         call continue_to_signal_ (0);

      goto ctl_ (ctl_index);

ctl_ (34):			/* ".br" = break-block */
ctl_ (35):			/* ".brb" = break-block */
brb_ctl:
      if shared.table_mode		/* map into a .brf */
      then goto brf_ctl;

      if shared.blkptr ^= null
      then if text.hdr.count > 0 | text.input_line ^= ""
	 then
	    do;			/**/
				/* pending caption? */
	       if text.parms.ftrptr ^= null & ^shared.inserting_hfc
	       then
		do;
		   if text.input_line ^= ""
		   then call comp_break_ (format_break, 0);
		   call comp_title_block_ (text.parms.ftrptr);
		end;

	       call comp_break_ (block_break, 0);
	    end;

      goto return_;

ctl_ (36):			/* ".brc" = break-column */
      if current_parms.keep
      then
         do;
	  call comp_report_ (2, 0, "break-column in a keep block ignored.",
	       addr (ctl.info), ctl_line);
	  goto return_;
         end;

      if shared.table_mode
      then
         do;
	  call comp_report_ (2, 0, "break-column in table mode ignored.",
	       addr (ctl.info), ctl_line);
	  goto return_;
         end;

      if page.parms.cols.count = 0	/* if not multicolumn */
      then new_col = 0;

      else			/* multicolumn */
         do;			/* if a column number is given */
	  if ctl.index <= length (ctl_line)
	  then
	     do;
	        new_col =
		   comp_read_$number (ctl_line, 1, ctl.index, ctl.index,
		   addr (ctl.info), 0);
	        if new_col < 0
	        then
		 do;
		    call comp_report_ (2, 0, "Positive value required.",
		         addr (ctl.info), ctl_line);
		    goto return_;
		 end;		/**/
				/* too big? */
	        if new_col > page.parms.cols.count
	        then
		 do;
		    call comp_report_ (2, 0, "Given column not defined.",
		         addr (ctl.info), ctl_line);
		    goto return_;
		 end;
	     end;

	  else new_col = mod (page.hdr.col_index, page.parms.cols.count) + 1;

join_brc:				/* dont balance this page */
	  if new_col > 0 & page.hdr.col_index > 0
	  then page.parms.cols.bal = "0"b;
         end;

      if shared.blkptr ^= null
      then
         do;			/**/
				/* pending header? */
	  if text.parms.hdrptr ^= null & ^shared.inserting_hfc
	  then call comp_title_block_ (text.parms.hdrptr);

	  blkusd =
	       text.hdr.used
	       + bin (text.input_line ^= "") * text.parms.linespace;
         end;
      else blkusd = 0;		/**/
				/* fill column with WS */
      if page.hdr.col_index > 0 & page.hdr.used > 0 & ^page.parms.cols.bal
	 & col.hdr.net - col.depth_adj > col.hdr.used + blkusd
      then call comp_space_ (col.hdr.net - col.depth_adj - col.hdr.used
	      - blkusd, shared.blkptr, "1"b, "1"b, "1"b, "0"b);

      old_col = page.hdr.col_index;	/* save exit column */
				/* entering or leaving col0? */
      if (old_col = 0 | new_col = 0) & page.hdr.used > 0
      then call comp_break_ (column_break, 0);
				/* * bin (^page.parms.cols.bal));*/

      if page.parms.cols.count > 0	/* if multicolumn and not moving */
	 & old_col ^= 0 & new_col ^= 0/* to/from column 0 */
      then			/* fill intervening columns */
         do;			/* with nontrimmable WS */
	  if old_col < page.parms.cols.count & new_col ^= old_col + 1
	  then
	     do i = old_col + 1 to page.parms.cols.count;
	        page.hdr.col_index = i;
	        shared.colptr = page.column_ptr (i);
	        if col.hdr.net - col.depth_adj > col.hdr.used
	        then call comp_space_ (col.hdr.net - col.depth_adj
		        - col.hdr.used, null, "1"b, "1"b, "1"b, "0"b);
	        call comp_break_ (block_break, 0);
	     end;

	  if new_col > 1
	  then
	     do i = 1 to new_col - 1;
	        page.hdr.col_index = i;
	        shared.colptr = page.column_ptr (i);
	        if col.hdr.net - col.depth_adj > col.hdr.used
	        then call comp_space_ (col.hdr.net - col.depth_adj
		        - col.hdr.used, null, "1"b, "1"b, "1"b, "0"b);
	        call comp_break_ (block_break, 0);
	     end;
         end;

      if new_col <= old_col & new_col ^= 0
      then call comp_break_ (page_break, new_col);

      if old_col = 0		/* if leaving column 0 */
      then
         do i = 1 to page.hdr.col_count;
	  page.column_ptr (i) -> col.hdr.depth = col0.hdr.depth;
         end;

      page.hdr.col_index = new_col;	/* set the new column */
      page.hdr.col_count = max (page.hdr.col_count, new_col);
      shared.colptr = page.column_ptr (new_col);

      if page.hdr.col_index = 0
      then current_parms.measure = page_parms.measure;
      else current_parms.measure = col.parms.measure;

      if shared.bug_mode
      then call ioa_$rsnnl ("col=^d u^f mrg=^f/^f/^f", exit_str, 0,
	      page.hdr.col_index, show (col.hdr.used, 12000),
	      show (col.margin.left, 12000), show (col.parms.measure, 12000),
	      show (col.margin.right, 12000));

      goto return_;

ctl_ (37):			/* ".brf" = break-format */
brf_ctl:
      if shared.blkptr ^= null
      then if length (text.input_line) > 0
	 then call comp_break_ (format_break, 0);

      goto return_;

ctl_ (38):			/* ".brn" = break-need */
      if option.galley_opt		/* ignore it in galley */
      then goto return_;

      else if current_parms.keep	/* needs within keeps not allowed */
      then call comp_report_ (2, 0, "break-need in a keep block ignored.",
	      addr (ctl.info), ctl_line);

      else if shared.ftn_mode		/* needs within ftns not allowed */
      then call comp_report_ (2, 0, "break-need in a footnote block ignored.",
	      addr (ctl.info), ctl_line);

      else
         do;
	  if ctl.index > length (ctl_line)
	  then needed = 12000;	/* default value */
	  else needed =
		  comp_read_$number (ctl_line, vscales, ctl.index,
		  ctl.index, addr (ctl.info), 0);

	  save_input = "0"b;
	  if shared.blkptr ^= null ()
	  then
	     do;
	        save_input = "1"b;
	        save_ctl_line = text.input_line;
	        save_text_input = text.input;
	        needed = needed + text.hdr.used;

	        if length (text.input_line) > 0
	        then needed = needed + 12000;
	     end;

	  if page.hdr.col_index = 0	/* need page space */
	  then
	     do;
	        if shared.bug_mode
	        then call ioa_ ("   (need page ^f have ^f)",
		        dec (divide (needed, 12000, 31, 10), 11, 3),
		        dec (
		        divide (col0.hdr.net - col0.depth_adj
		        - col0.hdr.used - col0.hdr.ftn.usd, 12000, 31, 10),
		        11, 3));

	        if needed
		   > col0.hdr.net - col0.depth_adj - col0.hdr.used
		   - col0.hdr.ftn.usd
	        then
		 do;
		    if ^save_input
		    then call comp_break_ (page_break, 0);

		    else
		       do;
			call comp_break_ (need_break, -2);

			if ^shared.end_output & shared.blkptr = null
			then
			   do;
			      call comp_head_page_ (0);
			      call comp_util_$getblk (0, shared.blkptr,
				 "tx", addr (current_parms), "0"b);
			      text.input = save_text_input;
			      text.input.ptr = addr (text.input_line);
			      text.input_line = save_ctl_line;
			   end;
		       end;
		 end;
	     end;

	  else
	     do;			/* need column space */
	        if shared.bug_mode
	        then call ioa_ ("   (need col ^f have ^f)",
		        dec (divide (needed, 12000, 31, 10), 11, 3),
		        dec (
		        divide (col.hdr.net - col.depth_adj
		        - col.hdr.used - col.hdr.ftn.usd, 12000, 31, 10),
		        11, 3));

	        if needed
		   > col.hdr.net - col.depth_adj - col.hdr.used
		   - col.hdr.ftn.usd
	        then
		 do;
		    new_col =
		         mod (page.hdr.col_index, page.parms.cols.count)
		         + 1;
		    goto join_brc;
		 end;
	     end;
         end;
      goto return_;

ctl_ (39):			/* ".brp" = break-page */
brp_ctl:
      if option.galley_opt		/* in galley, */
      then goto brb_ctl;		/* map into a block break */

      if current_parms.keep		/* no brp's in keep */
      then
         do;
	  call comp_report_ (2, 0, "break-page in a keep block ignored.",
	       addr (ctl.info), ctl_line);
	  goto return_;
         end;

      if shared.ftn_mode		/* no brp's in ftns */
      then
         do;
	  call comp_report_ (2, 0, "break-page in a footnote block ignored.",
	       addr (ctl.info), ctl_line);
	  goto return_;
         end;

      if shared.table_mode
      then
         do;
	  tblfmtndx = tbldata.ndx;	/* save table data */
	  tblfmtptr = tbldata.fmt (tblfmtndx).ptr;
	  save_colno = tblfmt.ccol;
         end;			/**/
				/* anything on the page? */
      if page.hdr.used > 0 | shared.blkptr ^= null ()
      then call comp_break_ (page_break, 0);
				/* if a param is given */
      if ctl.index <= length (rtrim (ctl_line))
      then
         do;
	  if substr (ctl_line, ctl.index) = "e"
	  then
	     do;			/* if param is "even" */
	        if ^page.hdr.frontpage/* and so it the last output page */
	        then call comp_util_$pageno (1000, new_pageno);
	        goto brp_exit;
	     end;

	  else if substr (ctl_line, ctl.index) = "o"
	  then
	     do;			/* if param is "odd" */
	        if page.hdr.frontpage /* and so it the last output page */
	        then call comp_util_$pageno (1000, new_pageno);
	        goto brp_exit;
	     end;

	  else			/* set to given parameter */
	     do;			/* if an increment */
	        if substr (ctl_line, ctl.index, 1) = "+"
	        then
		 do;
		    page_incr =
		         comp_read_$number (ctl_line, scale, ctl.index,
		         ctl.index, addr (ctl.info), 0) + 1000;
		    call comp_util_$pageno (page_incr, new_pageno);
		 end;

	        else
		 do;
		    val_str = before (substr (ctl_line, ctl.index), " ");
		    mode_str = after (substr (ctl_line, ctl.index), " ");

		    i, j = 0;	/* parse the given page number */
		    do while (length (val_str) > 0);
				/* look for a separator */
		       k = search (val_str, "-.()|");

		       if k > 0	/* is there one? */
		       then
			do;
			   val = substr (val_str, 1, k - 1);
			   if substr (val_str, k, 1) = "|"
			   then shared.pagenum.sep (i + 1) = "";
			   else shared.pagenum.sep (i + 1) =
				   substr (val_str, k, 1);
			   val_str = substr (val_str, k + 1);
			   ms_mode = before (mode_str, ",");
			   mode_str = after (mode_str, ",");
			end;

		       else
			do;
			   ms_mode = mode_str;
			   val = val_str;
			   val_str, mode_str = "";
			end;	/**/
				/* if there is no mode, */
		       if ms_mode = ""
		       then
			do;	/* val is what it appears to be */
				/* numeric */
			   if verify (val, "0123456789") = 0
			   then
			      do;
			         shared.pagenum.mode (i + 1) = 0;
				/* ar display */
			         shared.pagenum.nmbr (i + 1) =
				    1000 * bin (val);
			      end;/**/
				/* roman lower */
			   else if verify (val, "ixcmvld") = 0
			   then
			      do;
			         shared.pagenum.mode (i + 1) = 6;
				/* rl display */
			         shared.pagenum.nmbr (i + 1) =
				    read_roman (val, 6);
			      end;/**/
				/* roman upper */
			   else if verify (val, "IXCMVLD") = 0
			   then
			      do;
			         shared.pagenum.mode (i + 1) = 7;
				/* ru display */
			         shared.pagenum.nmbr (i + 1) =
				    read_roman (val, 7);
			      end;/**/
				/* apha lower */
			   else if
			        verify (val,
			        "abcdefghijklmnopqrstuvwxyz") = 0
			   then
			      do;
			         shared.pagenum.mode (i + 1) = 4;
				/* al display */
			         shared.pagenum.nmbr (i + 1) =
				    read_alpha (val, 4);
			      end;/**/
				/* alpha upper */
			   else if
			        verify (val,
			        "ABCDEFGHIJKLMNOPQRSTUVWXYZ") = 0
			   then
			      do;
			         shared.pagenum.mode (i + 1) = 5;
				/* au display */
			         shared.pagenum.nmbr (i + 1) =
				    read_alpha (val, 5);
			      end;
			end;

		       else	/* set index value for */
			do;	/* given mode */
			   shared.pagenum.mode (i + 1) =
			        index (mode_string, ms_mode);
				/* key not found */
			   if shared.pagenum.mode (i + 1) = 0
			   then call comp_report_ (2, 0,
				   "Unknown display mode keyword.",
				   addr (ctl.info), ctl_line);
				/* compute true index value */
			   shared.pagenum.mode (i + 1) =
			        divide (shared.pagenum.mode (i + 1), 2,
			        17);
				/* if a numeric is given */
			   if verify (val, "0123456789") = 0
			   then shared.pagenum.nmbr (i + 1) =
				   1000 * bin (val);

			   else if shared.pagenum.mode (i + 1) = 6
			   then shared.pagenum.nmbr (i + 1) =
				   read_roman (val, 6);

			   else if shared.pagenum.mode (i + 1) = 7
			   then shared.pagenum.nmbr (i + 1) =
				   read_roman (val, 7);

			   else if shared.pagenum.mode (i + 1) = 4
			   then shared.pagenum.nmbr (i + 1) =
				   read_alpha (val, 4);

			   else if shared.pagenum.mode (i + 1) = 5
			   then shared.pagenum.nmbr (i + 1) =
				   read_alpha (val, 5);
			end;

		       shared.pagenum.index, i = i + 1;
		    end;
		 end;		/**/
				/* use -1 here since head_page */
				/* bump it be one */
	        call comp_util_$pageno (-1000, new_pageno);
	        page_header.modified, page.hdr.modified = "0"b;
	     end;

	  page.hdr.pageno = new_pageno;
         end;

brp_exit:
      if page.parms.cols.count > 0	/* if a multi-column page */
      then
         do;
	  page.hdr.col_index = 1;
	  shared.colptr = page.column_ptr (1);
	  current_parms.measure = col.parms.measure;
         end;

      if shared.table_mode
      then
         do;
	  ctl_line = ".tac " || ltrim (char (save_colno));
	  ctl.index = 6;
	  call comp_tbl_ctls_ (tac_ctl_index);
         end;

      if shared.bug_mode
      then call ioa_$rsnnl ("col=^d pageno=^a ^[front^;back^]", exit_str, 0,
	      page.hdr.col_index, page.hdr.pageno, page.hdr.frontpage);

      goto return_;

read_roman:
   proc (rstr, rmode) returns (fixed bin (31));

      dcl rstr	     char (32) var;
      dcl rmode	     fixed bin (8);

      dcl rconstr	     (2) char (7) static options (constant)
		     init ("ivxlcdm", "IVXLCDM");
      dcl rvals	     (7) fixed bin static options (constant)
		     init (1, 5, 10, 50, 100, 500, 1000);
      dcl (ri, rj, rk)   fixed bin;
      dcl rval	     fixed bin (31);

      rval = 0;
      do ri = 1 to length (rstr);	/* which char do we have? */
         rj = index (rconstr (rmode - 5), substr (rstr, ri, 1));
				/* if the char following represents a
				   larger value, then the current char
				   subtracts its value from that one.
				   Luckily, Roman numbering defined only
				   one such subtraction!  */
         if ri < length (rstr)	/* if not the last char */
         then
	  do;
	     rk = index (rconstr (rmode - 5), substr (rstr, ri + 1, 1));
	     if rk > rj
	     then
	        do;
		 rval = rval + rvals (rk) - rvals (rj);
		 ri = ri + 1;
	        end;		/* otherwise, the char simply adds
				   its value */
	     else rval = rval + rvals (rj);
	  end;
         else rval = rval + rvals (rj); /* last char adds it value */
      end;

      return (1000 * rval);

   end read_roman;

read_alpha:
   proc (astr, amode) returns (fixed bin (31));

      dcl astr	     char (32) var;
      dcl amode	     fixed bin (8);

      dcl aconstr	     (2) char (26) static options (constant)
		     init ("abcdefghijklmnopqrstuvwxyz",
		     "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
      dcl ai	     fixed bin;
      dcl aval	     fixed bin (31);

      aval = 0;
      do ai = 1 to length (astr);
         aval = 26 * aval + index (aconstr (amode - 3), substr (astr, ai, 1));
      end;

      return (1000 * aval);

   end read_alpha;

ctl_ (40):			/* ".brs" = break-skip */
      if shared.blkptr ^= null ()
      then if text.parms.keep
	 then
	    do;
	       call comp_report_ (2, 0,
		  "break-skip in a keep block ignored.", addr (ctl.info),
		  ctl_line);
	       goto return_;
	    end;

      if page.hdr.used > 0		/* if anything on the page */
      then call comp_break_ (page_break, 0);

      else if shared.blkptr ^= null ()	/* or anything waiting */
      then if text.hdr.used > 0 | text.input_line ^= ""
	 then call comp_break_ (page_break, 0);

      varfld = substr (ctl_line, ctl.index);

      if varfld ^= ""		/* if there is a variable field */
      then
         do;			/* parameter = "even"? */
	  if substr (varfld, 1, 1) = "e"
	  then
	     do;
	        if ^page.hdr.frontpage
	        then blank_count = 1;
	        else blank_count = 0;
	        varfld = ltrim (substr (varfld, 2));
	     end;			/**/
				/* parameter = "odd"? */
	  else if substr (varfld, 1, 1) = "o"
	  then
	     do;
	        if page.hdr.frontpage
	        then blank_count = 1;
	        else blank_count = 0;
	        varfld = ltrim (substr (varfld, 2));
	     end;

	  else if index ("0123456789+", substr (varfld, 1, 1)) ^= 0
	  then
	     do;
	        blank_count =
		   comp_read_$number (varfld, unscaled, 1, fnxt,
		   addr (ctl.info), 0);
	        varfld = ltrim (substr (varfld, fnxt));
	     end;

	  else blank_count = 1;	/* no control parameter */
         end;

      else blank_count = 1;		/* set default if nothing given */

      if blank_count > 0		/* if any separating pages */
      then
         do;
	  if varfld ^= ""		/* any more in the variable field? */
	  then
	     do;			/* text is first */
				/* get a block for it */
	        call comp_util_$getblk (-1, shared.blank_text_ptr, "bt",
		   addr (current_parms), "0"b);
	        shared.blank_text_ptr -> text.input.quad = quadc;
	        shared.blank_text_ptr -> text.input.rmarg =
		   page.parms.measure;
				/* get the text */
	        shared.blank_text_ptr -> text.input_line =
		   comp_extr_str_ ("1"b, varfld, 1, fnxt, 0,
		   addr (ctl.info));
	        varfld = ltrim (substr (varfld, fnxt));
				/* page header is next */
	        if varfld ^= ""
	        then
		 do;		/* get a block for it */
		    call comp_util_$getblk (-1, shared.blank_header_ptr,
		         "bh", addr (current_parms), "0"b);
		    hfcblk_ptr = shared.blank_header_ptr;
				/* get the title */
		    blank_hdr =
		         comp_extr_str_ ("1"b, varfld, 1, fnxt, 0,
		         addr (ctl.info));
		    if blank_hdr ^= ""
		    then call comp_hft_ctls_$title (shared
			    .blank_header_ptr, addr (ctl), blank_hdr,
			    ctl.linespace);
		    varfld = ltrim (substr (varfld, fnxt));
		 end;		/**/
				/* page footer is last */
	        if varfld ^= ""
	        then
		 do;		/* get a block for it */
		    call comp_util_$getblk (-1, shared.blank_footer_ptr,
		         "bf", addr (current_parms), "0"b);
		    hfcblk_ptr = shared.blank_footer_ptr;
				/* get the title */
		    blank_ftr =
		         comp_extr_str_ ("1"b, varfld, 1, fnxt, 0,
		         addr (ctl.info));

		    if blank_ftr ^= ""
		    then call comp_hft_ctls_$title (shared
			    .blank_footer_ptr, addr (ctl), blank_ftr,
			    ctl.linespace);
		 end;
	     end;

	  if ^option.galley_opt
	  then
	     do;			/* write the blank pages */
	        do i = blank_count to 1 by -1;
		 page.hdr.blankpage = "1"b;
				/* head the page */
		 call comp_head_page_ (0);
				/* write any given text */
		 if shared.blank_text_ptr ^= null ()
		 then if shared.blank_text_ptr -> text.input_line ^= ""
		      then
		         do;	/* space down to page center */
			  call comp_space_ (
			       divide (page.hdr.net, 2, 31, 10),
			       shared.blkptr, "1"b, "1"b, "0"b, "0"b);
			  call comp_break_ (block_break, 0);
			  call comp_util_$getblk (0, shared.blkptr, "tx",
			       addr (current_parms), "0"b);
			  call comp_util_$add_text (shared.blkptr, "1"b,
			       "1"b, "1"b, "0"b,
			       addr (shared.blank_text_ptr -> text.input)
			       );
			  call comp_break_ (page_break, 0);
		         end;
		      else call comp_eject_page_;
		 else call comp_eject_page_;
	        end;

	        page.hdr.blankpage = "0"b;
	     end;

	  if shared.blank_header_ptr ^= null
	  then call comp_util_$relblk (-1, shared.blank_header_ptr);
	  if shared.blank_footer_ptr ^= null
	  then call comp_util_$relblk (-1, shared.blank_footer_ptr);
	  if shared.blank_text_ptr ^= null
	  then call comp_util_$relblk (-1, shared.blank_text_ptr);
         end;

return_:
      if shared.bug_mode
      then call ioa_ ("^5x(break_ctls:^[ ^a^])", exit_str ^= "", exit_str);

      return;
%page;
show:
   proc (datum, scale) returns (fixed dec (11, 3));
      dcl datum	     fixed bin (31);
      dcl scale	     fixed bin (31);

      return (
	 round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
   end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_entries;
%include comp_fntstk;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

   end comp_break_ctls_;




		    comp_ctls_.pl1                  04/23/85  1059.2rew 04/23/85  0909.0      798003



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

/* compose routine to process text controls */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_ctls_:
  proc (text_added);

/* PARAMETERS */

    dcl text_added	   bit (1) aligned; /* flag to show text was generated */

/* LOCAL STORAGE */

    dcl again	   bit (1);	/* 1 = process line as control line */
    dcl atd	   char (300);	/* attach description for input */
    dcl aux_wrt_buf	   char (1020) var; /* buffer for aux file data */
    dcl aux_file_index fixed;		/* table index for aux write file */
    dcl blnkct	   fixed bin (31);	/* blank line count */
    dcl break_type	   fixed bin;	/* break type for space ctls */
    dcl callers_nest   fixed bin;	/* callers if nest level */
				/* heading line for compx file */
    dcl chars_head	   char (19) aligned static options (constant)
		   init ("  Page  Line  Text
");				/**/
				/* command line for .exc */
    dcl command_line   char (1020) aligned;
    dcl compx_buffer   char (128) var;	/* compx line buffer */
    dcl cond_name	   char (32) var;	/* condition name */
				/* legal condition names */
    dcl cond_names	   (1) char (32) var static options (constant)
		   init ("block_split");
				/* control tokens */
/**** format: off */
      dcl controls	     (374) char (32) init (
                         "alb   ", "align-both                ",
                         "alc   ", "align-center              ",
                         "ali   ", "align-inside              ",
                         "all   ", "align-left                ",
                         "alo   ", "align_outside             ",
                         "alr   ", "align-right               ",
                         "bb    ", "block-begin               ", /* OBSOLETE */
                         "bart  ", "begin-artwork             ",
                         "bba   ", "block-begin-art           ", /* OBSOLETE */
                         "bblk  ", "begin-block               ", /* 10 */
                         "bbc   ", "block-begin-column        ", /* OBSOLETE */
		     "bbe   ", "block-begin-equation      ", /* OBSOLETE */
		     "bbf   ", "block-begin-footnote      ", /* OBSOLETE */
		     "bbi   ", "block-begin-inline        ", /* OBSOLETE */
		     "bbk   ", "block-begin-keep          ", /* OBSOLETE */
		     "bbl   ", "block-begin-literal       ", /* OBSOLETE */
		     "bbn   ", "block-begin-named         ", /* OBSOLETE */
		     "bbp   ", "block-begin-picture       ", /* OBSOLETE */
		     "bbt   ", "block-begin-title         ", /* OBSOLETE */
		     "bcf   ", "begin-column-footer       ", /* 20 */
		     "bch   ", "begin-column-header       ",
		     "be    ", "block-end                 ", /* OBSOLETE */
		     "bea   ", "block-end-art             ", /* OBSOLETE */
		     "bec   ", "block-end-column          ", /* OBSOLETE */
		     "bee   ", "block-end                 ", /* OBSOLETE */
		     "bef   ", "block-end-footnote        ", /* OBSOLETE */
		     "bek   ", "block-end-keep            ", /* OBSOLETE */
		     "bel   ", "block-end-literal         ", /* OBSOLETE */
		     "ben   ", "block-end-named           ", /* OBSOLETE */
		     "bep   ", "block-end-picture         ", /* 30 OBSOLETE */
		     "bet   ", "block-end-title           ", /* OBSOLETE */
		     "bpf   ", "begin-page-footer         ", 
		     "bph   ", "begin-page-header         ",
		     "br    ", "break                     ",
		     "brb   ", "break-block               ",
		     "brc   ", "break-column              ",
		     "brf   ", "break-format              ",
		     "brn   ", "break-need                ",
		     "brp   ", "break-page                ",
		     "brs   ", "break-skip                ", /* 40 */
		     "brw   ", "break-word                ",
		     "btc   ", "begin-text-caption        ",
		     "btt   ", "begin-text-title          ",
		     "cba   ", "change-bars-addition      ",
		     "cbd   ", "change-bars-deletion      ",
		     "cbf   ", "change-bars-off           ",
		     "cbm   ", "change-bars-modification  ",
		     "cbn   ", "changes-bars-on           ",
		     "cfl   ", "column-footer-line        ",
		     "chl   ", "column-header-line        ", /* 50 */
		     "csd   ", "change-symbol-delimiter   ",
		     "ctd   ", "change-title-delimiter    ",
		     "dfu   ", "defer-until               ",
		     "dmp   ", "dump                      ",
		     "do    ", "do                        ",
		     "dvc   ", "device-control            ",
		     "eart  ", "end-artwork               ",
		     "ecf   ", "end-column-footer         ",
		     "ech   ", "end-column-header         ",
		     "else  ", "else                      ", /* 60 */
		     "elseif", "elseif                    ",
		     "enddo ", "enddo                     ",
		     "endif ", "endif                     ",
		     "epf   ", "end-page-footer           ",
		     "eph   ", "end-page-header           ",
		     "eqc   ", "equation-count            ",
		     "err   ", "error                     ",
		     "etc   ", "end-text-caption          ",
		     "ett   ", "end-text-title            ",
		     "exc   ", "execute                   ", /* 70 */
		     "fb    ", "footer-block              ",
		     "fbb   ", "footer-block-begin        ", /* OBSOLETE */
		     "fbe   ", "footer-block-end          ", /* OBSOLETE */
		     "fi    ", "fill-default              ",
		     "fif   ", "fill-off                  ", 
		     "fin   ", "fill-on                   ",
		     "fl    ", "footer-line               ",
		     "fla   ", "footer-line-all           ",
		     "fle   ", "footer-line-even          ",
		     "flo   ", "footer-line-odd           ", /* 80 */
		     "fnt   ", "font                      ",
		     "frf   ", "footnote-reference        ",
		     "fth   ", "footnotes-held            ",
		     "ftp   ", "footnotes-paged           ",
		     "ftr   ", "footnotes-running         ",
		     "ftu   ", "footnotes-unreferenced    ",
		     "galley", "galley-mode               ",
		     "gl    ", "galley-mode               ",
		     "go    ", "go-to                     ", 
		     "hb    ", "header-block              ", /* 90 */
		     "hbb   ", "header-block-begin        ",
		     "hbe   ", "header-block-end          ",
		     "hif   ", "hit-file                  ",
		     "hit   ", "hit                       ",
		     "hl    ", "header-line               ",
		     "hla   ", "header-line-all           ",
		     "hle   ", "header-line-even          ",
		     "hlf   ", "header-line-footnote      ",
		     "hlo   ", "header-line-odd           ",
		     "hrul  ", "horizontal-rule           ", /* 100 */
		     "htd   ", "horizontal-tabs-define    ",
		     "htf   ", "horizontal-tabs-off       ",
		     "htn   ", "horizontal-tabs-on        ",
		     "hy    ", "hyphenate-default         ",
		     "hyf   ", "hyphenate-off             ",
		     "hyn   ", "hyphenate-on              ",
		     "hyw   ", "hyphenate-word            ",
		     "ibl   ", "insert-block              ",
		     "if    ", "if                        ",
		     "ifi   ", "insert-file               ", /* 110 */
		     "ift   ", "insert-footnotes          ",
		     "igr   ", "insert-graphic            ",
		     "in    ", "indent                    ",
		     "inb   ", "indent-both               ",
		     "inl   ", "indent-left               ",
		     "inr   ", "indent-right              ",
		     "indctl", "indent-controls           ",
		     "indx  ", "insert-index              ",
		     "la    ", "label                     ",
		     "ls    ", "linespace                 ", /* 120 */
		     "pd    ", "page-define               ",
		     "pdc   ", "page-define-columns       ",
		     "pdl   ", "page-define-length        ",
		     "pdw   ", "page-define-width         ",
		     "pfl   ", "page-footer-line          ",
		     "phl   ", "page-header-line          ",
		     "pml   ", "page-margin-left          ",
		     "ps    ", "page-space                ",
		     "rac   ", "runaround-centered        ",
		     "ral   ", "runaround-left            ", /* 130 */
		     "rar   ", "runaround-right           ",
		     "rd    ", "read                      ",
		     "rt    ", "return                    ",
		     "sp    ", "space                     ",
		     "spb   ", "space-break               ",
		     "spd   ", "space-to-depth            ",
		     "spf   ", "space-format              ",
		     "spt   ", "space-total               ",
		     "sr    ", "set-reference             ",
		     "src   ", "set-reference-counter     ", /* 140 */
		     "srm   ", "set-reference-mode        ",
		     "srv   ", "set-reference-variable    ",
		     "stl   ", "split-title-line          ",
		     "tab   ", "table-define              ",
		     "tac   ", "table-column              ",
		     "taf   ", "table-off                 ",
		     "tan   ", "table-on                  ",
		     "tb    ", "title-block               ",
		     "tbb   ", "title-block-begin         ",
		     "tbe   ", "title-block-end           ", /* 150 */
		     "tcl   ", "text-caption-line         ",
		     "then  ", "then                      ",
		     "thl   ", "text-header-line          ",
		     "tlc   ", "title-line-caption        ",
		     "tlh   ", "title-line-header         ",
		     "tre   ", "translate-exceptions      ",
		     "trf   ", "translate-formatted       ",
		     "trn   ", "translate                 ",
		     "ttl   ", "text-title-line",
		     "ts    ", "test                      ", /* 160 */
		     "ty    ", "type                      ",
		     "un    ", "undent                    ",
		     "unb   ", "undent-both",
		     "unh   ", "undent-hanging            ",
		     "unl   ", "undent-left               ",
		     "unn   ", "undent-nobreak            ",
		     "unr   ", "undent-right              ",
		     "unson ", "underscore-on             ",
		     "unsoff", "underscore-off            ",
		     "ur    ", "use-reference             ", /* 170 */
		     "vab   ", "vertical-align-bottom     ",
		     "vac   ", "vertical-align-center     ",
		     "vaj   ", "vertical-align-justified  ",
		     "vat   ", "vertical-align-top        ",
		     "vm    ", "vertical-margin-all       ",
		     "vmb   ", "vertical-margin-top       ",
		     "vmf   ", "vertical-margin-footer    ",
		     "vmh   ", "vertical-margin-header    ",
		     "vmt   ", "vertical-margin-top       ",
		     "vrul  ", "vertical-rule             ", /* 180 */
		     "wi    ", "widow                     ",
		     "wif	  ", "widow-footnote            ",
		     "wit   ", "widow-text                ",
		     "wrf   ", "write-formatted           ",
		     "wro   ", "write-order               ",
		     "wrt   ", "write-text                ",
		     "wt    ", "wait                      ",
		     (0) (32)"")		     /* 187 */
		     static options (constant);
/**** format: on */
    dcl CREATE	   bit (1) static options (constant) init ("1"b);
				/* ctl line index for translation */
    dcl 1 ctl_char	   based (addr (ctl_line)),
	2 len	   fixed (35),
	2 index	   (1020) fixed (8) unaligned;
    dcl ctl_index	   fixed bin;	/* control token index value */
				/* ctl string for search */
    dcl ctl_list	   char (32 * hbound (controls, 1)) based (ctls_ptr);
    dcl ctls_ptr	   ptr;		/**/
    dcl ctl_token	   char (32);	/* control token from input line */
    dcl ctl_token_len  fixed bin;	/* string length of control token */
    dcl dirl	   fixed (35);
    dcl dirname	   char (168);	/* dir for insert & aux files */
    dcl ELSE	   fixed bin static options (constant) init (-1);
    dcl endchar	   char (1);
    dcl end_flag	   bit (1) static init ("0"b);
				/* for label searching */
    dcl ercd	   fixed (35);	/* error code */
    dcl exit_str	   char (128) var;	/* debug message */
    dcl fcs_str	   char (8) aligned;
    dcl footref_array  (3) char (48) var;
    dcl footrefstr	   char (256) var;
    dcl found_clause   bit (1);
    dcl ftnblkptr	   ptr;		/* a footnote block */
    dcl 1 ftnblk	   aligned like text based (ftnblkptr);
    dcl ftndx	   fixed bin;	/* blkndx value for footnotes */
    dcl ftnreflin	   fixed bin;	/* ref line index for ftn thread */
    dcl given_symbol   char (32);	/* symbol name for .sr/.srv/.src */
    dcl head_used	   fixed bin (31);	/* space used by page header */
    dcl hit_text	   char (1020) var;
    dcl hitfilendx	   fixed bin;	/* local hit file index */
    dcl hitcharndx	   fixed bin;
    dcl hittypechar	   char (1);	/* hit type desired */
    dcl hittypecodes   char (8) static options (constant) init ("ULIANS*K");
    dcl hittypendx	   fixed bin;	/* index for hit type */
    dcl hscales	   (7) fixed bin (31) static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl (i, j, k, l)   fixed bin;	/* working index */
    dcl itsptr	   ptr;		/* local ITS pointer */
    dcl label_value_str		/* string of label values for search */
		   char (3200) based;
    dcl lineno_pic	   pic "zzzzz9";	/* picture of lineno for compx */
    dcl LOG	   fixed bin static options (constant) init (1);
    dcl mode_key	   char (2) var;	/* display mode keyword */
    dcl modendx	   fixed bin;	/* for display mode keyword */
    dcl namel	   fixed (35);
    dcl oflo	   bit (1);
    dcl pgs_path	   char (200);	/* path of PGS for graphic insertion */
    dcl rdct	   fixed bin (35);	/* chars read for .rd */
    dcl save_ctl_index fixed (35);	/* to save ctl.index around calls */
    dcl save_line	   char (1020) var; /* to hold .go line */
    dcl save_posn	   fixed (35);	/* to hold position of .go control */
    dcl scale	   (1) fixed bin (31) static options (constant)
		   init (1000);
    dcl search_label   char (32);	/* label value for search */
    dcl slog	   bit (1);
    dcl THEN	   fixed bin static options (constant) init (1);
    dcl this_nest	   fixed bin;	/* for if nest searching */
				/* WS trim control flag */
    dcl trim_flag	   bit (1);
    dcl ty_buf	   char (200);
    dcl unscaled	   (1) fixed bin (31) static options (constant) init (1);
    dcl vscales	   (7) fixed bin (31) static options (constant)
		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);
    dcl wdir	   char (168);
    dcl wdirl	   fixed;
    dcl wrd_buffer	   char (128) var;	/* break word buffer */

    dcl comp_error_table_$syntax_error
		   ext fixed bin (35);
    dcl comp_error_table_$unknown_keyword
		   ext fixed bin (35);
    dcl comp_error_table_$usage_error
		   ext fixed bin (35);

    dcl (addr, before, char, collate, divide, fixed, hbound, index, length,
        ltrim, max, min, null, reverse, rtrim, search, size, substr, unspec,
        verify)	   builtin;

    dcl (cleanup, comp_abort)
		   condition;

    dcl adjust_bit_count_
		   entry (char (168), char (32), bit (1), fixed,
		   fixed (35));
    dcl com_err_	   entry options (variable);
    dcl cu_$cp	   entry (ptr, fixed (35), fixed (35));
    dcl expand_pathname_
		   entry (char (*), char (*), char (*), fixed (35));
    dcl get_wdir_	   entry returns (char (168));
    dcl ioa_$rsnnl	   entry options (variable);
    dcl iox_$attach_name
		   entry (char (*), ptr, char (*), ptr, fixed (35));
    dcl iox_$detach_iocb
		   entry (ptr, fixed bin (35));
    dcl iox_$get_line  entry (ptr, ptr, fixed bin (35), fixed bin (35),
		   fixed bin (35));
    dcl iox_$open	   entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
    dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
    dcl pathname_	   entry (char (*), char (*)) returns (char (168));

    if shared.bug_mode
    then call ioa_ ("ctls: ^a", comp_util_$display (ltrim (ctl_line), 0, "0"b))
	    ;

    exit_str = "";			/* clear debug info string */
    ctls_ptr = addr (controls);	/* point to control array */
				/* current input file */
    call_box_ptr = call_stack.ptr (call_stack.index);

    callers_nest = shared.if_nest.ndx;	/* if nest level at entry */
    trim_flag, text_added = "0"b;	/* clear the text flag */
    again = "1"b;			/* set flag to process control line */

ctl_loop:
    do while (again);		/* as long as the flag stays up */
      again = "0"b;			/* reset process control line flag */

(nosubrg):			/* if we are indenting */
      if shared.indctl.stk (shared.indctl.ndx)
      then
(nostrg):
(nostrz):
        ctl_line = ltrim (ctl_line);

/* accept only .bel and .be in literal mode */
      if shared.literal_mode & shared.lit_count ^= 0
      then
        do;
	if ctl_line = ".bel"
	then
	  do;
	    call comp_block_ctls_ (bel_ctl_index);
	    goto end_ctl_loop;
	  end;

	else if ctl_line = ".be"
	then
	  do;
	    call comp_block_ctls_ (be_ctl_index);
	    goto end_ctl_loop;
	  end;

	else
	  do;
	    text_added = "1"b;
	    goto return_;
	  end;
        end;

/* ".*", ".~" = comment */
      if index (ctl_line, ".*") = 1 | index (ctl_line, ".~") = 1
      then goto end_ctl_loop;

/* ".." = short form of ".ifi" */
      if index (ctl_line, "..") = 1
      then
        do;
	ctl.index = 3;
	call comp_insert_ctls_ (ifi_ctl_index);
	goto end_ctl_loop;
        end;			/**/
				/* extract control token */
      ctl_token_len = index (ctl_line, " ") - 2;
      if ctl_token_len < 0		/* if no SP, take the whole thing */
      then ctl_token_len = length (ctl_line) - 1;

      if ctl_token_len > 32		/* cant be more than 32 chars */
      then goto unk_ctl;		/**/
				/* accept the control token */
(nostrg):
      ctl_token = substr (ctl_line, 2, ctl_token_len);
      ctl.index = ctl_token_len + 2;	/* and step over it */
				/* set start of variable field */
      if ctl.index < length (rtrim (ctl_line))
      then
(nostrg):
        ctl.index = ctl.index - 1 + verify (substr (ctl_line, ctl.index), " ");
      else ctl.index = length (ctl_line) + 1;
				/* look for the control */
      ctl_index = index (ctl_list, ctl_token);

      if ctl_index = 0		/* if no control was found */
      then
        do;
unk_ctl:
	text_added = "1"b;
	if shared.table_mode
	then if index ("0123456789", substr (ctl_token, 2, 1)) ^= 0
	     then goto return_;

	call comp_report_ (2, 0, "Unknown control request.", addr (ctl.info),
	     ltrim (ctl_line));
	goto end_ctl_loop;
        end;			/**/
				/* true index */
      ctl_index = divide (ctl_index + 63, 64, 17);

      goto ctl_ (ctl_index);		/* transfer to control processor */

/* TEXT ALIGNMENT CONTROLS */
ctl_ (1):				/* ".alb" = align-both */
ctl_ (2):				/* ".alc" = align-center */
ctl_ (3):				/* ".ali" = align-inside */
ctl_ (4):				/* ".all" = align-left */
ctl_ (5):				/* ".alo" = align-outside */
ctl_ (6):				/* ".alr" = align-right */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

/* BEGIN-BLOCK CONTROLS */
ctl_ (7):				/* ".bb" = begin-block OBSOELTE */
ctl_ (8):				/* ".bart" = begin-artwork */
ctl_ (9):				/* ".bba" = block-begin-art OBSOLETE */
ctl_ (10):			/* ".bblk" = begin-block */
      call comp_block_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (11):			/* ".bbc" = block-begin-column OBSOLETE */
      ctl_index = tac_ctl_index;
      goto tac_ctl;

ctl_ (12):			/* ".bbe" = block-begin-equation OBSOLETE */
ctl_ (13):			/* ".bbf" = block-begin-footnote OBSOLETE */
ctl_ (14):			/* ".bbi" = block-begin-inline OBSOLETE */
ctl_ (15):			/* ".bbk" = block-begin-keep OBSOLETE */
ctl_ (16):			/* ".bbl" = block-begin-literal OBSOLETE */
ctl_ (17):			/* ".bbn" = block-begin-named OBSOLETE */
ctl_ (18):			/* ".bbp" = block-begin-picture OBSOLETE */
ctl_ (19):			/* ".bbt" = block-begin-title OBSOLETE */
      call comp_block_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (20):			/* ".bcf" = begin-column-footer */
ctl_ (21):			/* ".bch" = begin-column-header */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* BLOCK-END CONTROLS */
ctl_ (22):			/* ".be" = block-end (be_ctl_index) */
ctl_ (23):			/* ".bea" = block-end-art */
      call comp_block_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (24):			/* ".bec" = block-end-column OBSOLETE */
      ctl_index = tac_ctl_index;
      goto tac_ctl;

ctl_ (25):			/* ".bee" = block-end-equation */
ctl_ (26):			/* ".bef" = block-end-footnote (bef_ctl_index) */
ctl_ (27):			/* ".bek" = block-end-keep */
ctl_ (28):			/* ".bel" = block-end-literal (bel_ctl_index) */
ctl_ (29):			/* ".ben" = block-end-named */
ctl_ (30):			/* ".bep" = block-end-picture (bep_ctl_index) */
ctl_ (31):			/* ".bet" = block-end-title */
      call comp_block_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (32):			/* ".bpf" = begin-page-footer */
ctl_ (33):			/* ".bph" = begin-page-header */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* BREAK CONTROLS */
ctl_ (34):			/* ".br" = break */
ctl_ (35):			/* ".brb" = break-block */
ctl_ (36):			/* ".brc" = break-column */
ctl_ (37):			/* ".brf" = break-format */
ctl_ (38):			/* ".brn" = break-need */
ctl_ (39):			/* ".brp" = break-page */
ctl_ (40):			/* ".brs" = break-skip */
      call comp_break_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (41):			/* ".brw" = break-word */
      if ctl.index = length (ctl_line)	/* take all single chars */
      then shared.wrd_brkr = substr (ctl_line, ctl.index, 1);

      else if ctl.index < length (ctl_line)
      then
        do;
	wrd_buffer = ltrim (substr (ctl_line, ctl.index), "ż");

	if index (wrd_buffer, "*") = 1/* is it escaped? */
	then
	  do;
	    call comp_util_$escape (wrd_buffer, addr (ctl.info));
	    wrd_buffer = ltrim (wrd_buffer, "ż");

	    if length (wrd_buffer) = 1
	    then shared.wrd_brkr = wrd_buffer;

	    else
	      do;
	        call comp_report_$ctlstr (2, comp_error_table_$syntax_error,
		   addr (ctl.info), ctl_line,
		   "Only a single character may be given.");
	        goto end_ctl_loop;
	      end;
	  end;

	else
	  do;
	    call comp_report_$ctlstr (2, comp_error_table_$syntax_error,
	         addr (ctl.info), ctl_line,
	         "Only a single character may be given.");
	    goto end_ctl_loop;
	  end;
        end;

      else shared.wrd_brkr = " ";	/* default is wordspace */

      if shared.bug_mode
      then call ioa_$rsnnl ("wrdbrkr=^a", exit_str, 0,
	      comp_util_$display ((shared.wrd_brkr), 0, "0"b));

      goto end_ctl_loop;

ctl_ (42):			/* ".btc" = begin-text-caption */
ctl_ (43):			/* ".btt" = begin-text-title */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* CHANGE-BAR CONTROLS */
ctl_ (44):			/* ".cba" = change-bar-addition */
      if ^option.cbar_opt		/* if change bars are not active */
      then goto end_ctl_loop;		/* forget it! */
				/* if a change level is given */
      if ctl.index <= length (ctl_line)
      then
        do;			/* less than level selected? */
	if substr (ctl_line, ctl.index, 1) < option.cbar.level
	then goto end_ctl_loop;
	page.hdr.pgc_select =
	     byte (
	     max (32, rank (page.hdr.pgc_select),
	     rank (substr (ctl_line, ctl.index, 1))));
        end;			/**/
				/* set shared flags */
      current_parms.cbar.add = "1"b;
      if shared.blkptr ^= null ()	/* and active flag */
      then text.parms.cbar.add, text.input.cbar.add = "1"b;
      shared.cbar_type = "add";
      goto end_ctl_loop;

ctl_ (45):			/* ".cbd" = change-bar-delete */
      if ^option.cbar_opt		/* if change bars are not active */
      then goto end_ctl_loop;		/* forget it! */
				/* if a change level is given */
      if ctl.index <= length (ctl_line)
      then
        do;			/* less than level selected? */
	if substr (ctl_line, ctl.index, 1) < option.cbar.level
	then goto end_ctl_loop;
	page.hdr.pgc_select =
	     byte (
	     max (32, rank (page.hdr.pgc_select),
	     rank (substr (ctl_line, ctl.index, 1))));
        end;			/**/
				/* set shared flags */
      current_parms.cbar.del = "1"b;
      if shared.blkptr ^= null ()	/* and active flags */
      then text.parms.cbar.del, text.input.cbar.del = "1"b;

      shared.cbar_type = "del";
      goto end_ctl_loop;

ctl_ (46):			/* ".cbf" = change-bars-off */
      if ^option.cbar_opt		/* if change bars are not active */
      then goto end_ctl_loop;		/* forget it! */

      if ctl.index <= length (ctl_line) /* if a change level is given */
      then if
/**** option.cbar.level = "" |	/* and all levels were selected */
				/* or its less than the active level */
	      substr (ctl_line, ctl.index, 1) < option.cbar.level
	 then goto end_ctl_loop;	/**/
				/* reset shared flags */
      current_parms.cbar.add, current_parms.cbar.mod = "0"b;
      if shared.blkptr ^= null ()	/* and the active flags */
      then text.parms.cbar.add, text.parms.cbar.mod = "0"b;

      shared.cbar_type = "";
      goto end_ctl_loop;

ctl_ (47):			/* ".cbm" = change-bars-modified */
ctl_ (48):			/* ".cbn" = change-bars-on */
      if ^option.cbar_opt		/* if change bars are not active */
      then goto end_ctl_loop;		/* forget it! */

      if ctl.index <= length (ctl_line) /* if a change level is given */
      then
        do;			/* less than the active level? */
	if substr (ctl_line, ctl.index, 1) < option.cbar.level
	then goto end_ctl_loop;

	page.hdr.pgc_select =
	     byte (
	     max (32, rank (page.hdr.pgc_select),
	     rank (substr (ctl_line, ctl.index, 1))));
        end;

      current_parms.cbar.mod = "1"b;	/* set shared flag */
      if shared.blkptr ^= null ()	/* set active flags */
      then text.parms.cbar.mod, text.input.cbar.mod = "1"b;

      if shared.table_mode		/* set table flag */
      then tbldata.ptr (tbldata.ndx) -> tblcol.parms.cbar.mod = "1"b;
      shared.cbar_type = "mod";

      goto end_ctl_loop;

ctl_ (49):			/* ".cfl" = column-footer-line */
ctl_ (50):			/* ".chl" = column-header-line */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (51):			/* ".csd" = change-symbol-delimiter */
      if ctl.index = 8
      then shared.sym_delim = "%";
      else shared.sym_delim = substr (ctl_line, ctl.index, 1);

      goto end_ctl_loop;

ctl_ (52):			/* ".ctd" = change-title-delimiter */
      if ctl.index > length (ctl_line)
      then shared.ttl_delim = "|";
      else shared.ttl_delim = substr (ctl_line, ctl.index, 1);
      goto end_ctl_loop;

ctl_ (53):			/* ".dfu" = defer-until */
      if ctl.index > length (ctl_line)
      then goto end_ctl_loop;		/* if nothing given */

      cond_name =
	 comp_read_$name (ctl_line, ctl.index, ctl.index, addr (ctl.info));

      do i = 1 to hbound (cond_names, 1) while (cond_name ^= cond_names (i));
      end;

      if i > hbound (cond_names, 1)
      then
        do;
	call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
	     "Unknown condition ^a", cond_name);
	goto end_ctl_loop;
        end;

      ctl_line = ltrim (after (ctl_line, cond_name));

      if shared.blkptr = null
      then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	      addr (current_parms), "0"b);

      ctl.linespace = 0;		/* no lead for special lines */
      call comp_util_$add_text (shared.blkptr, "0"b, "0"b, "0"b, "0"b,
	 addr (ctl));

      line_area_ptr = text.line_area.cur;
      txtlinptr = line_area.linptr (line_area.ndx);
      txtlin.blk_splt = "1"b;
      ctl.linespace = text.parms.linespace;

      goto end_ctl_loop;

ctl_ (54):			/* ".dmp" = dump - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (55):			/* ".do" = do - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (56):			/* ".dvc" = device-command - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (57):			/* ".eart" = end-artwork - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (58):			/* ".ecf" = end-column-footer */
ctl_ (59):			/* ".ech" = end-column-header */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (60):			/* ".else" = conditional-else */
      if shared.if_nest.ndx = 0	/* if no active nest */
      then
        do;
	call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	     addr (ctl.info), ctl_line,
	     "Not in an active conditional execution group.");
	goto end_ctl_loop;
        end;

      found_clause = "1"b;		/**/
				/* execute the else? */
      if shared.if_nest (shared.if_nest.ndx).sw = ELSE
      then
        do;
	if shared.indctl.stk (shared.indctl.ndx)
	then ctl_line = ltrim (after (ctl_line, ".else "));
	else ctl_line = after (ctl_line, ".else ");

	if index (ctl_line, ".") = 1
	then again = "1"b;
	else if ctl_line ^= ""
	then text_added = "1"b;
        end;

      else			/* no - search for if/endif */
        do;			/* until found or end_input */
	this_nest = shared.if_nest.ndx;

	ctl_line = after (ctl_line, "else ");
	goto check_if;

	do while (^shared.end_input); /* read next line */
	  call comp_read_$line (call_box_ptr, ctl_line, "1"b);
	  ctl.info = call_box.info;

check_if:
	  if index (ltrim (ctl_line), ".if ") = 1
	  then
	    do;
	      shared.if_nest.ndx = shared.if_nest.ndx + 1;
	      shared.if_nest (shared.if_nest.ndx).info = ctl.info;
	      shared.if_nest (shared.if_nest.ndx).line = ctl_line;
	      shared.if_nest (shared.if_nest.ndx).sw = 0;

/*	      again = "1"b; 
/*
/*	      if shared.bug_mode
/*	      then call
/*		   ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
/*		   ctl.lineno, ctl_line);
/*
/*	      call comp_ctls_ ("0"b); */
	    end;

	  else if index (ltrim (ctl_line), ".endif") = 1
	  then
	    do;
	      if shared.bug_mode
	      then call ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
		      ctl.lineno, ctl_line);

	      if shared.if_nest.ndx > this_nest
	      then shared.if_nest.ndx = shared.if_nest.ndx - 1;

	      else
	        do;
		again = "1"b;	/* set the control flag */
		goto end_ctl_loop;
	        end;
	    end;
	end;
        end;
      goto end_ctl_loop;

ctl_ (61):			/* ".elseif" - conditional-elseif */
      if shared.if_nest.ndx = 0	/* if no active nest */
      then
        do;
	call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	     addr (ctl.info), ctl_line,
	     "Not in an active conditional execution group.");
	goto end_ctl_loop;
        end;			/**/
				/* execute the else? */
      if shared.if_nest (shared.if_nest.ndx).sw = ELSE
      then
        do;			/* fool the nest counter */
	shared.if_nest.ndx = shared.if_nest.ndx - 1;
	goto if_ctl;
        end;			/**/
				/* search for elseif, else, or endif */
      else			/* until found or end_input */
        do while (^shared.end_input);	/* read next line */
	call comp_read_$line (call_box_ptr, ctl_line, "1"b);
	ctl.info = call_box.info;	/**/
				/* if a nested .if */
	if index (ltrim (ctl_line), ".if ") = 1
	then
	  do;			/* count the nest */
	    shared.if_nest.ndx = shared.if_nest.ndx + 1;

/*	    shared.if_nest (shared.if_nest.ndx).info = ctl.info;
/*	    shared.if_nest (shared.if_nest.ndx).line = ctl_line;
/*	    shared.if_nest (shared.if_nest.ndx).sw = 0; */

	    if shared.bug_mode
	    then call ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
		    ctl.lineno, ctl_line);
	  end;

	else if index (ltrim (ctl_line), ".else") = 1
	then
	  do;
	    if shared.bug_mode
	    then call ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
		    ctl.lineno, ctl_line);

	    again = "1"b;		/* set the control flag */
	    goto end_ctl_loop;
	  end;

	if index (ltrim (ctl_line), ".endif") = 1
	then goto endif_ctl;

        end;
      goto end_ctl_loop;

ctl_ (62):			/* ".enddo" = end-do */
      goto end_ctl_loop;

ctl_ (63):			/* ".endif" = conditional-end */
endif_ctl:
      if shared.if_nest.ndx = 0	/* if no active nest */
      then
        do;
	call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	     addr (ctl.info), ctl_line,
	     "Not in an active conditional execution group.");
	goto end_ctl_loop;
        end;

      if ^found_clause		/* if no clause found */
      then call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	      addr (ctl.info), ctl_line,
	      "No executable clause for a conditional execution group.");

      shared.if_nest.ndx = shared.if_nest.ndx - 1;

      if shared.bug_mode
      then
        do;
	call ioa_$rsnnl ("ifnest=^d", exit_str, 0, shared.if_nest.ndx);
	if shared.if_nest.ndx > 0
	then call ioa_$rsnnl ("^a if_sw=^d", exit_str, 0, exit_str,
		shared.if_nest (shared.if_nest.ndx).sw);
        end;

      goto end_ctl_loop;

ctl_ (64):			/* ".epf" = end-page-footer */
ctl_ (65):			/* ".eph" = end-page-header */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (66):			/* ".eqc" = equation-count */
      if ctl.index > length (ctl_line)	/* if no value, then step counter */
      then shared.eqn_refct = shared.eqn_refct + 1;
      else shared.eqn_refct =
	      comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	      addr (ctl.info), 0);
      goto end_ctl_loop;

ctl_ (67):			/* ".err" = error */
      call comp_report_$exact (substr (ctl_line, ctl.index), addr (ctl.info));
      goto end_ctl_loop;

ctl_ (68):			/* ".etc" = end-text-caption */
ctl_ (69):			/* ".ett" = end-text-title */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (70):			/* ".exc" = execute-command */
      if ctl.index <= length (ctl_line)
      then
        do;
	command_line = substr (ctl_line, ctl.index);
	call cu_$cp (addr (command_line), length (ctl_line) - ctl.index + 1,
	     ercd);
        end;
      goto end_ctl_loop;

/* FOOTER-BLOCK CONTROLS */
ctl_ (71):			/* ".fb" = footer-block */
ctl_ (72):			/* ".fbb" = footer-block-begin */
ctl_ (73):			/* ".fbe" = footer-block-end */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* FILL MODE CONTROLS */
ctl_ (74):			/* ".fi" = fill DEFAULT */
ctl_ (75):			/* ".fif" = fill-off */
ctl_ (76):			/* ".fin" = fill-on (fin_ctl_index) */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

/* FOOTER-LINE CONTROLS */
ctl_ (77):			/* ".fl" = footer-line */
ctl_ (78):			/* ".fla" = footer-line-all */
ctl_ (79):			/* ".fle" = footer-line-even */
ctl_ (80):			/* ".flo" = footer-line-odd */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (81):			/* ".fnt" = font */
      if substr (ctl_line, ctl.index) = "-rs"
	 | substr (ctl_line, ctl.index) = "-reset"
      then
        do;
	call comp_font_ ("1"b, "", "");
	ctl_line = "";
        end;

      else
        do;
	call comp_font_ ("0"b, substr (ctl_line, ctl.index), fcs_str);
	ctl_line = fcs_str;
        end;			/**/
				/* if changing in mid-stream */
      if shared.blkptr ^= null ()
      then if ctl_line ^= "" & text.input_line ^= ""
	 then text_added, ctl.fnt_chng = "1"b;
	 else ctl.font = text.parms.fntstk.entry (text.parms.fntstk.index);
      else ctl.font = current_parms.fntstk.entry (current_parms.fntstk.index);

      ctl.cur.font = current_parms.fntstk.entry (current_parms.fntstk.index);

      goto end_ctl_loop;

ctl_ (82):			/* ".frf" = footnote-reference */
				/* which note? */
      if ctl.index <= length (ctl_line)
      then i = comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	      addr (ctl.info), 0);
      else i = 1;

      if shared.ftnrefct - i <= 0
      then
        do;
	call comp_report_ (2, 0, "Referenced footnote does not exist.",
	     addr (ctl.info), ltrim (ctl_line));
	goto end_ctl_loop;
        end;

      footref_array (2) = ltrim (char (shared.ftnrefct - i));
      call comp_dvt.footproc (footref_array, addr (comp_dvt));

      footrefstr = footref_array (1) || footref_array (2) || footref_array (3);

      if text.parms.fill_mode		/* insert reference into filled text */
      then
        do;
	ctl_line = "";
	call append_footref (addr (ctl));

	call comp_fill_;		/* to be sure it fits */
	if shared.ftn_reset ^= "hold"
	then
	  do;
	    text.input.ftn.ct = text.input.ftn.ct + 1;
	    text.input.ftn.refno (text.input.ftn.ct) = shared.ftnrefct - i;
	  end;
        end;

      else			/* append reference to end of */
        do;			/* last unfilled output line */
	line_area_ptr = text.line_area.cur;
	txtlinptr = line_area.linptr (line_area.ndx);

/*	if shared.table_mode	/* back up to last */
/*	then			/* line for this table column */
/*	  do;
/*	    tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
/*	    do j = text.hdr.count to 1 by -1
/*	         while (text.linptr (j) -> txtlin.tblcol ^= tblfmt.ccol);
/*	    end;
/*	  end;*/

	call append_footref (txtlinptr);
	call comp_util_$replace_text (shared.blkptr, "0"b, txtlinptr,
	     addr (ctl_line));	/**/
				/* if notes arent held */
	if shared.ftn_reset ^= "hold"
	then
	  do;
	    txtlin.ftn.ct = txtlin.ftn.ct + 1;
	    txtlin.ftn.refno (txtlin.ftn.ct) = shared.ftnrefct - i;
	  end;
	text.hdr.ftn.ct = text.hdr.ftn.ct + 1;
	col.hdr.ftn.ct = col.hdr.ftn.ct + 1;
        end;

append_footref:			/* append footref string onto text */
  proc (reflineptr);

    dcl reflineptr	   ptr;		/* line to be appended */
    dcl 1 refline	   aligned like text_entry based (reflineptr);

    txtstrptr = refline.ptr;

    if refline.sws.footref		/* does line already have a footref? */
    then
      do;
        ctl_line =			/* trim FCS and suffix */
	   substr (txtstr, 1,
	   length (txtstr) - 8 - length (footref_array (3)));
        ctl_line =			/* add sep, ref, suffix, and FCS */
	   ctl_line || refline.cur.font.fntptr -> font.footsep
	   || footref_array (2) || footref_array (3)
	   || refline.cur.font.fcs_str;
      end;

    else				/* no, add the whole ref string */
      do;				/* be sure footref is in right font */
        footrefstr =
	   footnote_parms.fntstk.entry (footnote_parms.fntstk.index).fcs_str
	   || footrefstr;
        ctl_line = txtstr || footrefstr || refline.cur.font.fcs_str;
      end;

    refline.sws.footref = "1"b;	/* set footref flag */

  end append_footref;

      goto end_ctl_loop;

ctl_ (83):			/* ".fth" = footnote-hold */
      shared.suppress_footref = "0"b;
      shared.ftn_reset = "hold";
      goto end_ctl_loop;

ctl_ (84):			/* ".ftp" = footnote-paged */
      shared.suppress_footref = "0"b;
      shared.ftn_reset = "paged";
      goto end_ctl_loop;

ctl_ (85):			/* ".ftr" = footnote-running */
      shared.suppress_footref = "0"b;
      shared.ftn_reset = "running";
      goto end_ctl_loop;

ctl_ (86):			/* ".ftu" = footnote-unreferenced */
      shared.suppress_footref = "1"b;	/* set footnote ref suppress flag */
      goto end_ctl_loop;

ctl_ (87):			/* ".galley" = galley-mode */
ctl_ (88):			/* ".gl" = galley-mode */
      if ctl.fileno + ctl.lineno ^= 1
      then call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
	      "galley control must be first, it will be ignored.");

      else option.galley_opt = "1"b;

      goto end_ctl_loop;

ctl_ (89):			/* ".go" = goto */
      if ctl.index > length (ctl_line)
      then
        do;
	call comp_report_ (2, 0, "No target label given.", addr (ctl.info),
	     ltrim (ctl_line));
	goto end_ctl_loop;
        end;

      search_label = substr (ctl_line, ctl.index);

      if insert.label.count > 0	/* see if we've been here already */
      then
        do;
	i = index (
	     substr (addr (insert.label.value (1)) -> label_value_str, 1,
	     32 * insert.label.count), search_label);

	if i > 0
	then
	  do;
	    i = divide (i, 32, 17) + 1;
	    call_box.lineno = insert.label.line (i);
	    call_box.posn = insert.label.position (i);
	    if shared.bug_mode
	    then call ioa_ ("^5x(label: line=^d ^d ^a)", ctl.info.fileno,
		    call_box.lineno, rtrim (search_label));
	    goto end_ctl_loop;
	  end;
        end;

      save_line = ctl_line;		/* save ctl line stuff */
      save_info = ctl.info;
      save_posn = insert.posn;	/* save .go position */
      end_flag = "0"b;		/* clear static flag */

      do while (^shared.end_input);	/* until found or end_input */
				/* read next line */
        call comp_read_$line (call_box_ptr, ctl_line, "1"b);
        ctl.info = call_box.info;

        if ^shared.end_input
        then
	do;			/**/
				/* a label control? */
	  if index (ltrim (ctl_line), ".la") = 1
	  then
	    do;			/* preset scan index to 1st nonblank */
	      ctl.index = verify (ctl_line, " ");
				/* set scan index */
	      if length (ctl_line) > ctl.index + 3
	      then ctl.index =
		      ctl.index
		      + index (substr (ctl_line, ctl.index), " ");
	      else ctl.index = length (ctl_line) + 1;

	      call set_label;	/* record the label value */
	      if insert.label.value (insert.label.count) = search_label
	      then
	        do;		/* if it matches */
		if shared.bug_mode
		then call ioa_ ("^5x(label: line=^d ^d ^a)",
			ctl.info.fileno, ctl.info.lineno,
			rtrim (search_label));
		goto end_ctl_loop;
	        end;
	    end;

	  if index (ltrim (ctl_line), ".endif") = 1
	  then shared.if_nest.ndx =
		  max (shared.if_nest.ndx - 1, callers_nest);
	end;

        else
	do;			/* no such label */
	  call comp_report_ (2, 0,
	       "Label not defined. """ || before (search_label, " ") || """",
	       addr (save_info), ltrim (save_line));
	  insert.posn = save_posn;	/* restore .go control position */
	  goto end_ctl_loop;
	end;
      end;

/* HEADER-BLOCK CONTROLS */
ctl_ (90):			/* ".hb" = header-block */
ctl_ (91):			/* ".hbb" = header-block-begin */
ctl_ (92):			/* ".hbe" = header-block-end */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (93):			/* ".hif" = hit-file - NOT COMPLETE */
				/* LOCAL STORAGE */
      dcl 1 hit_data     aligned based (shared.hit_data_ptr),
	  2 file_name  (0:9) char (32) var,
				/* entryname of data file */
	  2 iocb_ptr   (0:9) ptr,	/* iocb pointer */
	  2 last_caller
		     (0:9) char (32) var;
				/* last caller for each */

      if ^option.nohit_opt & shared.hit_data_ptr = null ()
      then
        do;
	shared.hit_data_ptr =
	     allocate (const.local_area_ptr, size (hit_data));
	hit_data.file_name (*) = "";
	hit_data.iocb_ptr (*) = null ();
	hit_data.last_caller (*) = "";
        end;
      goto end_ctl_loop;

ctl_ (94):			/* ".hit" = hit */
				/* if no data */
      if ctl.index > length (ctl_line)
      then goto end_ctl_loop;

      if ^option.nohit_opt
      then
        do;
	endchar = ";";
	hitcharndx = 0;

	if shared.hit_data_ptr = null ()
	then			/* need the hit file data? */
	  do;
	    shared.hit_data_ptr =
	         allocate (const.local_area_ptr, size (hit_data));
	    hit_data.file_name (*) = "";
	    hit_data.iocb_ptr (*) = null ();
	    hit_data.last_caller (*) = "";
	  end;			/**/
				/* check for a hit file index */
	if index ("0123456789", substr (ctl_line, ctl.index, 1)) ^= 0
	then hitfilendx =
		comp_read_$number (ctl_line, unscaled, ctl.index,
		ctl.index, addr (ctl.info), 0);
	else hitfilendx = 0;	/**/
				/* construct hit file name */
	if hit_data.file_name (hitfilendx) = ""
	then call ioa_$rsnnl ("^a.^d.cndx", hit_data.file_name (hitfilendx),
		0, before (call_box0.entryname, ".compin"), hitfilendx);
				/* attach/open hit file, write_page_ */
				/* will write the data, but we have */
				/* to give him the iocb ptr and */
				/* attach the file */
	call aux_file (hit_data.file_name (hitfilendx), 1, ercd);
	if ercd ^= 0
	then goto end_ctl_loop;

	hit_data.iocb_ptr (hitfilendx) =
	     aux_file_data.entry (aux_file_index).iocb_ptr;
				/* set up hit line */
	hit_line = text_entry;
	hit_line.info = ctl.info;
	hit_line.font = ctl.font;
	hit_line.ptr = addr (hit_text);
	hit_line.linespace = 0;
	hit_line.spcl.file = "1"b;
	hit_line.spcl_iocbp = hit_data.iocb_ptr (hitfilendx);
	hit_line.default = "1"b;	/* default means hit line */

	if ^page.hdr.headed		/* head page if needed */
	then call comp_head_page_ (head_used);
				/* need a text block? */
	if shared.blkptr = null ()
	then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
		addr (current_parms), "0"b);

	if shared.input_filename ^= hit_data.last_caller (hitfilendx)
	then
	  do;
	    hit_text = shared.input_filename || NL;
	    call comp_util_$add_text (shared.blkptr, "0"b, "0"b, "0"b, oflo,
	         addr (hit_line));
	    hit_data.last_caller (hitfilendx) = shared.input_filename;

	    if oflo & ^text.parms.keep & text.hdr.colno >= 0
	    then call comp_break_ (need_break, -2);
	  end;			/**/
				/* check for delimiter change */
	if substr (ctl_line, ctl.index, 1) = "="
	then
	  do;
	    hitcharndx = 4;
	    endchar = substr (ctl_line, ctl.index + 3, 1);
	  end;

	call ioa_$rsnnl ("^d^-.~ HIT ^a^a", hit_text, 0, ctl.lineno,
	     substr (ctl_line, ctl.index), endchar);

	hittypechar = substr (ctl_line, ctl.index + hitcharndx, 1);
	hittypendx =
	     index (hittypecodes,
	     translate (hittypechar, "ULIANSK", "uliansk"));
	goto hittype (hittypendx);

hittype (0):
	call comp_report_$ctlstr (2, comp_error_table_$unknown_keyword,
	     addr (ctl.info), ctl_line, "The hit type key ^a is unknown.",
	     hittypechar);
hittype (1):			/* U = UPPER case permute */
hittype (2):			/* L = lower case permute */
hittype (3):			/* I = initial cap permute */
hittype (4):			/* A = as-is permute */
hittype (5):			/* N = no-reference, explicitly omitted reference */
hittype (6):			/* S = "see" reference */
hittype (7):			/* * = like K with flagged reference */
hittype (8):			/* K = keys supplied */
	call comp_util_$add_text (shared.blkptr, "0"b, "0"b, "0"b, oflo,
	     addr (hit_line));

	if oflo & ^text.parms.keep & text.hdr.colno >= 0
	then call comp_break_ (need_break, -2);
        end;

      goto end_ctl_loop;

/* HEADER-LINE CONTROLS */
ctl_ (95):			/* ".hl" = header-line */
ctl_ (96):			/* ".hla" = header-line-all */
ctl_ (97):			/* ".hle" = header-line-even */
ctl_ (98):			/* ".hlf" = header-line-footnote */
ctl_ (99):			/* ".hlo" = header-line-odd */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (100):			/* ".hrul" - horizontal-rule */
      goto end_ctl_loop;

/* HORIZONTAL TAB CONTROLS */
ctl_ (101):			/* ".htd" = htab-define */
ctl_ (102):			/* ".htf" = htab-off */
ctl_ (103):			/* ".htn" = htab-on */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (104):			/* ".hy" = default hyphenation mode */
      shared.hyph_mode = option.hyph_opt;
      shared.hyph_size = option.hyph_size;
      goto end_ctl_loop;

ctl_ (105):			/* ".hyf" = hyphenate-off */
      shared.hyph_mode = "0"b;
      goto end_ctl_loop;

ctl_ (106):			/* ".hyn" = hyphenate-on */
      shared.hyph_mode = "1"b;
      call comp_util_$set_bin (shared.hyph_size, "hyphenation size",
	 option.hyph_size, 0, -1, unscaled, 1);
      goto end_ctl_loop;

ctl_ (107):			/* ".hyw" = hyphenate-word  */
      dcl hwrd	     char (256) var;/* need the hwrd data? */
      if shared.hwrd_data_ptr = null
      then
        do;
	shared.hwrd_data_ptr =
	     allocate (const.local_area_ptr, size (hwrd_data));
	hwrd_data.count = 0;
	hwrd_data.word (1) = "";
        end;			/**/
				/* delete all words? */
      if ctl.index > length (ctl_line)
      then
        do;
	hwrd_data.count = 0;
	goto end_ctl_loop;
        end;

      do while (ctl.index <= length (ctl_line));
        hwrd = before (substr (ctl_line, ctl.index), " ");
        j = verify (substr (ctl_line, ctl.index + length (hwrd)), " ");
        if j > 0
        then ctl.index = ctl.index + length (hwrd) - 1 + j;
        else ctl.index = length (ctl_line) + 1;

        if hwrd ^= ""
        then call process_hwrd;
      end;

      goto end_ctl_loop;

/* INSERTION CONTROLS */
ctl_ (108):			/* ".ibl" = insert-block */
      goto end_ctl_loop;

ctl_ (109):			/* ".if" = conditional-if *** */
if_ctl:				/* if_ctl_index */
      found_clause = "0"b;		/**/
				/* advance the nest */
      shared.if_nest.ndx = shared.if_nest.ndx + 1;

      if ctl.index > length (ctl_line)	/* if no varfld, assume true */
      then shared.if_nest (shared.if_nest.ndx).sw = THEN;

      else			/* process the varfld */
        do;
	do while (index (ctl_line, shared.sym_delim) ^= 0);
	  call comp_use_ref_ (ctl_line, current_parms.art, "0"b,
	       addr (ctl.info));
	end;			/**/
				/* <expr> must be logical */
	call comp_expr_eval_ (ctl_line, ctl.index, addr (ctl.info), LOG, 0,
	     slog, 0, "", ""b, ercd);

	if ercd ^= 0		/* true if there was an error */
	then shared.if_nest (shared.if_nest.ndx).sw = THEN;

	else if slog		/* THEN if TRUE, otherwise ELSE */
	then shared.if_nest (shared.if_nest.ndx).sw = THEN;
	else shared.if_nest (shared.if_nest.ndx).sw = ELSE;
        end;

      if shared.bug_mode
      then call ioa_$rsnnl ("ifnest=^d if_sw=^[ELSE^;OFF^;THEN^]", exit_str, 0,
	      shared.if_nest.ndx, shared.if_nest (shared.if_nest.ndx).sw + 2)
	      ;

      goto end_ctl_loop;

/* INSERTION CONTROLS (CONT) */
ctl_ (110):			/* ".ifi" = insert-file */
				/* ifi_ctl_index */
      call comp_insert_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (111):			/* ".ift" = insert-footnotes */
				/* ift_ctl_index */
      if shared.ftn_reset ^= "hold"	/* not holding notes? */
      then goto end_ctl_loop;		/* forget it */

      if shared.blkptr ^= null ()	/* clean up current block */
      then call comp_break_ (block_break, 0);

      if ^page.hdr.headed		/* head page if needed */
      then call comp_head_page_ (head_used);
				/* hang notes on last block */
      shared.colptr = page.column_ptr (page.hdr.col_count);
      shared.blkptr = col.blkptr (col.hdr.blkct);
      line_area_ptr = text.line_area.cur;
      txtlinptr = line_area.linptr (line_area.ndx);

      ctl.default = "1"b;		/* use this switch to force notes */
				/* pick up all remaining notes */
      do ftndx = 1 to ftnblk_data.highndx;
        ftnblkptr = ftnblk_data.blkptr (ftndx);

        if ftnblkptr ^= null
        then
	do;			/* mark note as unreffed */
	  ftnblk.hdr.unref = "1"b;
	  ftnblk.hdr.refer = 0;
	  col0.hdr.ftn.ct = col0.hdr.ftn.ct + 1;
				/* if first footnote, */
	  if col0.hdr.ftn.ct = 1	/* count space for the header */
	  then col0.hdr.ftn.usd = ftnhdr.hdr.used + 12000;
	  col0.hdr.ftn.usd =	/* extra space for separator */
	       col0.hdr.ftn.usd + ftnblk.hdr.used + 12000;
	  col0.hdr.ftn.blkndx (col0.hdr.ftn.ct) = ftndx;
				/* count it in the page header */
	  text.hdr.ftn.ct = text.hdr.ftn.ct + 1;
	  text.hdr.ftn.usd = text.hdr.ftn.usd + ftnblk.hdr.used + 12000;
	  text.hdr.ftn.blkndx (text.hdr.ftn.ct) = ftndx;
				/* and in the first line */
	  txtlin.ftn.ct = txtlin.ftn.ct + 1;
	  txtlin.ftn.used = txtlin.ftn.used + ftnblk.hdr.used + 12000;
	end;
      end;

      call comp_break_ (page_break, 0);

      if shared.end_output
      then goto end_ctl_loop;

      ctl.default = "0"b;		/* reset the switch */
      goto end_ctl_loop;

ctl_ (112):			/* ".igr" = insert-graphic */
      call comp_insert_ctls_ (ctl_index);
      goto end_ctl_loop;

/* INDENTATION CONTROLS */
ctl_ (113):			/* ".in"  = insert-left */
ctl_ (114):			/* ".inb" = indent-both */
ctl_ (115):			/* ".inl" = indent-left */
ctl_ (116):			/* ".inr" = indent-right */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (117):			/* ".indctl" = indent-controls */
      if ctl.index <= length (ctl_line)
      then
        do;
	if shared.indctl.ndx = 35
	then i, shared.indctl.ndx = 0;
	else i, shared.indctl.ndx = shared.indctl.ndx + 1;

	if substr (ctl_line, ctl.index) = "on"
	then shared.indctl.stk (i) = "1"b;
	else shared.indctl.stk (i) = "0"b;
        end;

      else shared.indctl.ndx = shared.indctl.ndx - 1;
      if shared.indctl.ndx < 0
      then shared.indctl.ndx = 35;

      goto end_ctl_loop;

ctl_ (118):			/* ".indx" = insert_index */
      call comp_insert_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (119):			/* ".la" = line label */
      call set_label;
      goto end_ctl_loop;

ctl_ (120):			/* ".ls" = line-space */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

/* PAGE DEFINITION CONTROLS */
ctl_ (121):			/* ".pd"  = page-define-all */
ctl_ (122):			/* ".pdc" = page-define-column */
ctl_ (123):			/* ".pdl" = page-define-length */
ctl_ (124):			/* ".pdw" = page-define-width */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (125):			/* ".pfl" = page-footer-line */
ctl_ (126):			/* ".phl" = page-header-line */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (127):			/* ".pml" = page-margin-left */
      if ctl.index > length (ctl_line)
      then
        do;
	call comp_util_$set_bin (page_parms.lmarg.odd,
	     "page left margin odd", 0, 0, page_parms.measure, hscales,
	     comp_dvt.min_WS);
	call comp_util_$set_bin (page_parms.lmarg.even,
	     "page left margin even", 0, 0, page_parms.measure, hscales,
	     comp_dvt.min_WS);
        end;

      else
        do;
	if index (substr (ctl_line, ctl.index), ",") ^= 1
	then call comp_util_$set_bin (page_parms.lmarg.odd,
		"page left margin odd",
		comp_read_$number (ctl_line, hscales, ctl.index, ctl.index,
		addr (ctl.info), 0), 0, page_parms.measure, hscales,
		comp_dvt.min_WS);

	if index (substr (ctl_line, ctl.index), ",") = 1
	then ctl.index = ctl.index + 1;

	if ctl.index <= length (ctl_line)
	then call comp_util_$set_bin (page_parms.lmarg.even,
		"page left margin even",
		comp_read_$number (ctl_line, hscales, ctl.index, ctl.index,
		addr (ctl.info), 0), 0, page_parms.measure, hscales,
		comp_dvt.min_WS);
        end;
      goto end_ctl_loop;

ctl_ (128):			/* OBSOLETE */
ctl_ (129):			/* ".rac" = runaround-centered */
      goto end_ctl_loop;		/* NOT DOCUMENTED OR IMPLEMENTED */

ctl_ (130):			/* ".ral" = runaround-left */
      goto end_ctl_loop;		/* NOT DOCUMENTED OR IMPLEMENTED */

ctl_ (131):			/* ".rar" = runaround-right */
      goto end_ctl_loop;		/* NOT DOCUMENTED OR IMPLEMENTED */

ctl_ (132):			/* ".rd" = read from terminal */
      call iox_$get_line (iox_$user_input, addr (ty_buf), 200, rdct, ercd);

      if ercd ^= 0
      then
        do;
	call comp_report_ (4, ercd, "Attempting .rd control",
	     addr (ctl.info), ctl_line);
	signal comp_abort;
        end;

      ctl_line = substr (ty_buf, 1, rdct - 1);

      if length (ctl_line) = 0	/* treat as .spb */
      then
        do;
	ctl.index = 1;
	goto spb_ctl;
        end;

      if substr (ctl_line, 1, 1) = "."
      then again = "1"b;		/* set reprocess input line flag */
      else text_added = "1"b;		/* or text flag */
      goto end_ctl_loop;

ctl_ (133):			/* ".rt" = return */
      ctl_line = "";
      shared.end_input = "1"b;
      return;

ctl_ (134):			/* ".sp"  = space */
ctl_ (135):			/* ".spb" = space-break */
spb_ctl:
      if shared.blkptr ^= null	/* if there is an active block */
      then
        do;
	if text.input_line ^= ""	/* clean up leftovers */
	then call comp_break_ (format_break, 0);
				/* insert pending header */
/****	if text.parms.hdrptr ^= null () & ^shared.inserting_hfc
/****	then call comp_title_block_ (text.parms.hdrptr);*/
				/* insert pending caption */
	if text.parms.ftrptr ^= null () & ^shared.inserting_hfc
	then call comp_title_block_ (text.parms.ftrptr);

	if ^(text.parms.keep	/* if not... a keep */
	     | text.parms.art	/* or art */
	     | text.parms.title_mode	/* or a <title> */
	     | text.hdr.picture	/* or a picture */
	     | shared.ftn_mode	/* or a footnote */
	     | shared.table_mode)	/* or table mode */
	then			/* then a block break */
	     break_type = block_break;/**/
				/* otherwise, a format break */
	else break_type = format_break;
        end;

      else break_type = block_break;	/* otherwise, a block break */

      goto join_sp;

ctl_ (136):			/* ".spd" = space-to-depth */
      break_type = block_break;
      head_used = 0;

      if shared.blkptr ^= null	/* space in a loose block? */
      then if text.hdr.colno < 0
	 then break_type = format_break;
	 else ;

      else if ^option.galley_opt	/* head the page? */
      then if ^page.hdr.headed
	 then call comp_head_page_ (head_used);
	 else head_used = col0.blkptr (1) -> text.hdr.used;

      trim_flag = "1"b;		/* space is not trimable */

      if ctl.index > length (ctl_line)	/* default is +1 */
      then
        do;
	call comp_space_ (12000, shared.blkptr, "1"b, "1"b, "1"b, "0"b);
	call comp_break_ (break_type, -1);
        end;			/**/
				/* cant back up */
      else if index (substr (ctl_line, ctl.index), "-") = 1
      then
        do;
	call comp_report_ (2, 0, "Negative page depth increment.",
	     addr (ctl.info), ctl_line);
	goto end_ctl_loop;
        end;			/**/
				/* addon value? */
      else if index (substr (ctl_line, ctl.index), "+") = 1
      then goto join_sp_1;

      else
        do;
	blnkct =
	     -page.parms.init_page_depth - 12000 - head_used
	     +
	     comp_read_$number (ctl_line, vscales, ctl.index, ctl.index,
	     addr (ctl.info), 0);

	if shared.blkptr ^= null ()
	then if shared.blkptr = shared.ophdrptr
		| shared.blkptr = shared.ephdrptr
		| shared.blkptr = shared.blank_header_ptr
	     then blnkct = blnkct - text.hdr.used - page.parms.margin.top;
	     else blnkct = blnkct - max (col0.hdr.used, page.hdr.used);
	else blnkct = blnkct - max (col0.hdr.used, page.hdr.used);

	if blnkct = 0		/* if we're already there */
	then goto end_ctl_loop;

	if blnkct < 0		/* cant back up */
	then
	  do;
	    call comp_report_ (2, 0, "Given depth less than current depth.",
	         addr (ctl.info), ctl_line);
	    goto end_ctl_loop;
	  end;

	goto join_sp_2;		/* go do it */
        end;

      goto end_ctl_loop;

ctl_ (137):			/* ".spf" = space-format */
      break_type = format_break;	/* otherwise, format break */

join_sp:
      if shared.blkptr ^= null ()	/* if there is a block */
      then
        do;
	if text.input_line ^= ""	/* clean up leftovers */
	then call comp_break_ (format_break, 0);
	trim_flag = text.hdr.picture | trim_flag;
        end;
      else trim_flag = "0"b;		/* set trim flag */
      trim_flag = current_parms.cbar.del | trim_flag;

      if ctl.index > length (ctl_line)
      then blnkct = 12000;		/* default is one */
      else
join_sp_1:
        blnkct =
	   comp_read_$number (ctl_line, vscales, ctl.index, ctl.index,
	   addr (ctl.info), 0);

join_sp_2:
      if blnkct ^= 0		/* put in any needed space */
      then
        do;
	call comp_space_ (blnkct, shared.blkptr, "1"b, trim_flag, "1"b, "0"b)
	     ;
	if break_type = block_break
	then
	  do;
	    if text.input.oflo
	    then call comp_break_ (need_break, -2);
	    call comp_break_ (block_break, 0);
	  end;
        end;

      goto end_ctl_loop;

ctl_ (138):			/* ".spt" = space-total */
				/* head the page? */
      if ^(option.galley_opt | page.hdr.headed)
      then call comp_head_page_ (0);

      trim_flag = "0"b;		/* space is trimable */

      if ctl.index <= length (ctl_line)
      then if substr (ctl_line, ctl.index, 1) = "-"
	 then			/* cant back up */
	   do;
	     call comp_report_ (2, 0, "Negative total space not allowed.",
		addr (ctl.info), ctl_line);
	     goto end_ctl_loop;
	   end;

      if shared.blkptr ^= null
      then if text.input_line ^= ""
	 then call comp_break_ (format_break, 0);
/****	 else			/* insert pending header */
/****	      if text.parms.hdrptr ^= null () & ^shared.inserting_hfc
/****	 then call comp_title_block_ (text.parms.hdrptr);*/
				/* additional space needed */
      if ctl.index > length (ctl_line)	/* default is 1 */
      then blnkct = 12000;

      else blnkct =
	      comp_read_$number (ctl_line, vscales, ctl.index, ctl.index,
	      addr (ctl.info), 0);

      if shared.blkptr ^= null
      then
        do;
	if text.parms.hdrptr ^= null
	then
	  do;
	    if shared.bug_mode
	    then call ioa_ ("^5x(need=^f have=^f)", show (blnkct, 12000),
		    show (text.parms.hdrptr -> text.hdr.trl_ws, 12000));

	    blnkct = blnkct - text.parms.hdrptr -> text.hdr.trl_ws;
	  end;

	else
	  do;
	    if shared.bug_mode
	    then call ioa_ ("^5x(need=^f have=^f)", show (blnkct, 12000),
		    show (text.hdr.trl_ws, 12000));

	    blnkct = blnkct - text.hdr.trl_ws;
	  end;
        end;

      else
        do;
	if shared.bug_mode
	then call ioa_ ("^5x(need=^f have=^f)", show (blnkct, 12000),
		show (col.hdr.pspc, 12000));

	blnkct = blnkct - col.hdr.pspc;
        end;

      if blnkct <= 0		/* if we're already there */
      then goto end_ctl_loop;

      if shared.blkptr ^= null	/* check header addition */
      then
        do;
	if text.parms.hdrptr ^= null
	then
	  do;
	    call comp_space_ (blnkct, text.parms.hdrptr, "1"b, "1"b, "1"b,
	         "0"b);
	    goto end_ctl_loop;
	  end;

	if shared.blkptr ^= null ()	/* finish block */
	then if text.input_line ^= ""
	     then call comp_break_ (format_break, 0);

	if (text.parms.title_mode | text.parms.keep | text.parms.art)
	then break_type = format_break;
	else break_type = block_break;
        end;

      else break_type = block_break;
      goto join_sp_2;		/* go do it */

ctl_ (139):			/* ".sr"  = set-reference */
ctl_ (140):			/* ".src" = set-reference-counter */
src_ctl:
      if ctl.index > length (ctl_line)	/* if nothing there */
      then
        do;
	call comp_report_ (2, 0, "Missing variable name.", addr (ctl.info),
	     ctl_line);
	goto end_ctl_loop;
        end;

      given_symbol =		/* read the given symbol */
	 comp_read_$name (ctl_line, ctl.index, ctl.index, addr (ctl.info));

      if given_symbol = ""		/* invalid name? */
      then goto end_ctl_loop;		/**/
				/* reserved name? */
      if index (given_symbol, "Arg") = 1 & given_symbol ^= "ArgCount"
      then if verify (rtrim (substr (given_symbol, 4)), "0123456789") = 0
	 then
	   do;
resrvd_nm:
	     call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		"^a is a reserved name.", given_symbol);
	     goto end_ctl_loop;
	   end;

      if given_symbol = "ArgCount"	/* this one, too */
      then goto resrvd_nm;		/**/
				/* is a value given? */
      if ctl.index <= length (ctl_line)
      then
        do;			/* substitution needed? */
	if index (ctl_line, shared.sym_delim) ^= 0
	then call comp_use_ref_ (ctl_line, "0"b, "0"b, addr (ctl.info));

	call comp_update_symbol_ ("0"b, "0"b, "0"b, given_symbol,
	     substr (ctl_line, ctl.index));
        end;			/**/
				/* if no value, use "" to define it */
      else call comp_update_symbol_ ("0"b, "0"b, "1"b, given_symbol, "");

      goto end_ctl_loop;

ctl_ (141):			/* ".srm" = set-reference-mode */
      if ctl.index > length (ctl_line)
      then			/* no variables */
        do;
	call comp_report_ (2, 0, "No display mode keyword given.",
	     addr (ctl.info), ctl_line);
	goto end_ctl_loop;
        end;

      mode_key =			/* read the keyword */
	 comp_read_$name (ctl_line, ctl.index, ctl.index, addr (ctl.info));
				/*  and set index value */
      modendx = index (mode_string, mode_key);

      if modendx = 0		/* key not found */
      then
        do;
	call comp_report_ (2, 0, "Unknown display mode keyword.",
	     addr (ctl.info), ctl_line);
	goto end_ctl_loop;
        end;

      modendx = divide (modendx, 2, 17);/* compute true index value */

      if ctl.index > length (ctl_line)	/* if nothing follows */
      then
        do;
	call comp_report_ (2, 0, "No variable list given.", addr (ctl.info),
	     ctl_line);
	goto end_ctl_loop;
        end;

      else
        do			/* scan the given variable list */
	   while (ctl.index <= length (ctl_line));
	given_symbol =		/* read a name */
	     comp_read_$name (ctl_line, ctl.index, ctl.index,
	     addr (ctl.info));

	if given_symbol = "PageNo"	/* PageNo not allowed */
	then
	  do;
	    call comp_report_ (2, 0,
	         "Page number display mode may not be changed "
	         || "with this control.", addr (ctl.info), ctl_line);
	  end;

	else
	  do;
	    call comp_util_$search_tree (given_symbol, CREATE);
	    tree_var_ptr = tree.var_ptr (tree.areandx);
	    tree_var.mode (tree.entryndx) = modendx;
	  end;
        end;

      goto end_ctl_loop;

ctl_ (142):			/* ".srv" = set-reference-variable */
      goto src_ctl;

ctl_ (143):			/* ".stl" = split_title_line */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* TABLE CONTROLS */
ctl_ (144):			/* ".tab" =   table-define */
ctl_ (145):			/* ".tac" =   table-column */
ctl_ (146):			/* ".taf" =   table-off */
ctl_ (147):			/* ".tan" =   table-on */
				/* tac_ctl_index, taf_ctl_index */
tac_ctl:
      call comp_tbl_ctls_ (ctl_index);
      goto end_ctl_loop;

/* TITLE-BLOCK CONTROLS */
ctl_ (148):			/* ".tb"  =   title-block */
ctl_ (149):			/* ".tbb" =   title-block-begin */
ctl_ (150):			/* ".tbe" =   title-block-end */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (151):			/* ".tcl" = text-caption-line */
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (152):			/* ".then" = conditional-then */
      if shared.if_nest.ndx = 0	/* if no active nest */
      then
        do;
	call comp_report_$ctlstr (2, comp_error_table_$usage_error,
	     addr (ctl.info), ctl_line,
	     "Not in an active conditional execution group.");
	goto end_ctl_loop;
        end;

      found_clause = "1"b;		/**/
				/* execute the then? */
      if shared.if_nest (shared.if_nest.ndx).sw = THEN
      then
        do;
	if shared.indctl.stk (shared.indctl.ndx)
	then ctl_line = ltrim (after (ctl_line, ".then"));
	else ctl_line = after (ctl_line, ".then ");

	if index (ctl_line, ".") = 1
	then again = "1"b;
	else if ctl_line ^= ""
	then text_added = "1"b;
        end;

      else			/* search for if/else/elseif/endif */
        do;			/* until found or end_input */
	this_nest = shared.if_nest.ndx;
	if index (ltrim (after (ctl_line, "then")), ".if ") = 1
	then
	  do;			/* count another nest */
	    shared.if_nest.ndx = shared.if_nest.ndx + 1;
	    if shared.bug_mode
	    then call ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
		    ctl.lineno, ctl_line);
	  end;

	do while (^shared.end_input); /**/
				/* read next line */
	  call comp_read_$line (call_box_ptr, ctl_line, "1"b);
	  ctl.info = call_box.info;

	  if index (ltrim (ctl_line), ".if ") = 1
	  then
	    do;			/* count another nest */
	      shared.if_nest.ndx = shared.if_nest.ndx + 1;
	      if shared.bug_mode
	      then call ioa_$rsnnl ("ifnest=^d if_sw=^d", exit_str, 0,
		      shared.if_nest.ndx,
		      shared.if_nest (shared.if_nest.ndx).sw);
	    end;

	  else if index (ltrim (ctl_line), ".else") = 1
	       | index (ltrim (ctl_line), ".endif") = 1
	  then
	    do;
	      if shared.bug_mode
	      then call ioa_ ("^5xifnest=^d (^d ""^a"")", shared.if_nest.ndx,
		      ctl.lineno, ctl_line);

	      if index (ltrim (ctl_line), ".endif") = 1
	      then
	        do;
		if shared.if_nest.ndx > this_nest
		then shared.if_nest.ndx = shared.if_nest.ndx - 1;

		else
		  do;
		    again = "1"b;	/* set the control flag */
		    goto end_ctl_loop;
		  end;
	        end;

	      else if index (ltrim (ctl_line), ".else") = 1
	      then if shared.if_nest.ndx = this_nest
		 then
		   do;
		     again = "1"b;	/* set the control flag */
		     goto end_ctl_loop;
		   end;
	    end;
	end;
        end;
      goto end_ctl_loop;

ctl_ (153):			/* ".thl" = text-header-line */
thl_ctl:
      call comp_hft_ctls_ (ctl_index);
      goto end_ctl_loop;

/* TITLE-LINE CONTROLS */
ctl_ (154):			/* ".tlc" = title-line-caption */
ctl_ (155):			/* ".tlh" = title-line-header */
      if shared.blkptr ^= null ()
      then if text.blktype = "th" | text.blktype = "tf"
	 then
	   do;
	     call comp_report_ (2, 0,
		"Already processing a text header or caption.",
		addr (ctl.info), ctl_line);
	     goto end_ctl_loop;
	   end;

      call comp_hft_ctls_ (ctl_index);

      goto end_ctl_loop;

ctl_ (156):			/* ".tre" = translate-exceptions */
      goto end_ctl_loop;

ctl_ (157):			/* ".trf" = translate-formatted */
ctl_ (158):			/* ".trn" = translate */
      dcl tr_in	     char (1);	/* input char */
      dcl tr_out	     char (1);	/* output char */

      if ctl.index > length (ctl_line)	/* resetting all? */
      then
        do;
	shared.trans.in, shared.trans.out = " ";
	goto end_ctl_loop;
        end;

      do ctl.index = ctl.index to length (ctl_line) by 2;
        tr_in = substr (ctl_line, ctl.index, 1);
				/* cant trf the sym delim */
        if tr_in = shared.sym_delim
        then call comp_report_ (2, 0, "Cannot translate symbol-delimiter.",
	        addr (ctl.info), ctl_line);
				/* or the ttl delim */
        else if tr_in = shared.ttl_delim
        then call comp_report_ (2, 0, "Cannot translate title-delimiter.",
	        addr (ctl.info), ctl_line);

        else
	do;
	  if ctl.index < length (ctl_line)
	  then if substr (ctl_line, ctl.index + 1, 1) ^= " "
	       then tr_out = substr (ctl_line, ctl.index + 1, 1);
	       else tr_out = EN;
	  else tr_out = EN;

	  i = index (shared.trans.in, tr_in);
				/* look for it */

	  if i > 0		/* resetting or changing */
	  then
	    do;
	      if tr_in = tr_out	/* resetting */
	      then
	        do;
		shared.trans.in =
		     substr (shared.trans.in, 1, i - 1)
		     || substr (shared.trans.in, i + 1);
		shared.trans.out =
		     substr (shared.trans.out, 1, i - 1)
		     || substr (shared.trans.out, i + 1);
	        end;		/* changing */
	      else substr (shared.trans.out, i, 1) = tr_out;
	    end;

	  else
	    do;			/* adding */
	      shared.trans.in = shared.trans.in || tr_in;
	      shared.trans.out = shared.trans.out || tr_out;
	    end;
	end;
      end;

      goto end_ctl_loop;

ctl_ (159):			/* ".ttl" = text-title-line */
      goto thl_ctl;

ctl_ (160):			/* ".ts" = test */
      if ctl.index <= length (ctl_line) /* process symbol refs */
      then if index (ctl_line, shared.sym_delim) ^= 0
	 then call comp_use_ref_ (ctl_line, current_parms.art, "0"b,
		 addr (ctl.info));

      slog = "0"b;
      if ctl.index <= length (ctl_line)
      then
        do;
	call comp_expr_eval_ (ctl_line, ctl.index, addr (ctl.info), LOG, 0,
	     slog, 0, "", ""b, ercd);
	if ercd ^= 0		/* was there an error? */
	then goto end_ctl_loop;	/* same as true */

	else if ^slog		/* skip next line if FALSE */
	then
	  do;
	    call comp_read_$line (call_box_ptr, ctl_line, "1"b);
	    ctl.info = call_box.info;
	  end;
        end;			/**/
				/* skip next line */
      else
        do;
	call comp_read_$line (call_box_ptr, ctl_line, "1"b);
	ctl.info = call_box.info;
        end;

      if shared.bug_mode
      then call ioa_$rsnnl ("^[T^;F^]", exit_str, 0, slog);

      goto end_ctl_loop;

ctl_ (161):			/* ".ty" = write on error_output */
      if ctl.index > length (ctl_line)
      then call iox_$put_chars (iox_$error_output, addr (NL), 1, ercd);

      else
        do;
	call comp_use_ref_ (ctl_line, "0"b, "0"b, addr (ctl.info));
	ty_buf = translate (substr (ctl_line, 5), PAD, "ż") || NL;
	call iox_$put_chars (iox_$error_output, addr (ty_buf),
	     length (ctl_line) - 3, ercd);
	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose",
	         ".ty attempting to write to error_output.");
	    signal comp_abort;
	    return;
	  end;
        end;
      goto end_ctl_loop;

ctl_ (162):			/* ".un"  = undent */
ctl_ (163):			/* ".unb" = undent-both */
ctl_ (164):			/* ".unh" = undent-hanging */
ctl_ (165):			/* ".unl" = undent-left */
ctl_ (166):			/* ".unn" = undent-nobreak - OBSOLETED BY .unh */
ctl_ (167):			/* ".unr" = undent-right */
      call comp_format_ctls_ (ctl_index);
      goto end_ctl_loop;

ctl_ (168):			/* ".unson" = underscore-on */
      ctl_line = unstart_signal;
      ctl.unstrt, text_added, ctl.DVctl = "1"b;

      goto end_ctl_loop;

ctl_ (169):			/* ".unsoff" = underscore-off */
      ctl_line = unstop_signal;
      ctl.unstop, text_added, ctl.DVctl = "1"b;

      goto end_ctl_loop;

ctl_ (170):			/* ".ur" = use reference */
      if ctl.index > length (ctl_line)	/* if nothing there */
      then goto return_;

      call comp_use_ref_ (ctl_line, current_parms.art, "0"b, addr (ctl.info));
      ctl_line = after (ctl_line, ".ur ");
      ctl.index = 1;

      if ctl_line = ""		/* convert null lines */
      then ctl_line = ".spb";

      if shared.table_mode		/* table mode? */
      then
        do;
	tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
	if tblfmt.context		/* context mode? */
	     & index (ctl_line, ".") = 1
	     & search (substr (ctl_line, 2), "0123456789") = 1
	then
	  do;
	    if index (ctl_line, "*") ^= 0 & page.hdr.col_index >= 0
	    then call comp_util_$escape (ctl_line, addr (ctl.info));
	    text_added = "1"b;
	    goto end_ctl_loop;
	  end;
        end;

      if index (ctl_line, ".") = 1	/* if nested controls */
	 & ctl_line ^= "." & index (ctl_line, "...") ^= 1
      then again = "1"b;		/* set flag to reprocess line */
      else
        do;
	text_added = "1"b;
	if index (ctl_line, "*") ^= 0 & page.hdr.col_index >= 0
	then call comp_util_$escape (ctl_line, addr (ctl.info));
        end;

      goto end_ctl_loop;

ctl_ (171):			/* ".vab" = vertical-align-bottom - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (172):			/* ".vac" = vertical-align-center - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (173):			/* ".vaj" = vertical-align-justify - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (174):			/* ".vat" = vertical-align-top - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (175):			/* ".vm" = vertical-margin-all */
      goto vmt_ctl;

ctl_ (176):			/* ".vmb" = vertical-margin-bottom */
vmb_ctl:
      call comp_util_$set_bin (page_parms.margin.bottom, "bottom margin",
	 48000, comp_dvt.vmb_min,
	 page_parms.length - page_parms.margin.top
	 - page_parms.margin.header - page_parms.margin.footer, vscales,
	 comp_dvt.min_lead);
      page.parms.margin.bottom = page_parms.margin.bottom;

      if ^option.galley_opt
      then call comp_util_$set_net_page ("1"b);

      goto end_ctl_loop;

ctl_ (177):			/* ".vmf" = vertical-margin-footer */
vmf_ctl:
      call comp_util_$set_bin (page_parms.margin.footer, "footer margin",
	 24000, 0,
	 page_parms.length - page_parms.margin.top
	 - page_parms.margin.header - page_parms.margin.bottom, vscales,
	 comp_dvt.min_lead);
      page.parms.margin.footer = page_parms.margin.footer;

      if index (ctl_line, ".vmf") ^= 1
      then goto vmb_ctl;

      if ^option.galley_opt
      then call comp_util_$set_net_page ("1"b);
      goto end_ctl_loop;

ctl_ (178):			/* ".vmh" = vertical-margin-header */
vmh_ctl:
      call comp_util_$set_bin (page_parms.margin.header, "header margin",
	 24000, 0,
	 page_parms.length - page_parms.margin.top
	 - page_parms.margin.footer - page_parms.margin.bottom, vscales,
	 comp_dvt.min_lead);
      page.parms.margin.header = page_parms.margin.header;

      if ^(page.hdr.headed | option.galley_opt)
      then
        do;
	page.hdr.hdspc = page.parms.margin.top;
				/* preset space to top margin */

	if page.hdr.frontpage	/* if a headed odd page */
	then if shared.ophdrptr ^= null ()
	     then if shared.ophdrptr -> hfcblk.hdr.count ^= 0
		then page.hdr.hdspc = 0;
		else ;
	     else ;		/**/
				/* or a headed even page */
	else if shared.ephdrptr ^= null ()
	then if shared.ephdrptr -> hfcblk.hdr.count ^= 0
	     then page.hdr.hdspc = 0;
	page.hdr.hdspc = page.hdr.hdspc + page.parms.margin.header;
        end;
      if index (ctl_line, ".vmh") ^= 1
      then goto vmf_ctl;

      if ^option.galley_opt
      then call comp_util_$set_net_page ("1"b);
      goto end_ctl_loop;

ctl_ (179):			/* ".vmt" = vertical-margin-top */
vmt_ctl:
      call comp_util_$set_bin (page_parms.margin.top, "top margin", 48000,
	 comp_dvt.vmt_min,
	 page_parms.length - page_parms.margin.header
	 - page_parms.margin.footer - page_parms.margin.bottom, vscales,
	 comp_dvt.min_lead);
      page.parms.margin.top = page_parms.margin.top;

      if ^(page.hdr.headed | option.galley_opt)
      then
        do;
	page.hdr.hdspc = page_parms.margin.top;

	if page.hdr.frontpage	/* if a headed odd page */
	then if shared.ophdrptr ^= null ()
	     then if shared.ophdrptr -> hfcblk.hdr.count ^= 0
		then page.hdr.hdspc = 0;
		else ;
	     else ;		/**/
				/* or a headed even page */
	else if shared.ephdrptr ^= null ()
	then if shared.ephdrptr -> hfcblk.hdr.count ^= 0
	     then page.hdr.hdspc = 0;

	page.hdr.hdspc = page.hdr.hdspc + page.parms.margin.header;
        end;

      if index (ctl_line, ".vmt") ^= 1
      then goto vmh_ctl;

      if ^option.galley_opt
      then call comp_util_$set_net_page ("1"b);
      goto end_ctl_loop;

ctl_ (180):			/* ".vrul" = vertical-rule */
      goto end_ctl_loop;

ctl_ (181):			/* ".wi" = widow */
      goto wit_ctl;

ctl_ (182):			/* ".wif" = widow-footnotes */
      call comp_util_$set_bin (shared.widow_foot, "footnote widow", 1, 0, -1,
	 unscaled, 1);
      goto end_ctl_loop;

ctl_ (183):			/* ".wit" = widow-text */
wit_ctl:
      call comp_util_$set_bin (shared.widow_size, "text widow", 2, 0, -1,
	 unscaled, 1);
      goto end_ctl_loop;

ctl_ (184):			/* ".wrf" = write-formatted - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (185):			/* ".wro" = write-order - NOT IMPLEMENTED */
      goto end_ctl_loop;

ctl_ (186):			/* ".wrt" = write-text */
      dcl bits	     fixed;	/* bitcount of aux write file */

      if ctl.index > length (ctl_line)
      then
        do;
	call comp_report_ (2, 0, "Path must be given.", addr (ctl.info),
	     ctl_line);
	goto end_ctl_loop;
        end;

      call aux_file (ctl_line, ctl.index, ercd);
      if ercd ^= 0
      then goto end_ctl_loop;

      if ctl.index > length (ctl_line)
      then call iox_$put_chars (aux_file_data.entry (aux_file_index).iocb_ptr,
	      addr (NL), 1, ercd);

      else
        do;
	aux_wrt_buf = substr (ctl_line, ctl.index);

	if (substr (aux_wrt_buf, 1, 1) ^= "."
	     | substr (aux_wrt_buf, 1, 3) = "...")
	     & index (aux_wrt_buf, "*") ^= 0
	then call comp_util_$escape (aux_wrt_buf, addr (ctl.info));

	if shared.trans.in ^= " "
	then aux_wrt_buf = comp_util_$translate (aux_wrt_buf);
	aux_wrt_buf = aux_wrt_buf || NL;
	call iox_$put_chars (aux_file_data.entry (aux_file_index).iocb_ptr,
	     addrel (addr (aux_wrt_buf), 1), length (aux_wrt_buf), ercd);
        end;

      if ercd ^= 0
      then call comp_report_ (2, ercd, "Writing to auxiliary write file.",
	      addr (ctl.info), ctl_line);

      call adjust_bit_count_ ((aux_file_data.entry (aux_file_index).dir),
	 (aux_file_data.entry (aux_file_index).name), "1"b, bits, ercd);

      if ercd ^= 0
      then call comp_report_ (2, ercd,
	      "Adjusting bitcount of auxiliary" || " write file.",
	      addr (ctl.info), ctl_line);
      goto end_ctl_loop;

ctl_ (187):			/* ".wt" = wait */
      if shared.blkptr = null
      then
        do;
	ctl_line = wait_signal;
	text_added, ctl.DVctl = "1"b;
	ctl.linespace = 0;
        end;

      else
        do;
	if text.input_line ^= ""
	then
	  do;
	    ctl_line = wait_signal;
	    text_added, ctl.DVctl = "1"b;
	    ctl.linespace = 0;
	  end;
	else
	  do;
	    line_area_ptr = text.line_area.cur;
	    txtstrptr = line_area.linptr (line_area.ndx) -> txtlin.ptr;
	    txtstr = txtstr || wait_signal;
	  end;
        end;

end_ctl_loop:
    end ctl_loop;

return_:
    if shared.bug_mode
    then call ioa_ ("     (ctls:^[ ^a^;^s^]^[ text added=^d^])",
	    (exit_str ^= ""), exit_str, text_added, length (ctl_line));
    return;
%page;
/* RECORD/CHECK STATUS/OPEN AUXILIARY FILES */
aux_file:
  proc (buffer, start, code);

/* PARAMETERS */

    dcl buffer	   char (*) var;	/* buffer containing file name */
    dcl start	   fixed bin (21);	/* buffer position index */
    dcl code	   fixed bin (35);	/* error code */

/* LOCAL STORAGE */

    dcl aux_name	   char (32);	/* name of auxiliary write file */
    dcl aux_path	   char (200);	/* path of auxiliary write file */
    dcl pic_i	   pic "99";	/* pictured aux_file_file index */
				/* opening mode, stream-input-output */
    dcl sio	   fixed bin static options (constant) init (3);

/* for future extensible files
/*	dcl  safety_switch bit (1) aligned;
/*	dcl  hcs_$get_safety_sw entry (char (*)aligned, char (*)aligned, bit (1)aligned, fixed bin (35));
/*			call hcs_$get_safety_sw (dn, en, safety_switch, code); */

    code = 0;			/**/
				/* need file data structure? */
    if shared.aux_file_data_ptr = null ()
    then
      do;
        shared.aux_file_data_ptr =
	   allocate (const.local_area_ptr, size (aux_file_data));
        aux_file_data.count = 0;
        aux_file_data.iocb_ptr = null;
        aux_file_data.name = "";
        aux_file_data.dir = "";
        aux_file_data.path = "";
      end;			/**/
				/* extract file name */
    namel = index (substr (buffer, start), " ") - 1;
    if namel > 0			/* if data follows the name */
    then
      do;
        aux_path, aux_name = substr (buffer, start, namel);
        start = start + namel + 1;
      end;
    else				/* only a name */
      do;
        aux_path, aux_name = substr (buffer, start);
        start = length (buffer) + 1;
      end;

    dirname = "";			/* clean up possible garbage */
    if search (aux_path, "<>") ^= 0	/* if a path is given, expand it */
    then
      do;
        call expand_pathname_ (aux_path, dirname, aux_name, ercd);

        if ercd ^= 0
        then
	do;
	  call comp_report_ (2, ercd,
	       "Expanding given auxiliary write file pathname.",
	       addr (ctl.info), (buffer));
	  code = 1;
	  return;
	end;
      end;			/**/
				/* search table for this file */
    if aux_file_data.count > 0
    then
      do aux_file_index = 1 to aux_file_data.count
	 while (aux_file_data.entry (aux_file_index).name ^= aux_name);
      end;
    else aux_file_index = 1;		/**/
				/* if this is a new one */
    if aux_file_index > aux_file_data.count
    then
      do;				/* check file count */
        if aux_file_data.count = hbound (aux_file_data.entry, 1)
        then
	do;
	  call comp_report_$ctlstr (2, 0, addr (ctl.info), buffer,
	       "More that ^d auxiliary write files.",
	       hbound (aux_file_data.entry, 1));
	  code = 1;
	  return;
	end;			/**/
				/* set the name */
        aux_file_data.entry (aux_file_index).name = aux_name;

        if dirname ^= ""		/* if a path was given */
        then aux_file_data.entry (aux_file_index).dir = dirname;
        else aux_file_data.entry (aux_file_index).dir = get_wdir_ ();

        aux_file_data.entry (aux_file_index).path =
	   pathname_ ((aux_file_data.entry (aux_file_index).dir),
	   (aux_file_data.entry (aux_file_index).name));

        pic_i = aux_file_index;
        call iox_$attach_name ("comp_aux_file_" || pic_i,
	   aux_file_data.entry (aux_file_index).iocb_ptr,
	   "vfile_ " || aux_file_data.entry (aux_file_index).path, null (),
	   ercd);
        if ercd ^= 0
        then
	do;
	  call comp_report_ (2, ercd, "Attaching auxiliary write file.",
	       addr (ctl.info), (buffer));
	  code = 1;
	  return;
	end;

        call iox_$open (aux_file_data.entry (aux_file_index).iocb_ptr, sio,
	   "0"b, ercd);
        if ercd ^= 0
        then
	do;
	  call comp_report_ (2, ercd, "Opening auxiliary write file.",
	       addr (ctl.info), (buffer));
	  call iox_$detach_iocb (aux_file_data.entry (aux_file_index)
	       .iocb_ptr, ercd);
	  code = 1;
	  return;
	end;

        aux_file_data.count = aux_file_index;
				/* now we know one more */
      end;
  end aux_file;
%page;
process_hwrd:
  proc;

/* This procedure adds the current word to the internal hwrd list.  It
   first parses the word for hyphenation and/or break points.  If the word
   already exists in the list, it is replaced with the current data unless
   the first character is "^". It that case, it is simply removed.
*/

    dcl brkpoints	   bit (288);	/* word break points */
    dcl delete	   bit (1);	/* 1= delete word */
    dcl hpoints	   bit (288);	/* hyphenation points */
    dcl keywrd	   char (256) varying;
    dcl next_char	   char (1);
    dcl trigger	   char (1);

    if hwrd = "^"
    then
      do;
        call comp_report_$ctlstr (2, comp_error_table_$syntax_error,
	   addr (ctl.info), ctl_line,
	   "Null special hyphenation word. ""^a""", hwrd);
        return;
      end;

    keywrd = "";
    brkpoints, hpoints = "0"b;

    if index (hwrd, "^") = 1		/* check for delete only */
    then
      do;
        delete = "1"b;
        hwrd = after (hwrd, "^");
      end;
    else delete = "0"b;		/**/
				/* parse the word */
    do j = 1 by 1 while (j <= length (hwrd));
				/* look for a trigger */
      i = search (substr (hwrd, j), "-^") - 1;
      if i = -1
      then i = length (hwrd) - j + 1;	/**/
				/* add chars to key */
      keywrd = keywrd || substr (hwrd, j, i);
      j = j + i;			/* step over them */

      if j <= length (hwrd)		/* something left */
      then
        do;
	trigger = substr (hwrd, j, 1);/* get the trigger */

	if j < length (hwrd)	/* get the next character */
	then next_char = substr (hwrd, j + 1, 1);
	else next_char = " ";

	if trigger = "^"		/* a word break point? */
	then
	  do;			/* does it follow a literal hyphen? */
	    if substr (keywrd, length (keywrd), 1) = "-"
	    then ;		/* then ignore it */

	    else
	      do;
	        substr (brkpoints, length (keywrd), 1) = "1"b;
				/* treat a following hyphen as a literal */
	        if next_char = "-"
	        then j = j + 1;
	      end;
	  end;

	else			/* hyphenation point */
	  do;
	    if next_char ^= "="	/* must be a hyphenation point */
	    then
	      do;
	        if length (keywrd) = 0
	        then
		do;
		  call comp_report_$ctlstr (2, 0, addr (ctl.info),
		       ctl_line,
		       "Hyphenation point precedes word. "
		       || "Word ignored. ""^a""", hwrd);
		  return;
		end;

	        if substr (keywrd, length (keywrd), 1) = "-"
	        then
		do;
		  call comp_report_$ctlstr (2, 0, addr (ctl.info),
		       ctl_line,
		       "Hyphenation point immediately follows "
		       || "hyphen. Word ignored. ^a", hwrd);
		  return;
		end;		/**/
				/* indicate hyphenation point */
	        substr (hpoints, length (keywrd), 1) = "1"b;
	      end;		/**/
				/* must be a literal hyphen */
	    if next_char = "=" | next_char = "-"
	    then
	      do;			/* indicate literal hyphen */
	        keywrd = keywrd || "-";
	        j = j + 1;		/* to skip over two character sequence */
	      end;
	  end;
        end;
    end;				/**/
				/* look for the word */
    do i = 1 to hwrd_data.count while (hwrd_data.word (i) ^= keywrd);
    end;

    hwrd_data.word (i) = "";		/* erase it */

    if delete			/* delete only? */
    then return;			/**/
				/* add the word to the list */
    hwrd_data.word (i) = keywrd;
    hwrd_data.hpts (i) = hpoints;
    hwrd_data.brkpts (i) = brkpoints;

    if i > hwrd_data.count
    then hwrd_data.count = i;

  end process_hwrd;
%page;
set_label:
  proc;				/* RECORD LABEL CONTROL DATA */

/* LOCAL STORAGE */

    dcl this_label	   char (32);	/* label from control */
				/* check label count */
    if insert.label.count = hbound (insert.label.value, 1)
    then
      do;
        call comp_report_ (2, 0, "Too many labels.", addr (ctl.info), ctl_line)
	   ;
        return;
      end;			/* extract the given label */
    this_label = ltrim (substr (ctl_line, ctl.index));

    if this_label = "" | this_label = " "
				/* if null or blank */
    then
      do;
        call comp_report_ (2, 0, "Missing label name.", addr (ctl.info),
	   ctl_line);
        return;
      end;

    if insert.label.count > 0		/* if any labels are recorded ... */
    then
      do;
        j = index (
	   substr (addr (insert.label.value (1)) -> label_value_str, 1,
	   32 * insert.label.count), this_label);
        if j > 0
        then return;		/* we already have this one */
      end;

    j, insert.label.count = insert.label.count + 1;
				/* a new label */

    insert.label.value (j) = this_label;
    insert.label.line (j) = ctl.info.lineno;
    insert.label.position (j) =
         call_stack.ptr (call_stack.index) -> call_box.posn;

  end set_label;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_aux_file;
%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_DCdata;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_footnotes;
%include comp_hwrd_data;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
    dcl 1 save_info	   like text_entry.info;
				/* to hold info of .go line */
    dcl 1 hit_line	   aligned like text_entry;
				/* the hit line entry */
%include comp_text;
%include comp_dvt;
/* DISORDER DUE TO SYMBOL TABLE SIZE LIMIT */
%include comp_tree;
%include compstat;
%include translator_temp_alloc;

  end comp_ctls_;




		    comp_eject_page_.pl1            04/23/85  1059.2rew 04/23/85  0909.0       70866



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

/* compose subroutine to finish and eject the current page */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_eject_page_:
  proc;

/* PARAMETERS */

/* LOCAL STORAGE */

    dcl footer_depth   fixed bin (31);	/* depth of first footer line */
				/* copy of page footer pointer */
    dcl (i, j)	   fixed bin;	/* working index */
    dcl 1 locol	   aligned like col based (locolptr);
				/* for local reference */
    dcl locolptr	   ptr;		/* for local reference */
    dcl tmpline	   char (1020) var; /* for header symbol replacement */

    dcl (index, length, max, mod, null)
		   builtin;
    dcl end_output	   condition;

    if shared.bug_mode
    then call ioa_ ("eject_page: (^a ^[front^;back^]^[ blank^]"
	    || "^[ MOD pgc=^a^;^s^] d^f u^f/^f)", page.hdr.pageno,
	    page.hdr.frontpage, page.hdr.blankpage, page.hdr.modified,
	    page.hdr.pgc_select, show (page.hdr.depth, 12000),
	    show (page.hdr.used, 12000), show (page.hdr.net, 12000));

    if shared.ftn_mode		/* if building footnotes */
    then goto return_;

    page.hdr.col_index = 0;		/* return to column 0 */
    shared.colptr = page.column_ptr (0);
    shared.blkptr = col0.blkptr (1);	/* and select page header */
				/* replace header symbols */
    do line_area_ptr = text.line_area.first repeat (line_area.next)
         while (line_area_ptr ^= null);
      do i = 1 to line_area.ndx;
        txtlinptr = line_area.linptr (i);
        txtstrptr = txtlin.ptr;	/* does it have symbols or escapes? */
        if index (txtstr, shared.sym_delim) ^= 0
	   | (^txtlin.art & index (txtstr, "*") ^= 0)
        then
	do;
	  tmpline = txtstr;		/* copy the text */
	  if index (tmpline, shared.sym_delim) ^= 0
	  then call comp_use_ref_ (tmpline, txtlin.art, "1"b,
		  addr (txtlin.info));

	  if index (tmpline, "*") ^= 0
	  then call comp_util_$escape (tmpline, addr (txtlin.info));

	  call comp_util_$replace_text (shared.blkptr,
	       (txtlin.quad ^= quadl & txtlin.quad ^= just), txtlinptr,
	       addr (tmpline));
	end;
      end;
    end;

    if page.hdr.blankpage		/* blank page? */
    then hfcblk_ptr = shared.blank_footer_ptr;
    else if page.hdr.frontpage	/* odd page? */
    then hfcblk_ptr = shared.opftrptr;
    else if ^page.hdr.frontpage	/* even page? */
    then hfcblk_ptr = shared.epftrptr;

    if hfcblk_ptr ^= null		/* do the page footer */
    then if hfcblk.hdr.used > 0
         then
	 do;
	   footer_depth =
	        page.parms.length - page.parms.margin.bottom
	        - hfcblk.hdr.used - page.parms.init_page_depth;

	   if shared.bug_mode
	   then call ioa_ ("^-(footer depth=^f)", show (footer_depth, 12000))
		   ;

	   if page.hdr.art		/* if page header starts artwork, */
	   then			/* extend it and append footer */
	     do;
	       shared.blkptr = col0.blkptr (1);
				/* put in real space */
	       call comp_space_ (footer_depth - text.hdr.used, shared.blkptr,
		  "0"b, "1"b, "0"b, "1"b);
				/* build the footer */
	       call comp_title_block_ (hfcblk_ptr);
				/* fill in page depth */
	       page.hdr.depth, col0.hdr.depth = 0;
	       do line_area_ptr = text.line_area.first
		  repeat (line_area.next) while (line_area_ptr ^= null);
	         do i = 1 to line_area.ndx;
		 txtlinptr = line_area.linptr (i);
		 txtstrptr = txtlin.ptr;
				/* does it have symbols or escapes? */
		 if index (txtstr, shared.sym_delim) ^= 0
		      | (^txtlin.art & index (txtstr, "*") ^= 0)
		 then
		   do;
		     tmpline = txtstr;
				/* copy the text */
		     if index (tmpline, shared.sym_delim) ^= 0
		     then call comp_use_ref_ (tmpline, txtlin.art, "1"b,
			     addr (txtlin.info));

		     if index (tmpline, "*") ^= 0
		     then call comp_util_$escape (tmpline,
			     addr (txtlin.info));

		     call comp_util_$replace_text (shared.blkptr,
			(txtlin.quad ^= quadl & txtlin.quad ^= just),
			txtlinptr, addr (tmpline));
		   end;

		 txtlin.depth = page.hdr.depth;
		 page.hdr.depth, col0.hdr.depth =
		      page.hdr.depth + txtlin.linespace;
	         end;
	       end;

	       if text.hdr.art
	       then call comp_art_ (shared.blkptr, "0"b);
	     end;

	   else			/* create a separate footer block */
	     do;
	       call comp_util_$getblk (0, shared.blkptr, "pf",
		  addr (hfcblk.parms), "0"b);
	       text.parms.page = "1"b;
	       unspec (text.parms.cbar) = "0"b;
				/* build the footer */
	       call comp_title_block_ (hfcblk_ptr);
/****				/* fill in page depth */
/****	       page.hdr.depth, col0.hdr.depth = footer_depth - 12000;
/****	       do line_area_ptr = text.line_area.first
/****		  repeat (line_area.next) while (line_area_ptr ^= null);
/****	         do i = 1 to line_area.ndx;
/****		 txtlinptr = line_area.linptr (i);
/****		 txtlin.depth = page.hdr.depth;
/****		 page.hdr.depth, col0.hdr.depth =
/****		      page.hdr.depth + txtlin.linespace;
/****	         end;
/****	       end;
/****
/****	       if text.hdr.art
/****	       then call comp_art_ (shared.blkptr, "0"b);*/

	       page.hdr.depth, col0.hdr.depth = footer_depth;
	       call comp_break_ (footer_break, 0);
	     end;
	 end;

    call comp_write_page_;		/* write the page */

    do i = 0 to page.hdr.col_count;	/* clean up all the columns */
      locolptr = page.column_ptr (i);
      locol.hdr = colhdr;		/* erase column header */
      locol.hdr.net = page.hdr.net - locol.ftrusd;
    end;

    page.hdr.used, page.hdr.balusd, page.hdr.baldepth = 0;

    if shared.pass_counter <= 1	/* if an output pass */
    then
      do;
        if shared.print_flag		/* if page was printed */
        then
	do;			/* and page is last of current range */
	  if page.hdr.pageno = option.pglst (option.pglstndx).to
	  then
	    do;			/* print flag OFF */
	      shared.print_flag = "0"b;
				/* next list entry */
	      option.pglstndx = option.pglstndx + 1;
	    end;
	end;			/**/
				/* if end hasn't been signalled */
        if ^shared.end_output &	/* if -to and this is it */
				/* or the last given -page */
	   (option.pglst (0).to ^= ""
	   & page.hdr.pageno = option.pglst (0).to)
	   | (option.pages_opt
	   & page.hdr.pageno = option.pglst (option.pglstct).to)
        then
	do;
	  shared.end_output = "1"b;
/****	  signal end_output;*/
	  goto return_;
	end;
      end;			/**/
				/* count the page */
    shared.pagecount = shared.pagecount + 1;

    if page.parms.cols.count > 0	/* if multicolumn */
    then				/* next page starts in column 1 */
      do;
        page.hdr.col_index = 1;
        shared.colptr = page.column_ptr (1);
        page.hdr.col_count = page.parms.cols.count;
      end;

    if shared.ftn_reset = "paged"	/* if footnotes are paged */
    then shared.ftnrefct = 1;		/* reset the counter */

return_:
    if shared.bug_mode
    then call ioa_ ("^5x(eject_page) (^[END^;^a ^[front^;back^]^])",
	    shared.end_output, page.hdr.pageno, page.hdr.frontpage);
    page.hdr.headed = "0"b;
%page;
show:
  proc (value, scale) returns (fixed dec (11, 3));
    dcl value	   fixed bin (31);
    dcl scale	   fixed bin (31);
    return (dec (divide (value, scale, 31, 10), 11, 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

  end comp_eject_page_;




		    comp_error_table_.alm           11/05/86  1546.4r w 11/04/86  1038.8        7137



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1985 *
" *                                                         *
" ***********************************************************
	include 	et_macros
	et 	comp_error_
"
" Written by Ed Wallman - 04/19/83.
" Modified:

ec inconsistent,incon,
	(Inconsistent formatting values.)

ec limitation,limit,
	(Program limitation.)

ec missing_delimiter,nodelim,
	(Missing delimiter.)

ec not_numeric,notnum,
	(Numeric value expected.)

ec program_error,progerr,
	(Program error.)

ec syntax_error,synerr,
	(Control syntax error.)

ec unknown_keyword,unkkey,
	(Unknown keyword.)

ec usage_error,userr,
	(Usage error.)

	end




		    comp_expr_eval_.pl1             04/23/85  1059.2rew 04/23/85  0909.1      371655



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

/* compose subroutine to evaluate expressions. */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_expr_eval_:
  proc (buffer, start, info_ptr, needtyp, restyp, reslog, resnum, resstr,
       res_attr, ercd);

/* PARAMETERS */

    dcl buffer	   char (*) var;	/* IN buffer containing <expr> */
    dcl start	   fixed bin (21);	/* IN/OUT starting char of <expr> */
    dcl info_ptr	   ptr;		/* IN info structure for buffer */
    dcl needtyp	   fixed bin;	/* IN needed type LOG/NUM/STR */
    dcl restyp	   fixed bin;	/* OUT result type LOG/NUM/STR */
    dcl reslog	   bit (1);	/* OUT result value for LOG */
    dcl resnum	   fixed bin (31);	/* OUT result value for NUM */
    dcl resstr	   char (*) var;	/* OUT result value for STR */
    dcl res_attr	   bit (9);	/* OUT attributes of result value */
    dcl ercd	   fixed bin (35);	/* error code */

/* This is an anotated debug output from this procedure.		       */
/*			    "o >" push operator		       */
/*    +-------------- action flag " v>" push operand onto operator	       */
/*    |			    "<ov" pop operand and operator	       */
/*    |			    "< v" pop operand (operator remains)	       */
/*    |  +----------- depth in stack				       */
/*    |  |  +-------- type of operation				       */
/*    |  |  | +------ operator precedence, 1(low) 9(high)		       */
/*    |  |  | | +---- operand  type (if present) Logical, Numeric, String    */
/*    |  |  | | | +-- operand value (if present)			       */
/*    |  |  | | | |						       */
/*    |  |  | | | |						       */
/*                  expr_eval: ""a"="b" "DE" & (4 * (1 - "4")) > 5 & 1+21"   */
/*   o >  1 << 0	     : push begin-expr operator at depth 1 to initialize */
/*    v>  1 << 0 S "a"   : next up is a string, this operand is pushed at    */
/*		     :	depth 1				       */
/*   o >  2 =  6	     : the "=" operator is next. since its precedence    */
/*		     :	(6) is higher than that of "<<" (0), the "="   */
/*		     :	is pushed at depth 2		       */
/*    v>  2 =  6 S "bDE" : the pair of strings which follow are concatenated */
/*		     :	and treated as a single operand which is       */
/*		     :	pushed at depth 2			       */
/*		     : next up is the "&" operator which has precedence  */
/*		     : 	5 (which will be seen in a few lines). Since   */
/*		     :	this is less than the 6 which is on top of     */
/*		     :	the stack, the operation stacked must be done  */
/*		     :    before the "&" can be pushed.		       */
/*   <ov  2 =  6 S "bDE" :    Taking to operands in the order 1-2 and the    */
/*   < v  1 << 0 S "a"   :	operator at 2, we can see that the stacked     */
/*		     :    operation is: "a"="bDE"		       */
/*    v>  1 << 0 L F     : The result of this is a logical FALSE (0) which   */
/*		     :    gets pushed at depth 1 to become the operand   */
/*		     :    at that level			       */
/*   o >  2 &  5	     : Now, the precedence 5 is higher than the stacked  */
/*		     :    precedence 0, so the "&" is pushed at depth 2  */
/*   o >  3 (  1	     : Then comes a "(" operator. This has a tabular     */
/*		     :    precedence of B, higher than any other. So it  */
/*		     :    is pushed, but with the shown precedence of 1  */
/*		     :    so that ANYTHING will push on top of it.       */
/*    v>  3 (  1 N 4.    : The numeric "4" which is next is then pushed at   */
/*		     :    depth 3				       */
/*   o >  4 *  8	     : The "*" operator has a precedence of 8, higher    */
/*		     :    than the stacked 1, so it is stacked.	       */
/*   o >  5 (  1	     : This "(" is also stacked at the next level.       */
/*    v>  5 (  1 N 1.    : The numeric operand "1" is stacked at depth 5     */
/*   o >  6 -  7	     : The "-" operator is of higher precedence than the */
/*		     :    stacked "(" so it gets stacked, too.	       */
/*    v>  6 -  7 S "4"   : A string operand "4" is present next and is also  */
/*		     :    stacked, at depth 6			       */
/*		     : Next in the expression is a ")". This has a       */
/*		     :    tabulated precedence of / (which is <0). Since */
/*		     :    the stacked operator is higher, it must be     */
/*		     :    performed at this time.		       */
/*   <ov  6 -  7 N 4.    : The expression to be evaluated is made up of      */
/*   < v  5 (  1 N 1.    :    operands 5-6 and operator 6. Note that operand */
/*		     :    6 has been converted to numeric as is needed   */
/*		     :    by the "-" operator. The expression is: 1-4    */
/*    v>  5 (  1 N -3.   : The result, "-3", then replaces the expression in */
/*		     :    the stack				       */
/*   <ov  5 (  1 N -3.   : The "(" operator on top of the stack is of higher */
/*   < v  4 *  8	     :    precedence than the ")" pending, so it is also */
/*		     :    done. Operand 4 is null, but "(" only wants 1  */
/*		     :    so this is just fine. The action is just to    */
/*		     :    copy the operand 5.  The pending ")" operator  */
/*		     :    gets used up in the process.		       */
/*    v>  4 *  8 N -3.   : This result is pushed at depth 4		       */
/*   <ov  4 *  8 N -3.   : Another ")" follows, so another evaluation must   */
/*   < v  3 (  1 N 4.    :    get done. This time the expr indicated by the  */
/*		     :    stack is: 4 * -3			       */
/*    v>  3 (  1 N -12.  : The resulting "-12" gets stacked as depth 3       */
/*   <ov  3 (  1 N -12.  : The evaluation continues with the "(" operator.   */
/*   < v  2 &  5	     :    The "-12" is copied out and the ")" dropped    */
/*    v>  2 &  5 N -12.  : AND it is pushed back as the value at depth 2     */
/*   o >  3 >  6	     : The next operator, ">", is of higher precedence   */
/*		     :    than the stacked "&" and so it gets stacked.   */
/*    v>  3 >  6 N 5.    : The numeric "5" gets stacked at depth 3	       */
/*   <ov  3 >  6 N 5.    : The "&" operator which follows causes an expr to  */
/*   < v  2 &  5 N -12.  :    be evaluated. This is made up of operands 2-3  */
/*		     :    and operator 3 and is: -12 > 5	       */
/*    v>  2 &  5 L F     : The result, FALSE (0), is pushed back at depth 2  */
/*   <ov  2 &  5 L F     : The "&" pending is not less than the "&" stacked. */
/*   < v  1 << 0 L F     :    So another evaluation is done, made up of      */
/*		     :    operands 1-2 and operator 2 are used. This is  */
/*		     :    the expression: 0 & 0 (Both 0's are FALSE)     */
/*    v>  1 << 0 L F     : This FALSE (0) result is put back into the stack  */
/*   o >  2 &  5	     : Now the operator "&" can be pushed	       */
/*    v>  2 &  5 N 1.    : The next numeric operand "1" gets pushed at depth */
/*		     :    2				       */
/*   o >  3 +  7	     : The "+" operator gets pushed because it is of     */
/*		     :    higher precedence			       */
/*    v>  3 +  7 N 21.   : The numeric "21" is also stacked, depth 3	       */
/*   <ov  3 +  7 N 21.   : Finally the end-expression is reached. This has   */
/*   < v  2 &  5 N 1.    :    lower precedence than all other entities and   */
/*		     :    so the whole stack will be flushed. First      */
/*		     :    1 + 21 is pulled from the stack and evaluated  */
/*    v>  2 &  5 N 22.   : This result, "22" is pushed back.	       */
/*   <ov  2 &  5 L T     : The expression TRUE (-1) & FALSE (0) is pulled    */
/*   < v  1 << 0 L F     :    from the stack and evaluated. Note that before */
/*		     :    operand 2 was used, it was converted from a    */
/*		     :    numeric 22 into a logical TRUE (-1).	       */
/*    v>  1 << 0 L F     : This result FALSE (0) is pushed back on the stack */
/*      (expr_eval) L F  : The evaluation is now complete. The bottom of the */
/*		     :    stack contains the result with expr_eval       */
/*		     :    returns to the caller.		       */
/*							       */

/* LOCAL STORAGE */

    dcl (
        BoE	   init (37),	/* << begin expr     */
        DIGIT	   init (11),	/* all numeric digits */
        EoE	   init (38),	/* >> end expr */
        STRING	   init (13)	/* strings */
        )		   fixed bin static options (constant);
    dcl bufpos	   fixed bin (21);	/* buffer position */
    dcl debug	   bit (1);	/* local debug control */
    dcl depth	   fixed bin;	/* stack depth */
    dcl detail	   bit (1);	/* local debug control */
    dcl fb71	   fixed bin (71);	/* for multiplication */
    dcl 1 font_ref	   aligned like fntstk_entry;
    dcl 1 fun	   based (addr (FuncRes)),
	2 len	   fixed bin (35),
	2 chr	   (1020) char (1);
    dcl FuncRes	   char (1020) var; /* result during function work      */
/****    dcl hscales	   (7) fixed bin (31) static options (constant)
/****		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);*/
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl max_width	   fixed bin (31);	/* millipoints		       */
    dcl msg	   char (64) var;	/* error messages */
				/* keyword for numerics */
    dcl num_val_key	   char (12) var init ("");

    dcl 1 opstk	   (20),		/* operation stack */
	2 e,			/* entry structure */
	  3 typ	   fixed bin,	/* type of operation */
	  3 prec	   char (1),	/* precedence thereof */
	  3 log_val  bit (1),	/* logical value */
	  3 num_val  fixed bin (31),	/* numeric value associated with */
				/* operation, usually the value */
				/* right after it in the stack */
	  3 str_val,		/* points to string value */
	    4 (ofst, len)
		   fixed bin,	/* offset,length in strs */
	  3 val_typ  fixed bin;	/* value type (types follow) -- */
				/* not present */
    dcl NONE	   fixed bin int static init (0);
				/* logical */
    dcl LOG	   fixed bin int static init (1);
				/* numeric */
    dcl NUM	   fixed bin int static init (2);
				/* string */
    dcl STR	   fixed bin int static init (3);
				/* various opstk entries */
    dcl curop_ptr	   ptr;		/* the current operation */
    dcl 1 curop	   like opstk.e based (curop_ptr);
    dcl prvop_ptr	   ptr;		/* the previous operation */
    dcl 1 prvop	   like opstk.e based (prvop_ptr);

    dcl OFF	   bit (1) static options (constant) init ("0"b);
    dcl ON	   bit (1) static options (constant) init ("1"b);
    dcl op1	   char (3);	/* operands for error reporting      */
    dcl op2	   char (2);	/* operands for error reporting      */
    dcl opnd_need	   char (1);	/* number of operands needed */
    dcl op_typ	   fixed bin;	/* operator type		       */
    dcl oprec	   char (1);	/* working precedence	       */
    dcl ot	   fixed bin;	/* working operand type	       */
    dcl RtP	   fixed bin static options (constant) init (39);
				/* )  right paren    */
    dcl scale	   (1) fixed bin (31) static options (constant)
		   init (1000);
    dcl strs	   char (10000);	/* place to hold temporary strings   */
    dcl strse	   fixed bin;	/* first location in strs available  */
    dcl strsu	   fixed bin;	/* amount of strs actually in use    */
    dcl temp_log	   bit (1);	/* temporary logical value */
    dcl temp_num	   fixed bin (31);	/* temporary numeric value */
    dcl temp_str	   char (3000) var; /* temporary string value */
    dcl temp_typ	   fixed bin;	/* temporary value type */
/****    dcl vscales	   (7) fixed bin (31) static options (constant)
/****		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);*/
    dcl width	   fixed bin (31);	/* millipoints */
				/* for measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;

    dcl (addr, bit, bool, convert, fixed, index, length, max, mod, null,
        search, substr, verify)
		   builtin;

    dcl comp_error_table_$usage_error
		   fixed bin (35) ext static;

/* processing control data */

/* The duplication of characters in proc_ctl.type is for the purpose of  */
/* holding a place.  The "(==_", for example.  The 2nd = can never found by */
/* index.However, the location in the string of the 2nd one, 17, represents */
/* the "opcode" to match the "=" operator.			       */
/*							       */
/* The algorithm works in this fashion:				       */
/* 0) push a begin-expression ("<<") on to the operator stack	       */
/* 1) make sure the XOR operator is canonical if it is next up	       */
/*    if no more data, generate end-expression (">>") token		       */
/*    pick up the next char of input and index for it into proc_ctl.type.    */
/*    If it is not found, go check for a builtin function.		       */
/* 2) pick up from proc_ctl.prec the corresponding precedence	       */
/* 3) if the precedence is "s", then skip the token		       */
/*    if the precedence is 'x', then look for an '=' following.  This then   */
/*      tells if "^=" "<=" ">=" is there instead of just "^" "<" ">".	       */
/*      also checks for "^|"					       */
/*    if the precedence is "y", then look for "<BSP>_" following.  This      */
/*      differentiates "=<BSP>_" from "="			       */
/* 4) If the token found is an operand or "(", then go push it on the stack  */
/* 5) If the the precedence of the new token (operator) is higher than the   */
/*    stacked one, push the operator on the stack.		       */
/* 6) otherwise, process things off the stack until a point is reached where */
/*    the new operator IS higher than what is on the stack.		       */
/*    Each operator is checked to see if the needed number of operands is    */
/*    present in the stack.					       */
/*        A ">>" token will cause everything to be removed from the stack,   */
/*    as will a ",".  If a ")" is encountered which does not have a matching */
/*    "(" in the stack, this is not an error.  It is assumed that the caller */
/*    recognized the leading "(", removed it, and expects to see the	       */
/*    matching ")" upon return.  "abc"(1,2) is an example of when this       */
/*    can happen.						       */
/*							       */
/* This is the precedence assigned by proc_ctl.prec:		       */
/* /  ")","}", "," ">>" (end-expression)			       */
/*        All four of these must flush out much from the stack.	       */
/*        The ")" must find a matching "(" already in the stack.	       */
/*        The ">>" will find a matching "<<" already in the stack.	       */
/*        The other 2 must NOT find "(" in the stack.		       */
/* 0  "<<" begin-expression					       */
/* 1  (UNUSED, however, "(" is pushed as this value so ANYTHING will push on */
/*        top of it.					       */
/* 2  numeric value, any operator will push on top of it		       */
/* 3  "|"							       */
/* 4  "^|", "=<BSP>_"					       */
/* 5  "&"
   6  "=", "^=", "<", "<=", ">", ">="
   7  "+", "-"
   8  "*", "/", "\"
   9  "^"
   B  "(" This is so it will push on top of anything.  However, it gets pushed
	as a "1" so that anything else will, in turn, push on top of it. */
/**** format: off */
dcl 1 proc_ctl	   int static options (constant),
/* 		    000000000111.1111111222222222233333333334444 */
/*		    123456789012.3456789012345678901234567890123 */
   (2 type       init ("0123456789.#""TF(==_^^^^<<<>>>+-*/\&|<>),} 	"),
    2 prec       init ("222222222222""  By64x964x66x6677888530////ss"),
    2 dspl_sfx   init ("         9  ""     =  =|  =  =       <>     "),
    2 ops_need   init ("            ""  1 22 122 22 2233222220      "))
		   char (43);	/* this is an HT ----------^ */
/**** format: on */

    restyp = NONE;
    res_attr = ""b;
    ercd = 0;

    debug = shared.bug_mode | db_sw;	/* set local debug control */
    detail = debug & dt_sw;

    if debug
    then
      do;
        call ioa_ ("expr_eval: (^d ^d) ^a ", start, length (buffer),
	   comp_util_$display (buffer, 0, "0"b));
      end;

    depth = 0;			/* initialize the operation stack */
    opstk.num_val, opstk.typ, opstk.val_typ, temp_num = 0;
    opstk.prec = "";
    opstk.log_val, temp_log = OFF;
    opstk.str_val.ofst = 1;
    opstk.str_val.len = 0;
    strse = 1;			/* initialize strs area */
    strsu = 0;

    if start > length (buffer)	/* if no starting index */
    then goto return_;

    op_typ = BoE;			/* start by pushing begin-expression */
    oprec = substr (proc_ctl.prec, op_typ, 1);
    bufpos = start;

    if index (substr (buffer, start), "{") ^= 1
    then start = start - 1;		/* make sure first char gets used    */

push_op_typ:
    depth = depth + 1;
    curop_ptr = addr (opstk.e (depth));
    if depth > 1
    then prvop_ptr = addr (opstk.e (depth - 1));
    curop.typ = op_typ;
    curop.prec = oprec;
    curop.val_typ = NONE;		/* show NO VALUE there */
    curop.num_val, curop.str_val.len = 0;
    curop.str_val.ofst = 1;

    if detail
    then call dumper ("o >", depth);

parse_loop:
    bufpos, start = start + 1;
    if start > length (buffer)
    then op_typ = EoE;		/* end-of-expression */

    else
      do;				/**/
				/* make sure XOR has canonical form */
        if length (buffer) - start + 1 >= 3
        then if index (substr (buffer, start), "_=") = 1
	   then substr (buffer, start, 3) = "=_";
				/* look up type of next char	       */
        op_typ = index (proc_ctl.type, substr (buffer, start, 1));
        if op_typ = 0		/* not a known type	       */
        then
	do;			/* try known functions */

/* Measure( <string-expression> ) */
	  if index (substr (buffer, start), "Measure") = 1
	  then
	    do;
	      bufpos, start = start + 7;
				/* step over function name */
				/* there must be an opening paren */
	      if substr (buffer, start, 1) ^= "("
	      then
	        do;
		call comp_report_$ctlstr (2, comp_error_table_$usage_error,
		     info_ptr, buffer,
		     "Missing left parenthesis for Measure");
		goto err_return;
	        end;
	      start = start + 1;	/* step over the paren */
				/* the string must be quoted */
	      if substr (buffer, start, 1) ^= """"
	      then
	        do;
		call comp_report_$ctlstr (2, comp_error_table_$usage_error,
		     info_ptr, buffer, "Missing string value for Measure");
		goto err_return;
	        end;

	      FuncRes =		/* extract the given string */
		 comp_extr_str_ ("1"b, buffer, start, start, 0, info_ptr);
	      if start = 0		/* something was wrong	       */
	      then goto err_return;

	      if length (FuncRes) = 0 /* for a null string */
	      then temp_num = 0;

	      else
	        do;
		font_ref =
		     current_parms.fntstk
		     .entry (current_parms.fntstk.index);
		unspec (meas1) = "0"b;
		call comp_measure_ (FuncRes, addr (font_ref), "0"b, "0"b,
		     "0"b, page_parms.measure, addr (meas1), addr (meas2),
		     info_ptr);
		temp_num = meas1.width + meas1.avg;
	        end;		/**/
				/* there must also be a closing paren */
	      if (substr (buffer, start, 1) ^= ")")
	      then
	        do;
		call comp_report_ (2, 0,
		     "Missing right parenthesis for Measure", info_ptr,
		     buffer);
		goto err_return;
	        end;

	      temp_typ = NUM;
	      num_val_key = "hspace";
	      res_attr = numeric_attr | hspace_attr;
	      goto push_temp;
	    end;			/**/

/* Wordl( <string-expression> , <numeric-expression> ) */
	  else if index (substr (buffer, start), "Wordl") = 1
	  then
	    do;			/* step over function name */
	      bufpos, start = start + 5;
				/* must start with a left paren */
	      if substr (buffer, start, 1) ^= "("
	      then
	        do;
		call comp_report_ (2, 0,
		     "Missing left parenthesis for Wordl", info_ptr,
		     buffer);
		goto err_return;
	        end;		/* step over the paren */
	      start = start + 1;	/**/
				/* must be a quoted string */
	      if substr (buffer, start, 1) ^= """"
	      then
	        do;
		call comp_report_ (2, 0, "Missing string value for Wordl",
		     info_ptr, buffer);
		goto err_return;
	        end;

	      FuncRes =
		 comp_extr_str_ ("1"b, buffer, start, start, 0, info_ptr);
	      if start = 0		/* something was wrong */
	      then goto err_return;

	      if substr (buffer, start, 1) ^= ","
	      then
	        do;
syntax_error:
		call comp_report_ (2, 0, "Missing comma in Wordl",
		     info_ptr, buffer);
		goto err_return;
	        end;

	      start = start + 1;	/* skip over the comma */
	      call comp_expr_eval_ (buffer, start, info_ptr, NUM, 0, "0"b,
		 temp_num, "", res_attr, ercd);
	      if ercd ^= 0		/* something was wrong */
	      then goto err_return;

	      if temp_num <= 0
	      then
	        do;
		call comp_report_ (2, 0, "Improper value for Wordl",
		     info_ptr, buffer);
		goto err_return;
	        end;		/**/
				/* if not horiz space, convert it */
	      if (res_attr & hspace_attr) ^= hspace_attr
	      then
	        do;
		if res_attr & unscaled_attr
		then temp_num = 7200 * divide (temp_num, 1000, 31, 10);
		else if res_attr & vspace_attr
		then temp_num = 7200 * divide (temp_num, 12000, 31, 10);
		else temp_num = 7200 * temp_num;
	        end;

	      if length (FuncRes) = 0 /* nothing to measure */
	      then temp_num = 0;

	      else
	        do;
		font_ref =
		     current_parms.fntstk
		     .entry (current_parms.fntstk.index);
		unspec (meas1) = "0"b;
		call comp_measure_ (FuncRes, addr (font_ref), "1"b, "0"b,
		     "0"b, temp_num, addr (meas1), addr (meas2), info_ptr);
		temp_num = 1000 * meas1.chrct;
	        end;
	      temp_typ = NUM;
	      goto push_temp;	/* SUCCESS */
	    end;

	  else goto unk_func;	/* treat as a decimal */
	end;
      end;			/**/
				/* get corresponding precedence  */
    oprec = substr (proc_ctl.prec, op_typ, 1);

/*      call			/* quantum level debugging */
/*         ioa_ ("^-^i:^i ""^1a"" ^i (^1a)", start, length (buffer),
/*         substr (buffer, start, 1), op_typ, oprec);*/

    if oprec = "s"			/* "skip" character */
    then goto parse_loop;

    if oprec = "x"			/* type "x", handles ^= <= >= */
    then
      do;
        if (substr (buffer, start + 1, 1) = "=")
        then
	do;
	  start = start + 1;
	  op_typ = op_typ + 1;
	end;
        else if index (substr (buffer, start), "^|") = 1
        then
	do;
	  start = start + 1;
	  op_typ = op_typ + 2;
	end;
        op_typ = op_typ + 1;
      end;

    else if oprec = "y"		/* type "y", handles EXOR      */
    then
      do;
        if index (substr (buffer, start), "=_") = 1
        then
	do;
	  start = start + 2;
	  op_typ = op_typ + 2;
	end;
        else op_typ = op_typ + 1;
      end;

unk_func:
    if op_typ < DIGIT
    then
      do;
        if search (substr (buffer, start), "TF") = 1
        then op_typ = STRING;
        else op_typ = DIGIT;		/* any digit gets type DIGIT */
      end;			/**/
				/* in case it changed      */
    oprec = substr (proc_ctl.prec, op_typ, 1);

/*        call
/*	ioa_ ("^8x@ ^a^a", substr (proc_ctl.type, op_typ, 1),
/*	substr (proc_ctl.dspl_sfx, op_typ, 1)); */

    if op_typ < 17			/* these need special handling */
    then goto operand (op_typ);

try_again:
    ot = curop.typ;			/* the stacked operand type	       */
    opnd_need = substr (proc_ctl.ops_need, ot, 1);
				/* get operand counter	       */

    if (oprec > curop.prec)		/* if this has greater precedence    */
    then
      do;				/* then it goes in on top	       */
        if opnd_need = "2"		/* need 2 operands		       */
	   & opstk.val_typ (depth - 1) = NONE
				/*  but first one isnt there	       */
        then
	do;
	  msg = "1st operand missing. ";
	  op2 = substr (proc_ctl.type, op_typ, 1)
	       || substr (proc_ctl.dspl_sfx, op_typ, 1);
	  goto prt_err2;
	end;
        goto push_op_typ;
      end;

    if opnd_need = "1"		/* need 1 operand		       */
    then
      do;
        if (curop.val_typ = NONE)	/*   NOT THERE!		       */
        then
	do;
	  msg = "Operand missing. ";
	  goto prt_err1;
	end;

        if opstk.val_typ (depth - 1) ^= NONE
				/* orphan operand in front	       */
        then
	do;
	  msg = "Used as binary operator. ";
	  goto prt_err1;
	end;
      end;

    else if opnd_need = "2"		/* need 2 operands		       */
    then
      do;
        if curop.val_typ = NONE
        then
	do;
	  msg = "2nd operand missing. ";
check_for_unary_op:			/* wait a minute! is it unary?       */
	  if (substr (proc_ctl.ops_need, op_typ, 1) = "3")
				/* yes it is	       */
	  then
	    do;
	      oprec = "9";		/* promote it and push it	       */
	      goto push_op_typ;
	    end;
prt_err1:
	  op2 = "";
prt_err2:
	  op1 = substr (proc_ctl.type, ot, 1)
	       || substr (proc_ctl.dspl_sfx, ot, 1);
prt_err:
	  call comp_report_ (2, 0, msg || op1 || op2, info_ptr, buffer);
	  goto err_return;
	end;

        if opstk.val_typ (depth - 1) = NONE
        then
	do;
	  msg = "1st operand missing. ";
	  goto prt_err1;
	end;
      end;

    else if opnd_need = "3"		/* either 1 or 2 operands	       */
    then
      do;
        if curop.val_typ = NONE	/* if only 1 it must be AFTER	       */
        then
	do;
	  msg = "Missing operand. ";
	  goto check_for_unary_op;
	end;
      end;

    goto type (curop.typ);		/* we can actually do the operation  */

operand (11):			/* decimal value		       */
    temp_num = comp_read_$number (buffer, scale, start, start, info_ptr, ercd);
    if ercd ^= 0
    then goto err_return;

    temp_typ = NUM;
    start = start - 1;		/* an increment will follow and it   */
				/*  was left on first char not used  */
push_temp:
    if (curop.val_typ ^= NONE)	/* 2 operands in a row	       */
    then
      do;
        op1, op2 = "";
        msg = "Operator missing. ";
        goto prt_err;
      end;

    if temp_typ = STR
    then call aloc_str (depth);
    else
      do;
        curop.num_val = temp_num;
        curop.log_val = temp_log;
      end;

    curop.val_typ = temp_typ;

    if detail
    then call dumper (" v>", depth);
    bufpos = start;

    if (op_typ > 15)		/* if an operator is still pending   */
    then goto try_again;
    goto parse_loop;

operand (12):			/* octal value		       */
    temp_num = 0;
    j = 1;
    do i = start by 1 while (j ^< 0);
      start = start + 1;
      j = index ("01234567", substr (buffer, start, 1)) - 1;
      if (j >= 0)
      then temp_num = temp_num * 8 + j * 1000;
    end;
    temp_typ = NUM;
    goto push_temp;

operand (13):			/* string value */
    if start > length (buffer)
    then
      do;
        msg = "String syntax error. ";
        op1, op2 = "";
        goto prt_err;
      end;

    temp_str = "";
    do while (start <= length (buffer) & substr (buffer, start, 1) = """");
      temp_str =
	 temp_str
	 || comp_extr_str_ ("0"b, buffer, start, start, 0, info_ptr);
      if start = 0
      then goto err_return;		/* something was wrong */

      if start < length (buffer)
      then start = start - 1 + verify (substr (buffer, start), " ");
    end;

    if start < length (buffer)	/* UNLESS its all used up...	       */
         | (start = length (buffer)) & (substr (buffer, start, 1) ^= """")
    then start = start - 1;		/* we must step back 1 because       */
				/*  parse_loop is going to move      */
				/*  ahead one		       */
    temp_typ = STR;
    goto push_temp;

operand (16):			/* "(" is ALWAYS pushed	       */
    oprec = "1";			/* everyone allowed to push on top   */
    goto push_op_typ;		/* of this		       */

operand (14):			/* T logic key */
    temp_log = ON;
    temp_typ = LOG;
    goto push_temp;

operand (15):			/* F logic key */
    temp_log = OFF;
    temp_typ = LOG;
    goto push_temp;

type (17):
type (20):
type (24):
type (27):
    signal condition (prog_err);
    goto err_return;
    dcl prog_err	   condition;

type (16):			/* "("			       */
    if (op_typ ^= RtP)		/* ")"			       */
    then
      do;
        msg = "Missing right parenthesis. ";
        ot = op_typ;
        goto prt_err1;
      end;
    temp_typ = curop.val_typ;		/**/
				/* pull the result from stack	       */
    if temp_typ = LOG		/* logical value */
    then
      do;
        temp_log = curop.log_val;

/*        op_typ = DIGIT;*/
      end;

    if temp_typ = NUM		/* numeric value */
    then
      do;
        temp_num = curop.num_val;
        op_typ = DIGIT;
      end;

    else				/* string value */
      do;
        temp_str = substr (strs, curop.str_val.ofst, curop.str_val.len);
        op_typ = STRING;
      end;

    goto pop_op;

type (18):			/* "=" equal */
    call rel_vt (depth - 1, depth);
    temp_typ = LOG;

    if curop.val_typ = LOG
    then temp_log = (prvop.log_val = curop.log_val);

    else if curop.val_typ = NUM
    then temp_log = (prvop.num_val = curop.num_val);

    else temp_log =
	    (substr (strs, prvop.str_val.ofst, prvop.str_val.len)
	    = substr (strs, curop.str_val.ofst, curop.str_val.len));

pop_op:
    if detail
    then
      do;
        call dumper ("<ov", depth);
        call dumper ("< v", depth - 1);
      end;

    call free_str (depth);
    depth = depth - 1;
    curop_ptr = addr (opstk.e (depth));
    if depth > 1
    then prvop_ptr = addr (opstk.e (depth - 1));
    call free_str (depth);
    curop.val_typ = NONE;		/* clean out old operand	       */
    goto push_temp;

type (23):
type (19):			/* XOR			       */
    call log_vt (depth - 1, depth);
    if (curop.val_typ ^= STR)
    then
      do;
        if (opstk.num_val (depth - 1) = 0) = (curop.num_val = 0)
        then temp_log = OFF;
        else temp_log = ON;
        temp_typ = LOG;
      end;
    else
      do;
        unspec (temp_str) =
	   bool (
	   unspec (
	   substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))),
	   unspec (substr (strs, curop.str_val.ofst, curop.str_val.len)),
	   "0110"b);
        temp_typ = STR;
      end;
    goto pop_op;

type (21):			/* "^"			       */
    if (curop.val_typ ^= STR)
    then
      do;
        if (curop.num_val ^= 0)
        then temp_log = OFF;
        else temp_log = ON;
        temp_typ = LOG;
      end;
    else
      do;
        unspec (temp_str) =
	   bool ("0"b,
	   unspec (substr (strs, curop.str_val.ofst, curop.str_val.len)),
	   "1010"b);
        temp_typ = STR;
      end;
    goto pop_op;

type (22):			/* "^="			       */
    call rel_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if curop.val_typ = LOG
    then
      do;
        if prvop.log_val ^= curop.log_val
        then temp_log = ON;
      end;

    else if curop.val_typ = NUM
    then
      do;
        if prvop.num_val ^= curop.num_val
        then temp_log = ON;
      end;

    else
      do;
        if substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))
	   ^= substr (strs, curop.str_val.ofst, curop.str_val.len)
        then temp_log = ON;
      end;

    goto pop_op;

type (25):			/* "<"			       */
    call rel_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if (curop.val_typ ^= STR)
    then
      do;
        if (opstk.num_val (depth - 1) < curop.num_val)
        then temp_log = ON;
      end;
    else
      do;
        if (substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))
	   < substr (strs, curop.str_val.ofst, curop.str_val.len))
        then temp_log = ON;
      end;

    goto pop_op;

type (26):			/* "<="			       */
    call rel_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if (curop.val_typ ^= STR)
    then
      do;
        if (opstk.num_val (depth - 1) <= curop.num_val)
        then temp_log = ON;
      end;
    else
      do;
        if (substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))
	   <= substr (strs, curop.str_val.ofst, curop.str_val.len))
        then temp_log = ON;
      end;

    goto pop_op;

type (28):			/* ">"			       */
    call rel_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if (curop.val_typ ^= STR)
    then
      do;
        if (opstk.num_val (depth - 1) > curop.num_val)
        then temp_log = ON;
      end;
    else
      do;
        if (substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))
	   > substr (strs, curop.str_val.ofst, curop.str_val.len))
        then temp_log = ON;
      end;

    goto pop_op;

type (29):			/* ">="			       */
    call rel_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if (curop.val_typ ^= STR)
    then
      do;
        if (opstk.num_val (depth - 1) >= curop.num_val)
        then temp_log = ON;
      end;
    else
      do;
        if (substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))
	   >= substr (strs, curop.str_val.ofst, curop.str_val.len))
        then temp_log = ON;
      end;

    goto pop_op;

type (30):			/* "+"			       */
    call force_vt (depth - 1, depth, NUM);
    if (opstk.val_typ (depth - 1) = NUM)/* binary flavor		       */
    then temp_num = opstk.num_val (depth - 1) + curop.num_val;
    else temp_num = curop.num_val;
    temp_typ = NUM;
    goto pop_op;

type (31):			/* "-"			       */
    call force_vt (depth - 1, depth, NUM);
    if (opstk.val_typ (depth - 1) = NUM)/* binary flavor		       */
    then temp_num = opstk.num_val (depth - 1) - curop.num_val;
    else temp_num = -curop.num_val;
    temp_typ = NUM;
    goto pop_op;

type (32):			/* "*"			       */
    call force_vt (depth - 1, depth, NUM);
    fb71 = opstk.num_val (depth - 1) * curop.num_val;
    temp_num = divide (fb71, 1000, 71, 10);
				/*      temp_num = divide (opstk.num_val (depth - 1) * curop.num_val, 1000, 31, 10);*/
    temp_typ = NUM;
    goto pop_op;

type (33):			/* "/"			       */
    call force_vt (depth - 1, depth, NUM);
    temp_num =
         divide (1000 * opstk.num_val (depth - 1), curop.num_val, 31, 10);
    temp_typ = NUM;
    goto pop_op;

type (34):			/* "\"			       */
    call force_vt (depth - 1, depth, NUM);
    temp_num = mod (opstk.num_val (depth - 1), curop.num_val);
    temp_typ = NUM;
    goto pop_op;

type (35):			/* "&" - AND */
    call log_vt (depth - 1, depth);
    temp_log = OFF;
    temp_typ = LOG;

    if curop.val_typ = LOG		/* logical values */
    then if prvop.log_val & curop.log_val
         then temp_log = ON;
         else ;

    else if curop.val_typ = NUM	/* numeric values */
    then if prvop.num_val ^= 0 & curop.num_val ^= 0
         then temp_log = ON;
         else ;

    else				/* string values */
      do;
        unspec (temp_str) =
	   bool (
	   unspec (
	   substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))),
	   unspec (substr (strs, curop.str_val.ofst, curop.str_val.len)),
	   "0001"b);
        temp_typ = STR;
      end;

    goto pop_op;

type (36):			/* "|" = OR */
    call log_vt (depth - 1, depth);

    if curop.val_typ ^= STR		/* logicals or numerics */
    then
      do;
        temp_typ = LOG;

        if curop.val_typ = LOG
        then temp_log = prvop.log_val | curop.log_val;

        else if curop.val_typ = NUM
        then if prvop.num_val ^= 0 | curop.num_val ^= 0
	   then temp_log = ON;
	   else temp_log = OFF;
      end;

    else				/* strings */
      do;
        temp_typ = STR;
        unspec (temp_str) =
	   bool (
	   unspec (
	   substr (strs, opstk.str_val.ofst (depth - 1),
	   opstk.str_val.len (depth - 1))),
	   unspec (substr (strs, curop.str_val.ofst, curop.str_val.len)),
	   "0111"b);
      end;

    goto pop_op;

type (37):			/* "<<"	got all the way back to    */
    goto return_;			/*  begin-expression, time to stop   */
%page;
err_return:
    opstk.num_val (1) = 0;		/* force zero result */
    opstk.val_typ (1) = NUM;
    start = length (buffer) + 1;	/* indicate we've already squawked */
    ercd = -1;

return_:
    restyp = opstk.val_typ (1);

    if restyp ^= needtyp & needtyp > 0
    then
      do;
        call force_vt (1, 1, needtyp);
        restyp = needtyp;
      end;

    resnum = opstk.num_val (1);
    reslog = opstk.log_val (1);

    if restyp = STR
    then
      do;
        resstr = substr (strs, opstk.str_val.ofst (1), opstk.str_val.len (1));
        res_attr = string_attr;
      end;
    else resstr = "";

    if restyp = LOG
    then res_attr = flag_attr;

    else
      do;
        if res_attr = ""b
        then
	do;
	  res_attr = numeric_attr | unscaled_attr;
	  num_val_key = "unscaled";
	end;
        else num_val_key = "sclnum";
      end;

    if debug
    then call ioa_ ("^5x(expr_eval) ^[logical ^[T^;F^]^;"
	    || "^snumeric ^f ^a ^a^;^3sstring ""^a""^]", restyp, reslog,
	    resnum, num_val_key, comp_util_$display (resstr, 0, "0"b));
    return;

    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

    dcl db_sw	   bit (1) static init ("0"b);
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;
%page;
aloc_str:
  proc (which);

    dcl which	   fixed bin;

    if (length (strs) < strse + length (temp_str))
    then
      do;
        call comp_report_ (2, 0, "String expression too large", info_ptr,
	   buffer);
        goto err_return;
      end;
    substr (strs, strse, length (temp_str)) = temp_str;
    opstk.str_val.ofst (which) = strse;
    opstk.str_val.len (which) = length (temp_str);
    strse = strse + length (temp_str);
    strsu = strsu + length (temp_str);

  end aloc_str;
%skip (4);
free_str:
  proc (which);

    dcl which	   fixed bin;

    if (opstk.val_typ (which) ^= STR)
    then return;
    strse = max (strse, opstk.str_val.ofst (which));
				/* just in case not      */
				/*  freed in reverse order	       */
    strsu = strsu - opstk.str_val.len (which);
				/* account for unused space    */
    if (strsu = 0)			/* if nothing in use, we can start   */
    then strse = 1;			/*  over again.		       */

  end free_str;
%page;
rel_vt:
  proc (a1, a2);

    dcl (a1, a2)	   fixed bin;
    dcl typ	   fixed bin;

    dcl res	   fixed bin;
    dcl i		   fixed bin;
    dcl vtyp	   (1:3) char (3) int static init ("LOG", "NUM", "STR");
    dcl (vt1, vt2)	   fixed bin;

    if (opstk.val_typ (a1) = opstk.val_typ (a2))
    then return;
    res = max (opstk.val_typ (a1), opstk.val_typ (a2));
    goto common;

log_vt:
  entry (a1, a2);

    vt1 = opstk.val_typ (a1);
    vt2 = opstk.val_typ (a2);
    if (vt1 = vt2)
    then return;
    if (vt1 = STR) | (vt2 = STR)
    then
      do;
        call comp_report_ (2, 0,
	   vtyp (vt1) || "/" || vtyp (vt2)
	   || " conversion not defined in a logical context.", info_ptr,
	   buffer);
        goto err_return;
      end;
    res = LOG;
    goto common;

force_vt:
  entry (a1, a2, typ);		/* force two entries to be same type */

    res = typ;

common:
    do i = a1, a2;			/* for each of the entries */
      if opstk.val_typ (i) ^= NONE	/* if it has a type */
	 & opstk.val_typ (i) ^= res	/* and its not the one we want */
      then
        do;			/* do the necssary conversion */
	goto rtn (3 * (opstk.val_typ (i) - 1) + (res - 1));

rtn (3):				/* 2,1 NUM=>LOG */
	if opstk.num_val (i) ^= 0	/* if nonzero -- */
	then opstk.log_val (i) = ON;
	else opstk.log_val (i) = OFF;
	opstk.val_typ (i) = LOG;
	goto done_cv;

rtn (2):				/* 1,3 LOG=>STR */
	if opstk.log_val (i)
	then temp_str = "T";
	else temp_str = "F";
	call aloc_str (i);
	goto done_cv;

rtn (5):				/* 2,3 NUM=>STR */
	temp_str = comp_util_$num_display (addr (opstk.num_val (i)), 0);
	call aloc_str (i);
	goto done_cv;

rtn (6):				/* 3,1 STR=>LOG */
	if opstk.str_val.len (i) > 0	/* if nonnull -- */
	then opstk.log_val (i) = ON;
	else opstk.log_val (i) = OFF;
	opstk.val_typ (i) = LOG;
	goto done_cv;

rtn (7):				/* 3,2 STR=>NUM */
	temp_str =
	     substr (strs, opstk.str_val.ofst (i), opstk.str_val.len (i));
	opstk.num_val (i) =
	     comp_read_$number (temp_str, scale, 1, 0, info_ptr, 0);
	goto done_cv;

rtn (1):				/* 1,2 LOG=>NUM */
	if opstk.log_val (i)
	then opstk.num_val (i) = -1;
	else opstk.num_val (i) = 0;

rtn (0):				/* 1,1 LOG=>LOG */
rtn (4):				/* 2,2 NUM=>NUM */
rtn (8):				/* 3,3 STR=>STR */
done_cv:
	opstk.val_typ (i) = res;
        end;
    end;
  end rel_vt;
%page;
dumper:				/* display stack actions */
  proc (action, which);

    dcl action	   char (3),	/* stack action wanted */
        which	   fixed bin;	/* depth of stack box to display */

    dcl dmpstk_ptr	   ptr;		/* stack box to display */
    dcl 1 dmpstk	   like opstk.e based (dmpstk_ptr);

    dmpstk_ptr = addr (opstk.e (which));/* stack info */
    call ioa_$nnl ("  ^a ^2i ^1a^1a ^1a ", action, which,
         substr (proc_ctl.type, dmpstk.typ, 1),
         substr (proc_ctl.dspl_sfx, dmpstk.typ, 1), dmpstk.prec);

    if dmpstk.val_typ = LOG		/* logical values */
    then call ioa_$nnl ("L ^[T^;F^]", dmpstk.log_val);

    else if dmpstk.val_typ = NUM	/* numeric values */
    then call ioa_$nnl ("N ^f", dmpstk.num_val);

    else if dmpstk.val_typ = STR	/* string values */
    then call ioa_$nnl ("S ""^a""",
	    substr (strs, dmpstk.str_val.ofst, dmpstk.str_val.len));

    if substr (action, 2, 1) = ">"
    then call ioa_ (" at buffer (^d)", bufpos);
    else call ioa_ ("");

  end dumper;
%page;
%include comp_entries;
%include comp_fntstk;
%include comp_page;
%include comp_shared;
%include comp_text;
%include comp_varattrs;
%include compstat;

  end comp_expr_eval_;




		    comp_extr_str_.pl1              04/23/85  1059.2rew 04/23/85  0909.1       66915



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

/* compose subroutine to extract character strings */

/* format: style2,ind3,ll79,dclind4,idind15,comcol41,linecom */

comp_extr_str_:
   proc (reduce, buffer, pmstart, pmnext, flen, info_ptr)
        returns (char (*) varying);

/* PARAMETERS */

      dcl reduce	     bit (1);	/* escape reduction flag
				   0 = raw, 1 = reduced */
				/* buffer from which to extract */
      dcl buffer	     char (*) varying;
      dcl pmstart	     fixed bin (21);/* starting character in buffer */
      dcl pmnext	     fixed bin (21);/* next character in buffer */
      dcl flen	     fixed bin (21);/* length of string extracted */
      dcl info_ptr	     ptr;		/* info structure for buffer */
      dcl 1 bufinfo	     like text_entry.info based (info_ptr);

/* LOCAL STORAGE */

      dcl buflen	     fixed bin (21);/* length of the buffered string */
				/* replacement character */
      dcl char	     char (1) init ("");
      dcl char_index     fixed bin;	/* collating index for *cnnn */
				/* escaped copy of buffer */
      dcl escval	     char (1020) varying;
      dcl given_len	     fixed bin (31);/* given substring length, if any */
      dcl given_strt     fixed bin (31);/* given substring start, if any */
				/* working index */
      dcl (i, j, k)	     fixed bin init (1);
				/* working string length */
      dcl len	     fixed bin init (1);
      dcl NUM	     fixed bin static options (constant) init (2);
      dcl null_result    bit (1);
      dcl mode	     fixed bin (35);/* conversion mode for *cnnn */
      dcl qt_pos	     fixed bin;	/* position of closing quote */
      dcl start	     fixed bin (21);/* local string start value */
      dcl sub_len	     fixed bin;	/* length of substring */
      dcl sub_strt	     fixed bin;	/* start of substring */
				/* value to be returned */
      dcl value	     char (1020) varying;

      dcl (collate9, index, length, min, null)
		     builtin;

      dcl comp_error_table_$missing_delimiter
		     ext fixed bin (35);

      buflen = length (buffer);
      null_result = "0"b;		/* not so far, anyway	       */

      if shared.bug_mode
      then call ioa_ ("extr_str: (^d,^d) ^a", pmstart, buflen - pmstart + 1,
	      comp_util_$display (substr (buffer, pmstart), 0, "0"b));
				/* if not quoted */
      if substr (buffer, pmstart, 1) ^= """"
      then
         do;			/* return the raw string */
	  value = substr (buffer, pmstart);
	  pmnext = length (buffer) + 1;
	  flen = length (value);
	  goto return_;
         end;			/**/
				/* it is quoted */
      value, escval = buffer;		/* copy the string */
      if reduce & index (escval, "*") ^= 0
      then call comp_util_$escape (escval, info_ptr);
      qt_pos = 1;
      start = pmstart;

qt_scan_2:			/* look for a closer */
      i = index (substr (value, start + qt_pos), """");

      if i = 0			/* if no quote found */
      then
         do;
	  call comp_report_$ctlstr (2, comp_error_table_$missing_delimiter,
	       info_ptr, buffer, "No closing quote for ""^a""",
	       substr (value, start));
	  value = substr (value, start + 1);
	  pmnext = length (buffer) + 1;
	  flen = length (value);
	  goto return_;		/* return with what we have */
         end;			/**/
				/* is it escaped? */
      if substr (value, start + qt_pos + i - 2, 1) = "*"
      then if start + qt_pos + i > 3	/* not \277*" OR **" */
	 then if ^(substr (escval, start + qt_pos + i - 3, 2) = "ż*"
		 | substr (escval, start + qt_pos + i - 3, 2) = "**")
	      then
	         do;		/* step over the quote */
		  qt_pos = qt_pos + i;
		  goto qt_scan_2;	/* and look for another */
	         end;		/**/
				/* this is the closing quote */
	      else qt_pos = start + qt_pos + i - 1;
	 else qt_pos = start + qt_pos + i - 1;
      else qt_pos = start + qt_pos + i - 1;

      sub_strt = start + 1;		/* start of given string */
      sub_len = qt_pos - sub_strt;	/* end of given string */

      start = sub_strt + sub_len + 1;	/* see what follows the closer */

      if start < buflen & substr (value, start, 1) = "("
      then
         do;			/* if its a substr expression */
	  start = start + 1;	/* step over the paren */
	  call comp_expr_eval_ (value, start, info_ptr, NUM, 0, "0"b,
	       given_strt, "", "0"b, 0);
	  given_strt = divide (given_strt, 1000, 31, 0);

	  if start = 0		/* something was wrong */
	  then
	     do;
	        pmstart = 0;
	        goto return_;
	     end;

	  if given_strt < 0		/* if "-i" form */
	  then
	     do;
	        given_strt =	/* back up from end of string */
		   sub_len + given_strt + 1;

	        if given_strt <= 0	/* if before given string */
	        then
		 do;
		    call comp_report_ (2, 0,
		         "Substring starts before given string.", info_ptr,
		         buffer);
		    pmstart = 0;
		    goto return_;
		 end;
	     end;

	  if given_strt > sub_len	/* if after given string */
	  then null_result = "1"b;	/* will give back null string	       */
				/* but we must still finish parsing  */

	  if substr (value, start, 1) = ","
				/* if ",k" form */
	  then
	     do;
	        start = start + 1;	/* step over the comma */
	        call comp_expr_eval_ (value, start, info_ptr, NUM, 0, "0"b,
		   given_len, "", "0"b, 0);
	        given_len = divide (given_len, 1000, 31, 0);

	        if start = 0	/* something was wrong */
	        then
		 do;
		    pmstart = 0;
		    goto return_;
		 end;

	        if given_len < 0	/* if ",-k" form */
	        then
		 do;
		    sub_len = sub_len - given_strt + given_len + 2;
				/* adjust substr length	       */

		    if sub_len < 0 & ^null_result
				/* dont complain of we already know  */
				/* there is "nothing" there	       */
		    then
		       do;
			call comp_report_ (2, 0,
			     "Negative substring length.", info_ptr,
			     buffer);
			pmstart = 0;
			goto return_;
		       end;
		 end;

	        else sub_len = min (sub_len, given_len);
	     end;

	  else sub_len = sub_len - given_strt + 1;

	  sub_strt = sub_strt + given_strt - 1;
				/* check for closer */
	  if substr (value, start, 1) ^= ")"
	  then
	     do;
	        call comp_report_ (2, 0, "Missing right parenthesis",
		   info_ptr, buffer);
	        pmstart = 0;
	        goto return_;
	     end;
	  else start = start + 1;	/* else step over it */
         end;

      if null_result		/* set final result */
      then
         do;
	  value = "";
	  flen = 0;
	  pmnext = start;
	  goto return_;
         end;			/**/
				/* final output string */
      if reduce & index (value, "*") ^= 0
      then call comp_util_$escape (value, info_ptr);
      value = substr (value, sub_strt, sub_len);
      pmnext = start;
      flen = length (value);

return_:
      if shared.bug_mode
      then call ioa_ ("^5x(extr_str) (^d) ^a", flen,
	      comp_util_$display (value, 0, "0"b));

      return (value);
%page;
%include comp_entries;
%include comp_fntstk;
%include comp_shared;
%include comp_text;
%include compstat;

   end comp_extr_str_;




		    comp_fill_.pl1                  04/23/85  1059.2rew 04/23/85  0909.3      151335



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

/*	compose subroutine to fill lines to current line length	*/

/**** format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_fill_:
  proc;

/* LOCAL STORAGE */

    dcl dc1_ndx	   fixed bin;	/* index of DC1 char */
    dcl GAPs	   char (4);	/* word delimiters */
    dcl i		   fixed bin;	/* working index */
				/* hyphenation point index */
				/* for text measuring */
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl minwsp	   fixed bin;	/* strokes for current min WSP */
    dcl revstr	   char (1020) var; /* reverse of text.input_line */
    dcl re_fill	   bit (1);
    dcl scndx	   fixed bin;	/* line scan index */
    dcl usable	   fixed bin (31);	/* net line width */

    dcl (index, length, max, min, null, substr, translate, verify)
		   builtin;

/* initialize local variables */
    unspec (meas2), re_fill = "0"b;
    GAPs = " " || EN || PS || PAD;
    tblfmtndx, tblcolndx = 0;
    tblfmtptr, tblcolptr = null;

    if shared.table_mode
    then
      do;
        tblfmtndx = tbldata.ndx;
        tblfmtptr = tbldata.fmt (tblfmtndx).ptr;
        tblcolndx = tblfmt.ccol;
        tblcolptr = tblfmt.colptr (tblfmt.ccol);
      end;

/* set up for a fresh line */
    if text.input_line = ""
    then
      do;
        i = verify (ctl_line, " ") - 1; /* check for leading WS */
        if i > 0			/* if any, convert to undent */
        then text.parms.left.undent =
	        text.parms.left.undent - i * shared.EN_width;
        ctl_line = ltrim (ctl_line);

        text.input.info = ctl.info;
        text.input.keep = text.parms.keep;
        text.input.quad = text.parms.quad;
        text.input.und_prot = "0"b;
/****        text.input.hanging = ctl.hanging;
/****        ctl.hanging = "0"b;*/
        text.input.linespace = ctl.linespace;
        text.input.fnt_chng = ctl.fnt_chng;
        unspec (text.input.cur) = "0"b;
        text.input.font, text.input.cur.font = ctl.font;
      end;

    text.input.lmarg = text.parms.left.indent - text.parms.left.undent;
    text.input.rmarg =
         text.parms.measure - text.parms.right.indent
         + text.parms.right.undent;

    if shared.table_mode & ^text.parms.footnote
    then
      do;
        text.input.lmarg = text.input.lmarg + tblcol.margin.left;
        text.input.rmarg = text.input.rmarg + tblcol.margin.left;
      end;

    text.input.net, usable = text.input.rmarg - text.input.lmarg;

    if ^(ctl.fnt_chng | ctl.footref)	/* if not a font change or ftn ref */
    then
      do;				/* does it end in a ctl str? */
        scndx = length (ctl_line);
look_again:
        dc1_ndx = index (reverse (substr (ctl_line, 1, scndx)), DC1);
        if dc1_ndx > 0		/* is there a DC1? */
        then
	do;
	  if dc1_ndx < 3
	  then
	    do;			/* back up */
	      scndx = scndx - dc1_ndx - 1;
	      goto look_again;	/* and try again */
	    end;			/**/
				/* the DC1 byte plus length byte value */
	  scndx = length (ctl_line) - dc1_ndx + 1;
	  scndx = scndx + 3 + bin (unspec (substr (ctl_line, scndx + 2, 1)));
	  if scndx < length (ctl_line)
	  then ctl_line = rtrim (ctl_line);
	end;

        else ctl_line = rtrim (ctl_line);
      end;

    if shared.bug_mode
    then
      do;
        call ioa_ ("fill: (lin=^f/^f/^f ^a=^d e^d u^f(^f))",
	   show (text.input.lmarg, 12000), show (text.input.rmarg, 12000),
	   show (usable, 12000), text.blktype, text.blkndx, text.hdr.count,
	   show (text.hdr.used, 12000), show (text.hdr.trl_ws, 12000));

        call ioa_ ("^-(lft=c^d w^f g^d ^f^2(/^f^)^[ ftn=^d/^f^;^2s^]"
	   || " ^a ^f^[ mod=^d ^d^;^2s^]"
	   || "^[ PUNC^]^[ FRF^]^[ FCS^]^[ UNSR^]"
	   || "^[ UNSP^]^[ A^]^[ |^]^[ *^])^/^5x""^a""", text.input.chrct,
	   show (text.input.width, 12000), text.input.cur.gaps,
	   show (text.input.cur.width + text.input.cur.min, 12000),
	   show (text.input.cur.width + text.input.cur.avg, 12000),
	   show (text.input.cur.width + text.input.cur.max, 12000),
	   (text.input.ftn.ct > 0), text.input.ftn.ct,
	   show (text.input.ftn.used, 12000), text.input.font.name,
	   show (text.input.font.size, 1000), (text.input.mod_start > 0),
	   text.input.mod_start, text.input.mod_len, text.input.punct,
	   text.input.footref, text.input.fnt_chng, text.input.unstrt,
	   text.input.unstop, text.input.art,
	   (text.input.cbar.mod | text.input.cbar.add), text.input.cbar.del,
	   comp_util_$display (text.input_line, 0, "0"b));

        call ioa_ ("^-(new=c^d ^a ^f^[ FRF^]^[ FCS^]"
	   || "^[ UNSR^]^[ UNSP^]^[ A^]^[ |^]^[ *^])^/^5x""^a""",
	   length (ctl_line), ctl.font.name, show (ctl.font.size, 1000),
	   ctl.footref, ctl.fnt_chng, ctl.unstrt, ctl.unstop, text.parms.art,
	   (text.input.cbar.mod | text.input.cbar.add), text.input.cbar.del,
	   comp_util_$display (ctl_line, 0, "0"b));
      end;

    if usable <= 0			/* if the line cant be filled */
    then
      do;
        call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
	   "Net line length is ^f", show (usable, 12000));
        goto return_;
      end;			/**/
				/* set start of line scan */
    scndx = length (text.input_line) + 1;

/* any leftover text?  anything to be added ? */
    if length (text.input_line) > 0 & length (ctl_line) > 0
    then
      do;
        revstr = reverse (text.input_line);

        if ^text.input.footref	/* if leftover doesnt end */
        then			/* with footref */
	do;
	  if text.input.punct	/* and it ends with punctuation */
	       | (search (revstr, ".:!?") = 1
	       | (search (revstr, """)") = 1 & search (revstr, ".!?") = 2))
	  then
	    do;
	      if ^(ctl.footref	/* if addon is not a footref */
		 | ctl.unstop)	/* or UNSTOP, */
	      then		/* add PS and WORDSPACE */
	        do;
		text.input_line = text.input_line || PS || " ";
		text.input.punct, text.input.footref = "0"b;
	        end;		/**/
				/* set flag for next time */
	      else text.input.punct = "1"b;
	    end;			/* otherwise, only WORDSPACE unless */
				/* leftover ends with PAD, */
	  else if index (revstr, PAD) ^= 1 & ^text.input.unstrt
				/* UNSTRT, */
				/* or a word breaker, */
	       & index (revstr, shared.wrd_brkr) ^= 1
				/* or new is footref, UNSTOP, or FCS */
	       & ^(ctl.footref | ctl.unstop | ctl.fnt_chng)
	  then text.input_line = text.input_line || " ";
	end;

        else			/* leftover ends with footref */
	do;
	  if ^ctl.footref		/* new isnt a footref or starts with */
				/* closing punctuation */
	       & index (".,;:!?"")", substr (ctl_line, 1, 1)) = 0
	  then if text.input.punct	/* if left also ends with punct */
	       then
	         do;
		 text.input_line = text.input_line || PS || " ";
		 text.input.punct = "0"b;
	         end;
	       else text.input_line = text.input_line || " ";
	end;

        text.input.fnt_chng = ctl.fnt_chng;
      end;			/**/
				/* check for change bars */
    if text.parms.cbar.mod | text.parms.cbar.add
    then
      do;
        if text.input.mod_start = 0	/* if starting mod text */
        then text.input.mod_start = scndx;
        text.input.mod_len = text.input.mod_len + length (ctl_line);
      end;
    text.input.cbar.add = text.input.cbar.add | text.parms.cbar.add;
    text.input.cbar.mod = text.input.cbar.mod | text.parms.cbar.mod;
    text.input.cbar.del = text.input.cbar.del | text.parms.cbar.del;
    text.parms.cbar.del = "0"b;
    if text.input.cbar.del
    then shared.cbar_type = "";	/**/
				/* append the new text */
    text.input_line = text.input_line || ctl_line;
    text.input.art = text.input.art | text.parms.art;
    text.input.footref = ctl.footref;
    text.input.fnt_chng = text.input.fnt_chng & ctl.fnt_chng;
    text.input.unstrt = ctl.unstrt;
    text.input.unstop = ctl.unstop;
    ctl.unstrt, ctl.unstop, ctl.fnt_chng = "0"b;
				/* is this a hanging undent? */
    if text.parms.left.undent > 0 & text.input.hanging
    then
      do;				/* measure the hanger */
        call comp_measure_ (text.input_line, addr (text.input.cur.font), "0"b,
	   text.input.art, quadl, 0, addr (text.input.cur), addr (meas2),
	   addr (text.input.info));

        if text.input.cur.width + text.input.cur.avg < text.parms.left.undent
        then text.input.linespace = 0;
        else text.input.linespace = text.parms.linespace;

        text.input.quad = quadl;	/* set left */

        call put_line;
        text.input_line = "";
        text.input.width = 0;
        goto return_;
      end;

fill_loop:			/* scan the line */
    do while (text.input.cur.chrct < length (text.input_line));
				/* any undent that needs protection? */
      if text.parms.left.undent > 0 & ^text.input.und_prot
      then
        do;			/* measure up to the undent value */
	call comp_measure_ (text.input_line, addr (text.input.cur.font),
	     "0"b, text.input.art, quadl, text.parms.left.undent,
	     addr (text.input.cur), addr (meas2), addr (text.input.info));
	scndx = text.input.cur.chrct; /* update scan index */

	do i = 1 to text.input.cur.chrct;
				/* protect WS */
	  if substr (text.input_line, i, 1) = DC1
	  then			/* skip control strings */
	    do;
	      DCxx_p = addr (substr (text.input_line, i));
	      i = i + dcxx.leng + 3;
	    end;
	  else if substr (text.input_line, i, 1) = " "
	  then substr (text.input_line, i, 1) = EN;
	end;

	text.input.und_prot = "1"b;	/* undent has been protected */
        end;

      call			/* grab some text */
	 comp_measure_ (text.input_line, addr (text.input.cur.font), "1"b,
	 text.input.art, text.input.quad, usable, addr (text.input.cur),
	 addr (meas2), addr (text.input.info));
				/**/
				/* did a footref cause an overset? */
      if meas2.width + meas2.avg > usable & ctl.footref & ^re_fill
	 & text.input.cur.gaps > 0
      then
        do;			/* clear the decks */
	unspec (text.input.cur) = "0"b;
	text.input.cur.font = text.input.font;
	re_fill = "1"b;
	goto fill_loop;		/* and start over */
        end;

      if meas2.chrct > 0		/* did it overset? */
      then
        do;
	if text.input.cur.chrct = 0	/* overlength line */
	then text.input.cur = meas2;
	call put_line;
        end;

      ctl.footref, re_fill = "0"b;

      if meas2.chrct = 0		/* if no overflow */
      then			/* this is a leftover */
        do;			/* restore font */
	text.input.cur.font = text.input.font;
	goto return_;
        end;

/*      if text.input.quad ^= just	/* if not justifying */
/*	 & shared.hyph_mode		/* try hyphenation? */
/* & text.input.cur.width + text.input.cur.max < usable*/
/*      then goto try_hyph;*/

/* text.input.width = text.input.cur.width + text.input.cur.avg;*/
    end fill_loop;

return_:
    if shared.blkptr ^= null		/* clean up leftover */
    then if text.input_line ^= ""
         then
	 do;
	   text.input.width = text.input.cur.width;
	   text.input.cur.font = ctl.cur.font;
				/* check punctuation */
	   if scndx > length (text.input_line)
	   then
	     do;
	       i = length (text.input_line);
(nostrg):
	       if index (".:!?", substr (text.input_line, i, 1)) ^= 0
		  | (index (""")", substr (text.input_line, i, 1)) ^= 0
		  & index (".!?", substr (text.input_line, i - 1, 1)) ^= 0)
	       then text.input.punct = "1"b;
	       else text.input.punct = "0"b;
	     end;
	 end;

    if shared.bug_mode
    then
      do;
        if shared.end_output
        then call ioa_ ("^5x(fill: END)");

        else call ioa_ ("^5x(fill: lft=c^d w^f g^d ^f^2(/^f^)"
	        || "^[ ftn=^d/^f^;^2s^] ^a ^f^[ mod=^d ^d^;^2s^] ^a=^d e^d"
	        ||
	        " u^f(^f)^[ FRF^]^[ FCS^]^[ A^]^[ |^]^[ *^])^[^/^5x""^a""^]",
	        text.input.chrct, show (text.input.width, 12000),
	        text.input.cur.gaps,
	        show (text.input.cur.width + text.input.cur.min, 12000),
	        show (text.input.cur.width + text.input.cur.avg, 12000),
	        show (text.input.cur.width + text.input.cur.max, 12000),
	        (text.input.ftn.ct > 0), text.input.ftn.ct,
	        show (text.input.ftn.used, 12000), text.input.font.name,
	        show (text.input.font.size, 1000),
	        (text.input.mod_start > 0), text.input.mod_start,
	        text.input.mod_len, text.blktype, text.blkndx,
	        text.hdr.count, show (text.hdr.used, 12000),
	        show (text.hdr.trl_ws, 12000), text.input.footref,
	        text.input.fnt_chng, text.input.art,
	        (text.input.cbar.mod | text.input.cbar.add),
	        text.input.cbar.del, (length (text.input_line) > 0),
	        comp_util_$display (text.input_line, 0, "0"b));
      end;
    return;
%page;
/* add text line to block */

put_line:
  proc;

    dcl overset	   char (1020) var; /* overset text */

    overset = "";			/**/
				/* is there an overset? */
    if text.input.cur.chrct < length (text.input_line)
    then
      do;
        overset = substr (text.input_line, text.input.cur.chrct + 1);
        text.input_line = substr (text.input_line, 1, text.input.cur.chrct);
      end;			/**/
				/* final width */
    text.input.width = text.input.cur.width;

    if text.input.mod_start > 0
         & text.input.mod_start <= length (text.input_line)
    then text.input.cbar.mod = "1"b;
    else text.input.cbar.mod = "0"b;

    if text.input.fnt_chng
         & length (text.input_line) = length (text.input.cur.font.fcs_str)
    then text.input.linespace = 0;
    else if ^text.input.hanging
    then text.input.linespace = text.parms.linespace;

    call comp_util_$add_text (shared.blkptr, "0"b, "1"b, "0"b, text.input.oflo,
         addr (text.input));
    text.input_line = "";
    text.input.cbar = text.parms.cbar;

    if text.input.oflo & ^text.parms.keep & text.hdr.colno >= 0
         & ^shared.table_mode
    then call comp_break_ (need_break, -2);

    if shared.end_output
    then goto return_;

    if overset ^= ""		/* any leftovers? */
    then
      do;
        if shared.blkptr = null
        then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	        const.current_parms_ptr, "0"b);

        text.input_line = ltrim (rtrim (overset), PS || " ");

        text.input.mod_len =		/* update modification data */
	   min (length (text.input_line),
	   max (text.input.mod_start + text.input.mod_len
	   - length (text.input_line) - 1, 0));
        if text.input.mod_len > 0
        then text.input.mod_start = 1;
        else
	do;
	  text.input.mod_start = 0;
	  unspec (text.input.cbar) = "0"b;
	end;

        text.input.font = text.input.cur.font;
        unspec (text.input.cur) = "0"b; /* refresh scan data */
        text.input.cur.font = text.input.font;

        text.input.lmarg = text.parms.left.indent;
        text.input.rmarg = text.parms.measure - text.parms.right.indent;
        text.input.net, usable = text.input.rmarg - text.input.lmarg;

        if shared.table_mode & ^text.parms.footnote
        then
	do;
	  text.input.lmarg = text.input.lmarg + tblcol.margin.left;
	  text.input.rmarg = text.input.rmarg + tblcol.margin.left;
	end;
      end;

    else
      do;				/* all input used */
        text.input_line = "";
        text.input.chrct, text.input.mod_start, text.input.mod_len = 0;
      end;			/**/
				/* undents used */
    text.input.hanging, text.input.und_prot = "0"b;
    text.parms.left.undent, text.parms.right.undent = 0;

/****    if ^text.input.fnt_chng
/****    then col.hdr.hdspc = 0;		/* head space has been covered */
    text.input.fnt_chng = "0"b;
    text.input.ftn = text_entry.ftn;	/* footnotes cleared out */

    scndx = 1;			/* reset scan index */
    text.input.info = ctl.info;	/* update text line stuff */

    if ^shared.table_mode
    then
      do;
        text.input.lmarg = text.parms.left.indent;
        text.input.rmarg = text.parms.measure - text.parms.right.indent;
        text.input.net, usable = text.input.rmarg - text.input.lmarg;
      end;			/**/
				/* put any pictures */
    if shared.picture.count > 0 & text.blktype ^= "pi"
    then call comp_util_$pictures (shared.blkptr);

  end put_line;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_DCdata;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_metacodes;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

  end;




		    comp_font_.pl1                  04/23/85  1059.2rew 04/23/85  0909.4      124875



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

/* compose subroutine to change current font and/or point size */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_font_:
  proc (load, buffer, fcs_str);

/* PARAMETERS */

    dcl load	   bit (1);	/* ON = load the given font. */
				/*      (if buffer is null, then */
				/*       initialize the font stack */
				/*       with device defaults) */
				/* OFF = process the control info */
				/*       in buffer */
    dcl buffer	   char (*) var;	/* font change info */
    dcl fcs_str	   char (8);	/* FCS string for this font */

    fcs_str = "";			/* clear return value */
    DCFS.mark = DC1;		/* setup the font change string */
    DCFS.type = type_font;
    DCFS.leng = dcfs_len;
    init_stk, unspec (local_font) = "0"b;

    if load			/* loading a font or initing? */
    then
      do;
        if buffer = ""		/* no buffer, we're initing */
        then
	do;
	  if shared.bug_mode | db_sw & dt_sw
	  then call ioa_ ("comp_font: (init stack)");

	  init_stk = "1"b;		/**/
				/* wipe the font stack */
	  unspec (default_parms.fntstk) = "0"b;
	  default_parms.fntstk.entry.memptr,
	       default_parms.fntstk.entry.fntptr = null;
	  default_parms.fntstk.entry.fam_name,
	       default_parms.fntstk.entry.mem_name,
	       default_parms.fntstk.entry.name,
	       default_parms.fntstk.entry.fcs_str = "";
				/* need the media select table? */
	  if fnttbldata.medsel_ptr = null
	  then
	    do;
	      fnttbldata.medsel_ptr =
		 allocate (const.global_area_ptr, size (medsel));
	      medsel_table_ptr =
		 pointer (const.dvidptr, comp_dvt.medsel_table_r);
				/* load out all media select strings */
	      do i = 1 to medsel_table.count;
	        if medsel_table.ref_r (i) ^= "0"b
	        then
		do;
		  med_sel_p =
		       pointer (const.devptr, medsel_table.ref_r (i));
		  medsel (i) = substr (med_sel.str, 1, med_sel.str_l);
		end;
	        else medsel (i) = "";
	      end;
	    end;

	  istk = 0;		/* where to begin stacking */
	  default_parms.fntstk.entry (0).size = comp_dvt.init_ps;
	  local_font = default_parms.fntstk.entry (0);

	  local_font.name = "footnote";
	  call load_font;
	  footnote_parms.fntstk = default_parms.fntstk;
	  DCFS.f = local_font.devfnt;
	  DCFS.p = local_font.size;
	  local_font.fcs_str = DCFS_str;
	  footnote_parms.fntstk.entry (0) = local_font;

	  local_font.name = "text";
	  call load_font;
	  text_parms.fntstk = default_parms.fntstk;
	  DCFS.f = local_font.devfnt;
	  DCFS.p = local_font.size;
	  local_font.fcs_str = DCFS_str;
	  default_parms.fntstk.entry (0) = local_font;
	  fntstk_eptr = addr (text_parms.fntstk.entry (0));
	end;

        else			/* load the given font */
	do;
	  local_font.name = buffer;
	  call load_font;

	  if shared.bug_mode | db_sw & dt_sw
	  then call ioa_ ("comp_font: (load fnt=^d ^a ^f)",
		  local_font.devfnt, local_font.name,
		  dec (round (divide (local_font.size, 1000, 31, 11), 10),
		  11, 3));
	end;

        goto return;
      end;

/* SWITCH FONT AND/OR POINTSIZE */
    istk = current_parms.fntstk.index;	/* set current stack position */
    fntstk_eptr = addr (current_parms.fntstk.entry (istk));
    local_font = fntstk_entry;	/* make copy of stack entry in */
				/* case given data is bad and we */
				/* have to continue the current font */

    if shared.bug_mode | db_sw & dt_sw
    then call ioa_ ("comp_font: (col=^d stk=^d fnt=^d ^a ^f) ^a",
	    page.hdr.col_index, istk, fntstk_entry.devfnt, fntstk_entry.name,
	    dec (round (divide (fntstk_entry.size, 1000, 31, 11), 10), 11, 3)
	    , buffer);

    if buffer = ""			/* if no font given, then pop stack */
    then
      do;				/* back up 1 level */
        istk = current_parms.fntstk.index - 1;
        if istk < 0			/* make the stack circular */
        then istk = hbound (current_parms.fntstk.entry, 1);
				/* if nothing stacked */
        if current_parms.fntstk (istk).famndx = 0
        then
	do;
	  call comp_report_ (2, 0, "Font stack exhausted.", addr (ctl.info),
	       buffer);
error_result:
	  if load
	  then signal comp_abort;

	  if abort_sw
	  then signal font_error;

	  goto return;
	end;			/**/
				/* clear current level */
        current_parms.fntstk.famndx (current_parms.fntstk.index) = 0;
				/* and pop the stack */
        current_parms.fntstk.index = istk;
				/* point to it */
        fntstk_eptr = addr (current_parms.fntstk.entry (istk));
        local_font = fntstk_entry;	/* copy for return */
        fnttbl_ptr = fnttbldata.ptr (fntstk_entry.devfnt);
        member_ptr = fntstk_entry.memptr;

        shared.EN_width =
	   divide (local_font.size * fnttbl.units (rank (EN)),
	   fnttbl.rel_units, 31, 10);
      end;

    else
      do;				/* a font is given */
				/* push the stack  */
        istk, current_parms.fntstk.index =
	   mod (istk + 1, hbound (current_parms.fntstk.entry, 1) + 1);
				/* point to new stack entry */
        fntstk_eptr = addr (current_parms.fntstk.entry (istk));
        fntstk_entry = local_font;	/* init with current entry */
				/* we'll update it later if AOK      */
				/* parse the variable field */
        do while (buffer ^= "");	/* if field is all numeric */
	if verify (buffer, "0123456789.") = 0
	then
	  do;
	    local_font.size =
	         comp_read_$number (buffer, scale, 1, ibuf, addr (ctl.info),
	         0);
	    buffer = ltrim (substr (buffer, ibuf));
	  end;

	else			/* else its either a bachelor */
	  do;			/* or a family/member name */
				/* is there a family name? */
	    if index (buffer, "/") ^= 1
	    then
	      do;
	        local_font.fam_name =
		   comp_read_$name (buffer, 1, ibuf, addr (ctl.info));
	        buffer = ltrim (substr (buffer, ibuf));
	      end;		/**/
				/* is there a member name? */
	    if index (buffer, "/") = 1
	    then
	      do;
	        buffer = ltrim (after (buffer, rtrim (local_font.fam_name)));
	        local_font.mem_name =
		   comp_read_$name (buffer, 1, 1, addr (ctl.info));
	      end;
	    else local_font.mem_name = "";

	    local_font.name =
	         rtrim (local_font.fam_name) || rtrim (local_font.mem_name);
	  end;
        end;

        call load_font;
      end;

return:
    DCFS.f = local_font.devfnt;
    DCFS.p = local_font.size;
    local_font.fcs_str, fcs_str = DCFS_str;

    if ^load | init_stk		/* all done, replace with new data */
    then
      do;
        fntstk_entry = local_font;

        if shared.blkptr ^= null ()	/* copy change to current block */
        then
	do;
	  text.parms.fntstk.index = istk;
	  text.parms.fntstk.entry (istk) = local_font;
	  if text.input_line = ""
	  then text.input.font = local_font;
	end;

        if shared.ftn_mode		/* change footnote header, too */
        then
	do;
	  line_area_ptr = ftnhdr.line_area.cur;
	  line_area.linptr (1) -> txtlin.font = local_font;
	end;
      end;

    if shared.bug_mode | db_sw & dt_sw
    then call ioa_ ("^5x(comp_font: (^[load^s^;stk=^d^] fnt=^d ^a ^f) ^a",
	    load, istk, local_font.devfnt, local_font.name,
	    dec (round (divide (local_font.size, 1000, 31, 11), 10), 11, 3),
	    comp_util_$display ((fcs_str), 0, "0"b));

    return;

abrtn:
  entry;
    abort_sw = "1"b;
    return;
abrtf:
  entry;
    abort_sw = "0"b;
    return;
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;
%page;
load_font:			/* search for font name */
  proc;				/* first, search the fonts we have  */
				/* already loaded */
    do ifnt = 1 to fnttbldata.count
         while (fnttbldata.ptr (ifnt) -> fnttbl.name ^= local_font.name);
    end;

    if ifnt <= fnttbldata.count	/* already loaded? */
    then
      do;
        fnttbl_ptr = fnttbldata.ptr (ifnt);
        local_font = fnttbl.entry;
      end;

/* needed font is not loaded, have to search the DSM */
    else				/* first search for name as given. */
      do;				/* It may be either a LC family name */
				/* or an UC/mixed bachelor name. */
        do ifam = 1 to comp_dvt.family_ct
	   while (comp_dvt.family (ifam).name ^= local_font.name);
        end;			/**/
				/* if we didnt find it as given, */
				/* it cant be a bachelor, so */
				/* try again, forcing lowercase. */
        if ifam > comp_dvt.family_ct
        then
	do;
	  do ifam = 1 to comp_dvt.family_ct
	       while (comp_dvt.family (ifam).name
	       ^= translate (local_font.fam_name, az, AZ));
	  end;

	  if ifam > comp_dvt.family_ct
	  then			/* if we still didnt find it, */
	    do;
no_font:
	      call comp_report_$ctlstr (2, 0, addr (ctl.info), buffer,
		 "Font ^a not defined for ^a device.", local_font.name,
		 option.device);
	      goto error_result;
	    end;
	end;
        local_font.devfnt, fnttbldata.ndx, fnttbldata.count = ifnt;
				/* record family index */
        local_font.famndx = ifam;	/* point to its member table */
        member_ptr, local_font.memptr =
	   pointer (const.devptr, comp_dvt.family (ifam).member_r);

        if member (1).name = ""	/* if no members, its a bachelor */
        then
	do;
	  imem = 1;		/* force the index */
	  local_font.bachelor = "1"b;
	  local_font.mem_name = "";
	end;

        else			/* search for member */
	do;
	  local_font.bachelor = "0"b;
	  local_font.mem_name = rtrim ("/" || local_font.mem_name);
	  do imem = 1 to member.count
	       while (member (imem).name
	       ^= translate (local_font.mem_name, az, AZ));
	  end;			/**/
				/* if we didnt find it */
	  if imem > member.count
	  then goto no_font;
	end;			/**/
				/* record member index */
        local_font.memndx = imem;	/* point to the font table */
        font_ptr, local_font.fntptr =
	   pointer (const.devptr, member (imem).font_r);
				/* load the new font into pdir */
        fnttbl_ptr = allocate (const.global_area_ptr, size (fnttbl));
        fnttbldata.ptr (ifnt) = fnttbl_ptr;

        fnttbl.devfnt, fnttbl.units = 0;
        fnttbl.replptr = null ();
        fnttbl.white = "0"b;		/**/
				/* point to repl table in DSM */
        oput_p = pointer (const.devptr, font.oput_r);
				/* build the font table */
        do i = 0 to oput.data_ct;
	if oput.what_r (i) ^= "0"b
	then
	  do;
	    medchar_sel_p = pointer (const.devptr, oput.what_r (i));
	    fnttbl.replptr (i) = medchar_sel_p;
	    if medchar = ""
	    then fnttbl.white (i) = "1"b;
	    fnttbl.devfnt (i) = oput.which (i);
	  end;
        end;
        fnttbl.units = pointer (const.devptr, font.units_r) -> units;

        fnttbl.entry = local_font;
        fnttbl.rel_units = font.rel_units;
        fnttbl.min_wsp = font.min_wsp;
        fnttbl.avg_wsp = font.avg_wsp;
        fnttbl.max_wsp = font.max_wsp;	/**/
				/* load the size table */
        sizel_p = pointer (const.devptr, member (imem).size_r);
        siztbl_size = sizel.val_ct + 1;
        siztbl_ptr = allocate (const.global_area_ptr, size (siztbl_array));
        fnttbl.siztbl_ptr = siztbl_ptr; /* load the width table */
        unspec (siztbl_array) = unspec (sizel);
      end;

    sizel_p = fnttbl.siztbl_ptr;	/* validate requested size */
    if sizel.val_ct > 1
    then
      do;
        do isiz = 1 to sizel.val_ct
	   while (sizel.val (isiz) ^= local_font.size);
        end;

        if isiz > sizel.val_ct	/* if this size not in table */
        then
	do;
	  call comp_report_ (2, 0, "Invalid size for this font.",
	       addr (ctl.info), buffer);
	end;
      end;

    else local_font.size = sizel.val (1);

    shared.EN_width =
         divide (local_font.size * fnttbl.units (rank (EN)), fnttbl.rel_units,
         31, 10);
  end load_font;
%page;
/* LOCAL STORAGE */

    dcl abort_sw	   bit (1) static init ("0"b);
    dcl az	   char (26) static options (constant)
		   init ("abcdefghijklmnopqrstuvwxyz");
    dcl AZ	   char (26) static options (constant)
		   init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
    dcl BAD_CHAR	   char (1) static options (constant) init ("˙");
    dcl 1 DCFS	   like dcfs;
    dcl DCFS_str	   char (dcfs_len + 3) based (addr (DCFS));
    dcl db_sw	   bit (1) static init ("0"b);
    dcl dt_sw	   bit (1) static init ("0"b);
    dcl (i, j)	   fixed bin;	/* working index */
    dcl ibuf	   fixed bin (21);
    dcl ifam	   fixed bin;	/* local family index */
    dcl ifnt	   fixed bin;	/* fnttbldata index */
    dcl imem	   fixed bin;	/* local member index */
    dcl init_stk	   bit (1);
    dcl isiz	   fixed bin;	/* local size index */
    dcl istk	   fixed bin;	/* local stack index */
    dcl 1 local_font   aligned like fntstk_entry;
    dcl name_chars	   char (63) static options (constant)
		   init ("abcdefghijklmnopqrstuvwxyz_"
		   || "ABCDEFGHJIKLMNOPQRSTUVWXYZ0123456789");
    dcl scale	   (1) fixed bin (31) static options (constant)
		   init (1000);	/**/
				/* array for loading the size table */
    dcl siztbl_array   (siztbl_size) fixed bin (35) based (siztbl_ptr);
    dcl siztbl_ptr	   ptr;
    dcl siztbl_size	   fixed bin;

    dcl (comp_abort, font_error)
		   condition;

    dcl (addr, index, length, max, min, mod, null, pointer, size, substr,
        verify, unspec)
		   builtin;
%page;
%include comp_column;
%include comp_DCdata;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_footnotes;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_text;
%include compstat;
%include translator_temp_alloc;
  end comp_font_;




		    comp_format_ctls_.pl1           04/23/85  1059.2rew 04/23/85  0909.5      271593



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

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_format_ctls_:
  proc (ctl_index);

/* PARAMETERS */

    dcl ctl_index	   fixed bin;

/* LOCAL STORAGE 
				   text alignment flags */
    dcl align_flags	   (6) bit (6) aligned static options (constant)
		   init ("000001"b, "000100"b, "100000"b, "001000"b,
		   "010000"b, "000010"b);
    dcl align_mode	   char (32) var;
    dcl col_depth_adj  fixed bin (31);
    dcl ercd	   fixed bin (35);	/* error code */
				/* debug message for exit */
    dcl exit_str	   char (128) var init ("");
    dcl fnxt	   fixed bin (21);	/* next variable field char */
    dcl head_used	   fixed bin (31);
    dcl hf_needed	   fixed bin (31);	/* extra header/footer space needed */
    dcl hscales	   (7) fixed bin (31) static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl locolptr	   ptr;		/* for local reference */
    dcl 1 locol	   aligned like col based (locolptr);
    dcl maxcolusd	   fixed bin (31);	/* for setting multicolumn data */
    dcl min_val	   fixed bin (31);	/* minimum page length required */
    dcl net_line	   fixed bin (31);	/* net line for setting margins */
    dcl page_width	   fixed bin (31);	/* width for column specs */
    dcl save_index	   fixed (35);	/* to save ctl.index around calls */
    dcl tab_char	   char (1);	/* htab character */
    dcl tab_name	   char (32);	/* name of horizontal tab pattern */
    dcl unscaled	   (1) fixed bin (31) static options (constant) init (1);
				/* copy of control line variable field */
    dcl varfld	   char (1020) var;
    dcl vscales	   (7) fixed bin (31) static options (constant)
		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);

    dcl comp_error_table_$inconsistent
		   ext fixed bin (35);
    dcl comp_error_table_$limitation
		   ext fixed bin (35);
    dcl comp_error_table_$missing_delimiter
		   ext fixed bin (35);
    dcl comp_error_table_$syntax_error
		   ext fixed bin (35);

    dcl (index, length, ltrim, max, min, size)
		   builtin;

    dcl ioa_$rsnnl	   entry options (variable);

    if shared.bug_mode
    then call ioa_ ("format_ctls: (^d) ""^a""", ctl_index, ctl_line);

    maxcolusd = 0;
    varfld = substr (ctl_line, ctl.index);

    if shared.table_mode
    then
      do;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        tblcolptr = tblfmt.colptr (tblfmt.ccol);
      end;

    goto ctl_ (ctl_index);

/* TEXT ALIGNMENT CONTROLS
   both      center    inside    left      outside   right
   ".alb"    ".alc"    ".ali"    ".all"    ".alo"    ".alr"  */
ctl_ (1):
ctl_ (2):
ctl_ (3):
ctl_ (4):
ctl_ (5):
ctl_ (6):
    if shared.blkptr ^= null ()	/* change mode in current block */
    then
      do;
        if ^shared.ftn_mode		/* not a footnote */
				/* or not first footnote line */
	   | (shared.ftn_mode & text.hdr.count > 0)
				/* clean up leftovers */
        then if length (text.input_line) > 0
	   then call comp_break_ (format_break, 0);

        if text.hdr.colno >= 0	/* if not a loose block */
	   | option.galley_opt	/* or in galley mode */
        then current_parms.quad = align_flags (ctl_index);
        text.parms.quad, text.input.quad = align_flags (ctl_index);
      end;

    else if ^current_parms.title_mode
    then current_parms.quad = align_flags (ctl_index);

    if shared.bug_mode
    then
      do;
        align_mode = "%AlignMode%";
        call comp_use_ref_ (align_mode, "0"b, "0"b, addr (ctl.info));
        call ioa_$rsnnl ("align=^a", exit_str, 0, align_mode);
      end;

    goto return_;

ctl_ (74):			/* ".fi" = fill_mode ->  DEFAULT */
    goto fin_ctl;

ctl_ (75):			/* ".fif" = fill-off */
    if shared.blkptr ^= null		/* is there an active block? */
    then
      do;				/* clean up any leftovers */
        if text.input_line ^= ""
        then call comp_break_ (format_break, 0);
        text.parms.fill_mode = "0"b;
        if text.hdr.colno >= 0	/* if block isnt loose */
        then			/* set shared parm */
	   current_parms.fill_mode = "0"b;

        if ctl.index > length (ctl_line)
        then text.hdr.nofill_count = -1;
        else text.hdr.nofill_count =
	        comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	        addr (ctl.info), 0);
      end;
    else current_parms.fill_mode = "0"b;/* set shared parm */

    if ctl.index > length (ctl_line)
    then text_header.nofill_count = -1;
    else text_header.nofill_count =
	    comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    addr (ctl.info), 0);

    goto return_;

/* ".fin" = fill-on */
ctl_ (76):
fin_ctl:				/* fin_ctl_index */
    if ^option.nofill_opt		/* if fill mode is not disabled */
    then
      do;
        if shared.blkptr ^= null ()	/* if there is an active block */
        then if ^text.parms.fill_mode	/* if not already filling */
	   then
	     do;
	       if length (text.input.ptr -> txtstr) > 0
				/* clean up leftovers */
	       then call comp_break_ (format_break, 0);
	       text.parms.fill_mode = "1"b;
	       if text.hdr.colno >= 0 /* if block isnt loose */
	       then current_parms.fill_mode = "1"b;

	     end;
	   else ;			/**/
				/* set shared parm */
        else current_parms.fill_mode = "1"b;
      end;
    goto return_;

ctl_ (101):			/* ".htd" = horizontal-tabs-define */
    if varfld = ""			/* if nothing given */
    then
      do;				/* and there are some defined */
        if shared.htab_ptr ^= null ()
        then htab.count = 0;		/* cancel them all */
        goto return_;
      end;

    tab_name =			/* fetch the pattern name */
         comp_read_$name (varfld, 1, fnxt, addr (ctl.info));
    if tab_name = ""		/* if no name */
    then goto return_;

    varfld = ltrim (substr (varfld, fnxt));

    if shared.htab_ptr = null ()	/* allocate htab data */
    then
      do;
        shared.htab_ptr = allocate (const.local_area_ptr, size (htab));
        htab.count, htab.pats = 0;	/* initialize pattern count */
        htab.chars = "";		/* and clear chars */
				/* initialize the patterns */
        htab.pattern.name, htab.pattern.fill = "";
        htab.pattern.count, htab.pattern.stop = 0;
      end;

    do i = 1 to htab.count		/* see if this one exists */
         while (tab_name ^= htab.pattern (i).name);
    end;

    if i > hbound (htab.pattern, 1)	/* check pattern count limit */
    then
      do;
        call comp_report_$ctlstr (2, comp_error_table_$limitation,
	   addr (ctl.info), ctl_line,
	   "Only ^d horizontal tab patterns permitted.",
	   hbound (htab.pattern, 1));
        goto return_;
      end;

    if varfld = ""			/* if no column stops given */
    then
      do;
        if i > htab.count		/* if not known */
        then goto return_;

        else			/* cancel the pattern */
	do i = i to htab.count - 1;	/* and close up table */
	  htab.pattern (i) = htab.pattern (i + 1);
	end;

        htab.count = htab.count - 1;	/* reduce pattern count */
        goto return_;
      end;

    call set_htabs (i, ercd);		/* set the stops */
    if ercd = 0			/* record the pattern name */
    then htab.pattern (i).name = tab_name;

set_htabs:
  proc (itab, pmercd);		/* record stops */

    dcl itab	   fixed bin;	/* pattern index */
    dcl pmercd	   fixed bin (35);	/* error code */

    dcl jstop	   fixed bin;

    pmercd = 0;
    jstop, htab.pattern (itab).count = 0;

    do while (varfld ^= "" & jstop < hbound (htab.pattern.stop, 1));
				/* extract stop column */
      htab.pattern (itab).stop (jstop + 1) =
	 comp_read_$number (varfld, hscales, 1, fnxt, addr (ctl.info),
	 pmercd);
      if pmercd ^= 0
      then return;

      varfld = substr (varfld, fnxt);	/**/
				/* extract fill string, if any */
      htab.pattern (itab).fill (jstop + 1) = "";
      if index (varfld, ",") ^= 1
      then
        do;
	if index (varfld, """") = 1
	then
	  do;
	    htab.pattern (itab).fill (jstop + 1) =
	         comp_extr_str_ ("1"b, varfld, 1, fnxt, 0, addr (ctl.info));
	    varfld = substr (varfld, fnxt);
	  end;

	else
	  do;
	    k = search (varfld, ", ");
	    if k > 0
	    then
	      do;
	        htab.pattern (itab).fill (jstop + 1) =
		   substr (varfld, 1, k - 1);
	        varfld = substr (varfld, k);
	      end;
	    else
	      do;
	        htab.pattern (itab).fill (jstop + 1) = varfld;
	        varfld = "";
	      end;
	  end;
        end;			/**/
				/* check for a comma */
      if varfld ^= "" & index (varfld, ",") ^= 1
      then
        do;
	pmercd = comp_error_table_$missing_delimiter;
	call comp_report_$ctlstr (2, pmercd, addr (ctl.info), ctl_line,
	     "Missing comma after stop column ^d", jstop + 1);
	return;
        end;

      varfld = after (varfld, ",");	/* step over comma */

      if htab.pattern (itab).stop (jstop + 1) = 0
      then call comp_report_ (2, 0, "Invalid tab stop in column 0 ignored.",
	      addr (ctl.info), ctl_line);
      else jstop = jstop + 1;
    end;

    if varfld ^= ""			/* if more were given */
    then call comp_report_$ctlstr (2, comp_error_table_$limitation,
	    addr (ctl.info), ctl_line,
	    "More than ^d tab stops given. The excess will be ignored.",
	    hbound (htab.pattern.stop, 1));

    htab.pattern (itab).count = jstop;
    htab.count = max (itab, htab.count);

  end set_htabs;

    goto return_;

ctl_ (102):			/* ".htf" = horizontal-tabs-off */
    if shared.htab_ptr = null ()	/* if no tab patterns */
    then goto return_;

    if ctl.index > length (ctl_line)	/* if no tab chars given */
    then htab.chars = "";		/* clear the tab char string */

    else				/* for each given character */
      do ctl.index = ctl.index to length (ctl_line);
				/* find it in the tab char string */
        i = search (htab.chars, substr (ctl_line, ctl.index, 1));

        if i > 0			/* if its there */
        then			/* take it out of the string */
	do;
	  if i < maxlength (htab.chars)
	  then
	    do;
	      htab.chars =
		 substr (htab.chars, 1, i - 1)
		 || substr (htab.chars, i + 1);
				/* close up pattern index array */
	      do i = i by 1 while (htab.pats (i) ^= 0);
	        htab.pats (i) = htab.pats (i + 1);
	      end;
	    end;

	  else
	    do;
	      htab.chars = substr (htab.chars, 1, i - 1);
	      htab.pats (i) = 0;
	    end;
	end;

        else call comp_report_ (2, 0,
	        substr (ctl_line, ctl.index, 1)
	        || " is not an active tabbing character.", addr (ctl.info),
	        ctl_line);
      end;

    if htab.chars = ""		/* if all are off */
    then
      do;
        current_parms.htab_mode = "0"b; /* reset the flags */
        if shared.blkptr ^= null ()
        then text.parms.htab_mode = "0"b;
      end;

    goto return_;

ctl_ (103):			/* ".htn" = horizontal-tabs-on */
    if varfld = ""			/* if no char given */
         | index (varfld, " ") ^= 2
    then
      do;
        call comp_report_$ctlstr (2, comp_error_table_$syntax_error,
	   addr (ctl.info), ctl_line, "The tab character must be first.");
        goto return_;
      end;

    if shared.htab_ptr = null ()	/* allocate htab data */
    then
      do;
        shared.htab_ptr = allocate (const.local_area_ptr, size (htab));
        htab.count, htab.pats = 0;	/* initialize pattern count */
        htab.chars = "";		/* and clear chars */
      end;

    tab_char = substr (varfld, 1, 1);	/* record htab char */
				/* advance to pattern name */
    varfld = ltrim (substr (varfld, 2));

    if varfld = ""			/* if no name given */
    then
      do;
        call comp_report_$ctlstr (2, comp_error_table_$syntax_error,
	   addr (ctl.info), ctl_line,
	   "No tab pattern or pattern name given.");
        goto return_;
      end;			/**/
				/* if 1st char is numeric, its a pattern */
    if search (varfld, "0123456789") = 1
    then
      do;
        call set_htabs (0, ercd);
        if ercd ^= 0
        then goto return_;
        j = 0;
      end;

    else
      do;
        tab_name = comp_read_$name (varfld, 1, 1, addr (ctl.info));

        if htab.count > 0		/* find the pattern */
        then
	do j = 1 to htab.count while (tab_name ^= htab.name (j));
	end;
        else j = 0;

        if j = 0 | j > htab.count
        then
	do;
	  call comp_report_ (2, 0, "Tab pattern not defined.",
	       addr (ctl.info), ctl_line);
	  goto return_;
	end;
      end;			/**/
				/* find the tab char in the active list */
    i = index (htab.chars, tab_char);

    if i = 0			/* if not an active tab char */
    then
      do;
        htab.chars =		/* record new tab char */
	   htab.chars || tab_char;
        i = length (htab.chars);	/* and set the index */
      end;

    htab.pats (i) = j;		/* record pattern index */
    current_parms.htab_mode = "1"b;	/* set the mode flag */

    if shared.blkptr ^= null ()
    then
      do;
        if text.input_line ^= ""	/* first a format break */
        then call comp_break_ (format_break, 0);
        text.parms.htab_mode = "1"b;
      end;

    goto return_;

ctl_ (113):			/* ".in" = indent-left */
ctl_ (114):			/* ".inb" = indent-both */
ctl_ (115):			/* ".inl" = indent-left */
    save_index = ctl.index;		/* save index in case of .inb */

    if shared.blkptr ^= null		/* if there is an active block */
    then if text.input_line ^= ""	/* clean up any leftovers */
         then call comp_break_ (format_break, 0);

    if shared.ftn_mode
    then call comp_util_$set_bin (current_parms.left.indent,
	    "footnote left indent", footnote_parms.left.indent,
	    footnote_parms.left.indent, footnote_parms.measure, hscales,
	    comp_dvt.min_WS);
    else call comp_util_$set_bin (current_parms.left.indent, "left indent", 0,
	    0, current_parms.measure, hscales, comp_dvt.min_WS);

    if shared.blkptr ^= null		/* if there is an active block */
    then text.parms.left.indent = current_parms.left.indent;

    if shared.bug_mode
    then call ioa_$rsnnl ("col=^d mrg=^f/^f net=^f", exit_str, 0,
	    page.hdr.col_index, show (current_parms.left.indent, 12000),
	    show (current_parms.measure - current_parms.right.indent, 12000),
	    show (current_parms.measure - current_parms.left.indent
	    - current_parms.right.indent, 12000));

    if index (ctl_line, ".inb") ^= 1	/* if not indenting both margins */
    then goto return_;

    ctl.index = save_index;		/* restore index */
    goto inr_ctl;			/* set the other side */

ctl_ (116):			/* ".inr" = indent-right */
inr_ctl:
    call comp_util_$set_bin (current_parms.right.indent, "right indent", 0, 0,
         current_parms.measure, hscales, comp_dvt.min_WS);

    if shared.blkptr ^= null ()	/* if there is an active block */
    then
      do;
        if text.input_line ^= ""	/* any leftovers */
        then call comp_break_ (format_break, 0);
        text.parms.right.indent = current_parms.right.indent;
      end;

    if shared.bug_mode
    then call ioa_$rsnnl ("col=^d mrg=^f/^f net=^f", exit_str, 0,
	    page.hdr.col_index, show (current_parms.left.indent, 12000),
	    show (current_parms.measure + current_parms.left.indent, 12000),
	    show (current_parms.measure, 12000));

    goto return_;

ctl_ (120):			/* ".ls" = line-space */
    call comp_util_$set_bin (current_parms.linespace, "linespacing",
         option.linespace, 0, page.parms.length, vscales, comp_dvt.min_lead);

    ctl.linespace = current_parms.linespace;

    if shared.blkptr ^= null ()
    then text.parms.linespace, text.input.linespace = current_parms.linespace;

    goto return_;

ctl_ (121):			/* ".pd"  = page-define */
    goto pdl_ctl;

ctl_ (122):			/* ".pdc" = page-define-column */
pdc_ctl:
    if shared.blkptr ^= null		/* finish an active block */
    then call comp_break_ (block_break, 0);
				/* if we have anything */
    if page.hdr.used > 0		/* balance the page */
    then call comp_break_ (column_break, 0);

    if ctl.index >= length (ctl_line)	/* if no columns are given */
    then
      do;
        if page.parms.cols.count > 0
        then
	do;
/****	  col0.hdr.pspc = 0;	/* erase old head space */
	  do i = 1 to page.parms.cols.count;
	    maxcolusd = max (maxcolusd, page.column_ptr (i) -> col.hdr.used);
	  end;
	end;			/**/
				/* revert to col0 */
        page_parms.cols.count, page.parms.cols.count, page_header.col_index,
	   page.hdr.col_index = 0;
        shared.colptr = page.column_ptr (0);
        current_parms.measure = col0.parms.measure;

        if shared.bug_mode
        then call ioa_$rsnnl ("^a col=0 b^d u^f/^f(^f)^[ ftn=^d/^f^;^2s^]"
	        || " h^f pag=^a c^d u^f/^f h^f^[ pi=^d ^f^]", exit_str, 0,
	        exit_str, col.hdr.blkct, show (col.hdr.used, 12000),
	        show (col.hdr.net, 12000), show (col.depth_adj, 12000),
	        (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	        show (col.hdr.ftn.usd, 12000), show (col.hdr.pspc, 12000),
	        page.hdr.pageno, page.hdr.col_count,
	        show (page.hdr.used, 12000), show (page.hdr.net, 12000),
	        show (page.hdr.hdspc, 12000), (shared.picture.count > 0),
	        shared.picture.count, show (shared.picture.space, 12000));
      end;

    else				/* do the given columns */
      do;
        col0.margin.right, col0.parms.measure = page.parms.measure;
/**** column 1 is given special treatment because, if its width
      is zero, its gutter as assigned to column left margin
      and the second column spec is taken for column 1. */
				/* if no column 1 yet */
        if page.column_ptr (1) = null ()
        then
	do;
	  page.column_ptr (1) = allocate (const.local_area_ptr, size (col));
	  col1.blkptr (*) = null ();
	  col1.hdr = colhdr;
	  col1.hdrptr, col1.ftrptr = null ();
	  col1.hdrusd, col1.ftrusd = 0;
	end;

        page_parms.cols.count = 1;	/* set col 1 parms */
        call comp_util_$set_bin (col1.parms.measure, " column 1 measure", 0, 0,
	   page_parms.measure, hscales, comp_dvt.min_WS);
        page_width = col1.parms.measure;/**/
				/* is there a depth value? */
        if substr (ctl_line, ctl.index, 1) = "("
        then
	do;
	  ctl.index = ctl.index + 1;	/* step over paren */
	  call comp_util_$set_bin (col_depth_adj, "initial column 1 depth",
	       page_parms.length, -page_parms.length, page_parms.length,
	       vscales, comp_dvt.min_lead);

	  ctl.index = ctl.index + 2;	/* step over paren and comma */
	end;
        else col_depth_adj = 0;
        col1.depth_adj = col_depth_adj;

        if page_width = 0		/* if its zero width */
        then
	do;			/* gutter becomes left margin */
	  call comp_util_$set_bin (col1.margin.left, "column 1 left margin",
	       0, 0, page_parms.measure, hscales, comp_dvt.min_WS);
	  call comp_util_$set_bin (col1.parms.measure, "column 1 measure", 0,
	       0, page_parms.measure, hscales, comp_dvt.min_WS);

	  if page_width + col1.parms.measure > page_parms.measure
	  then goto bad_col;

	  else page_width = col1.margin.left + col1.parms.measure;
	end;			/**/
				/* col 1 has width, so */
        else col1.margin.left = 0;	/* it has 0 margin */
        col1.margin.right = col1.margin.left + col1.parms.measure;

        col1.hdr.net = page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd;
        col1.hdr.baldepth = page.hdr.baldepth;
        maxcolusd = col1.hdr.used;

/****        if col0.hdr.used = 0
/****        then col1.hdr.pspc = page.hdr.hdspc;
/****        else */
        col1.hdr.pspc = col0.hdr.pspc;

        if shared.bug_mode
        then call ioa_$rsnnl ("^a col=1 b^d u^f/^f(^f)^[ ftn=^d/^f^;^2s^]"
	        || " h^f pag=^a c^d u^f/^f h^f^[ pi=^d ^f^]", exit_str, 0,
	        exit_str, col1.hdr.blkct, show (col1.hdr.used, 12000),
	        show (col1.hdr.net, 12000), show (col1.depth_adj, 12000),
	        (col1.hdr.ftn.ct > 0), col1.hdr.ftn.ct,
	        show (col1.hdr.ftn.usd, 12000), show (col1.hdr.pspc, 12000),
	        page.hdr.pageno, page.hdr.col_count,
	        show (page.hdr.used, 12000), show (page.hdr.net, 12000),
	        show (page.hdr.hdspc, 12000), (shared.picture.count > 0),
	        shared.picture.count, show (shared.picture.space, 12000));
				/* set bal default */
        page_parms.cols.bal, page.parms.cols.bal = "1"b;
				/* now the rest of the columns */
        do while (ctl.index < length (ctl_line));
				/* if too many columns */
	if page_parms.cols.count = max_cols
	then
	  do;
	    call comp_report_ (2, 0,
	         "Only " || ltrim (char (max_cols))
	         || " text columns allowed.", addr (ctl.info), ctl_line);
	    goto return_;
	  end;			/**/
				/* go to next column */
	page_parms.cols.count = page_parms.cols.count + 1;

	locolptr = page.column_ptr (page_parms.cols.count);
	if locolptr = null ()	/* allocate the column */
	then
	  do;
	    page.column_ptr (page_parms.cols.count) =
	         allocate (const.local_area_ptr, size (col));

	    locolptr = page.column_ptr (page_parms.cols.count);
	    locol.hdr = colhdr;
	    locol.hdrptr, locol.ftrptr = null ();
	    locol.hdrusd, locol.ftrusd = 0;
	    locol.blkptr (*) = null ();
	  end;

	call comp_util_$set_bin (locol.gutter, "column gutter", 3 * 7200, 0,
	     page_parms.measure, hscales, comp_dvt.min_WS);

	if page_width + locol.gutter >= page_parms.measure
	then
	  do;
bad_col:
	    call comp_report_$ctlstr (2, comp_error_table_$inconsistent,
	         addr (ctl.info), ctl_line,
	         "Sum of column widths exceeds page width. All columns "
	         || "after column ^d will be ignored.",
	         page_parms.cols.count);
	    page.parms.cols = page_parms.cols;
	    page.hdr.col_count, page.parms.cols.count =
	         page_parms.cols.count;
	    goto return_;
	  end;

	else
	  do;
	    locol.margin.left, page_width = page_width + locol.gutter;
	  end;

	call comp_util_$set_bin (locol.parms.measure,
	     "column  " || ltrim (char (page_parms.cols.count))
	     || " measure", 0, 0, page_parms.measure, hscales,
	     comp_dvt.min_WS);

	if page_width + locol.parms.measure > page_parms.measure
	then goto bad_col;
	else page_width = page_width + locol.parms.measure;

	locol.margin.right = locol.margin.left + locol.parms.measure;
				/* if there a depth value? */
	if ctl.index <= length (ctl_line)
	then if substr (ctl_line, ctl.index, 1) = "("
	     then
	       do;		/* step over paren */
	         ctl.index = ctl.index + 1;
	         call comp_util_$set_bin (col_depth_adj,
		    "initial column depth", page_parms.length,
		    -page_parms.length, page_parms.length, vscales,
		    comp_dvt.min_lead);
				/* step over paren and comma */
	         ctl.index = ctl.index + 2;
	       end;
	     else col_depth_adj = 0;
	locol.depth_adj = col_depth_adj;

	locol.hdr.net =
	     page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd - locol.ftrusd;

/****	if col0.hdr.used = 0
/****	then locol.hdr.pspc = page.hdr.hdspc;
/****	else */
	locol.hdr.pspc = col0.hdr.pspc;

	locol.hdr.baldepth = page.hdr.baldepth;
	maxcolusd = max (maxcolusd, locol.hdr.used);
        end;

        if ctl.index = length (ctl_line)
        then
	do;
	  if index (substr (ctl_line, ctl.index), "u") = 1
	  then page_parms.cols.bal, page.parms.cols.bal = "0"b;
	  else page_parms.cols.bal, page.parms.cols.bal = "1"b;
	end;

        page.parms.cols = page_parms.cols;
				/* go to column 1 */
        page_parms.cols.count, page.hdr.col_index = 1;
        shared.colptr = page.column_ptr (1);
        current_parms.measure = col1.parms.measure;
      end;

    if page.hdr.used > 0
    then page.hdr.col_count = max (page.hdr.col_count, page.parms.cols.count);
    else page.hdr.col_count = page.parms.cols.count;

    do i = 0 to page.hdr.col_count;
      locolptr = page.column_ptr (i);
      if i > 0
      then locol.hdr.balusd, locol.hdr.used = maxcolusd;

      if shared.bug_mode
      then
        do;
	col_depth_adj = locol.depth_adj;
	call ioa_ ("^5x(col=^d b^d d^f u^f/^f(^f) h^f "
	     || "mrg=^f/^f/^f^[ (f^d ^f)^]", i, locol.hdr.blkct,
	     show (locol.hdr.baldepth, 12000), show (locol.hdr.used, 12000),
	     show (locol.hdr.net, 12000), show (locol.depth_adj, 12000),
	     show (locol.hdr.pspc, 12000), show (locol.margin.left, 12000),
	     show (locol.margin.right, 12000),
	     show (locol.parms.measure, 12000), (locol.hdr.ftn.ct > 0),
	     locol.hdr.ftn.ct, show (locol.hdr.ftn.usd, 12000));
        end;
    end;

    goto return_;

ctl_ (123):			/* ".pdl" = page-define-length */
pdl_ctl:
    if shared.blkptr ^= null ()	/* clean up current block */
    then call comp_break_ (block_break, 0);

    hf_needed = 0;			/* length is first, find min val */
    if shared.ophdrptr ^= null ()
    then hf_needed = max (hf_needed, shared.ophdrptr -> hfcblk.hdr.used);
    if shared.ephdrptr ^= null ()
    then hf_needed = max (hf_needed, shared.ephdrptr -> hfcblk.hdr.used);
    if shared.opftrptr ^= null ()
    then hf_needed = max (hf_needed, shared.opftrptr -> hfcblk.hdr.used);
    if shared.epftrptr ^= null ()
    then hf_needed = max (hf_needed, shared.epftrptr -> hfcblk.hdr.used);
    min_val =
         page.parms.margin.top + page.parms.margin.header + hf_needed
         + page.parms.margin.footer + page.parms.margin.bottom + 12000;

    call comp_util_$set_bin (page.parms.length, "page length", 792000, min_val,
         comp_dvt.pdl_max, vscales, comp_dvt.min_lead);
    page_parms.length = page.parms.length;

    if ^option.galley_opt
    then call comp_util_$set_net_page ("0"b);

    if index (ctl_line, ".pdl") = 1	/* if length only */
    then
      do;
        if shared.bug_mode
        then call ioa_$rsnnl ("page length = ^f", exit_str, 0,
	        show (page.parms.length, 12000));
        goto return_;
      end;

    else goto pdw_ctl;		/* otherwise, go for width */

ctl_ (124):			/* ".pdw" = page-define-width */
pdw_ctl:
    call comp_util_$set_bin (page_parms.measure, "page width", 468000, 1,
         comp_dvt.pdw_max, hscales, comp_dvt.min_WS);
    page.parms.measure, col0.parms.measure, col0.margin.right,
         text_parms.measure, footnote_parms.measure = page_parms.measure;

    if shared.blkptr ^= null ()
    then text.parms.measure = text_parms.measure;

    if shared.bug_mode
    then call ioa_$rsnnl ("pag,col0 measure ^f", exit_str, 0,
	    show (page_parms.measure, 12000));

    if index (ctl_line, ".pdw") = 1
    then goto return_;		/* if width only */
    else goto pdc_ctl;		/* otherwise, go for columns */

ctl_ (162):			/* ".un"  = undent */
ctl_ (163):			/* ".unb" = undent-both */
    goto unl_ctl;

ctl_ (164):			/* ".unh" = undent-hanging */
unh_ctl:
    if shared.blkptr = null
    then
      do;
        if ^page.hdr.headed & ^option.galley_opt
        then call comp_head_page_ (head_used);
        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	   addr (current_parms), "0"b);
      end;
    else if text.input_line ^= ""
    then call comp_break_ (format_break, 0);

    text.input.hanging = "1"b;
    goto join_unl;

ctl_ (165):			/* ".unl" = undent-left */
unl_ctl:
    if shared.blkptr = null
    then
      do;
        if ^page.hdr.headed & ^option.galley_opt
        then call comp_head_page_ (head_used);
        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	   addr (current_parms), "0"b);
      end;
    else if text.input_line ^= ""
    then call comp_break_ (format_break, 0);

join_unl:
    net_line =
         current_parms.measure - current_parms.right.indent
         - current_parms.left.indent;
    call comp_util_$set_bin (text.parms.left.undent, "left margin undent",
         text.parms.left.indent, -net_line, text.parms.left.indent, hscales,
         comp_dvt.min_WS);

    if index (ctl_line, ".unb") = 1
    then text.parms.right.undent = text.parms.left.undent;

    if shared.bug_mode
    then call ioa_$rsnnl ("col=^d mrg=^f/^f/^f", exit_str, 0,
	    page.hdr.col_index,
	    show (text.parms.left.indent - text.parms.left.undent, 12000),
	    show (text.parms.measure - text.parms.right.indent
	    + text.parms.right.undent, 12000),
	    show (text.parms.measure - text.parms.left.indent
	    + text.parms.left.undent - text.parms.right.indent
	    + text.parms.right.undent, 12000));

    goto return_;

ctl_ (166):			/* ".unn" = undent-nobreak - OBSOLETED BY .unh */
    goto unh_ctl;

ctl_ (167):			/* ".unr" = undent-right */
    if shared.blkptr = null
    then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	    addr (current_parms), "0"b);

    net_line =
         page_parms.measure - current_parms.right.indent
         - current_parms.left.indent;
    call comp_util_$set_bin (text.parms.right.undent, "right margin undent",
         text.parms.right.indent, -net_line, text.parms.right.indent, hscales,
         comp_dvt.min_WS);

    if shared.bug_mode
    then call ioa_$rsnnl ("col=^d mrg=^f/^f/^f", exit_str, 0,
	    page.hdr.col_index,
	    show (text.parms.left.indent - text.parms.left.undent, 12000),
	    show (text.parms.measure - text.parms.right.indent
	    + text.parms.right.undent, 12000),
	    show (text.parms.measure - text.parms.left.indent
	    + text.parms.left.undent - text.parms.right.indent
	    + text.parms.right.undent, 12000));

    goto return_;

return_:
    if shared.bug_mode
    then call ioa_ ("^5x(format_ctls:^[ ^a^])", (exit_str ^= ""), exit_str);

    return;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
    dcl 1 col1	   aligned like col based (page.column_ptr (1));
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_htab;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;
%include translator_temp_alloc;

  end comp_format_ctls_;




		    comp_get_file_.pl1              04/23/85  1059.2rew 04/23/85  0909.6      124191



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

/* compose subroutine to locate and access input files */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_get_file_:
  proc;
    return;			/* no entry here */

/* LOCAL STORAGE */

    dcl ctl_info_ptr   ptr;		/* for comp_report_$ctlstr */
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl 1 insert_status
		   aligned like status_branch;
				/* local insert block index */
    dcl insertndx	   fixed bin init (0);
    dcl itsptr	   ptr;		/* local ITS pointer */
    dcl pname_ptr	   ptr;		/* primary entryname */
    dcl pname	   char (32) aligned based (pname_ptr);
    dcl status_area	   area (4096);	/* work area for status */

    dcl (addr, before, bool, divide, hbound, index, null, pointer, rtrim, size,
        search)	   builtin;

    dcl comp_error_table_$limitation
		   fixed bin (35) ext static;
    dcl error_table_$no_r_permission
		   fixed bin (35) ext static;
    dcl error_table_$segknown
		   fixed bin (35) ext static;
    dcl error_table_$zero_length_seg
		   fixed bin (35) ext static;

    dcl com_err_	   entry options (variable);
    dcl expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*) aligned,
		   char (*) aligned, fixed bin (35));
    dcl hcs_$status_long
		   entry (char (*) aligned, char (*) aligned,
		   fixed bin (1), ptr, ptr, fixed bin (35));
    dcl msf_manager_$get_ptr
		   entry (ptr, fixed bin, bit (1), ptr, fixed bin (24),
		   fixed bin (35));
    dcl msf_manager_$open
		   entry (char (*) aligned, char (*) aligned, ptr,
		   fixed bin (35));
    dcl pathname_	   entry (char (*) aligned, char (*) aligned)
		   returns (char (168));
    dcl search_paths_$find_dir
		   entry (char (*), ptr, char (*) aligned, char (*),
		   char (*) aligned, fixed bin (35));
    dcl suffixed_name_$make
		   entry (char (*) aligned, char (*), char (32) aligned,
		   fixed bin (35));

find:
  entry (given_name, fildataptr, refdir, source_file, suffix, ercd);

/* PARAMETERS */

    dcl given_name	   char (*);	/* given search name */
    dcl fildataptr	   ptr;		/* pointer to the file struc */
    dcl 1 fildata	   aligned like insert.file based (fildataptr);
    dcl refdir	   char (*);	/* dir for refdir rule */
    dcl source_file	   bit (1);	/* 1= source file, 0= insert file */
    dcl suffix	   char (*);	/* file suffix */
    dcl ercd	   fixed bin (35);	/* system error code */

    ctl_info_ptr = addr (ctl.info);
    ercd = 0;

    if (shared.bug_mode & dt_sw) | (source_file & sf_sw)
    then call ioa_ ("get_file_$find: (^[S^;I^] ^a)", source_file, given_name);
				/* force suffix, the dir may not */
    call				/* be the right one, tho */
         expand_pathname_$add_suffix (given_name, suffix, fildata.dir,
         fildata.entryname, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose", "Expanding path for ^a", given_name);
        goto find_return;
      end;

    fildata.refname =
         substr (fildata.entryname, 1, length (rtrim (fildata.entryname)) - 7);

    if source_file			/* a command line file? */
    then fildata.insert_ptr = fildataptr;

    else				/* insert file */
      do;				/* search for given name */
        do i = 1 to insert_data.ref_area.count;
	refstr_ptr =		/* set search pointer & length */
	     addr (insert_data.ref_area.ptr (i) -> insert_refs.name (1));
	refstr_len = 32 * insert_data.ref_area.ptr (i) -> insert_refs.count;
				/* search name area */
	j = index (refname_str, fildata.entryname);

	if j > 0			/* did we find it? */
	then
	  do;			/* true name index */
	    j = divide (j, 32, 17, 0) + 1;
	    insertndx =		/* fetch insert index */
	         insert_data.ref_area.ptr (i) -> insert_refs.index (j);
	    goto name_found;
	  end;
        end;			/**/
				/* no luck, this is a new name */
        i = insert_data.ref_area.count; /* select last name area */
				/* fetch count */
        j = insert_data.ref_area.ptr (i) -> insert_refs.count;
				/* do we need a fresh name area? */
        if j = hbound (insert_data.ref_area.ptr (i) -> insert_refs.name, 1)
        then
	do;			/* last one full? */
	  if i = hbound (insert_data.ref_area.ptr, 1)
	  then
	    do;
	      call comp_report_$ctlstr (4, comp_error_table_$limitation,
		 ctl_info_ptr, ctl_line,
		 "Cant have more than ^d insert file names.",
		 60 * hbound (insert_data.ref_area.ptr, 1)
		 *
		 hbound (insert_data.ref_area.ptr (i) -> insert_refs.name,
		 1));
	      ercd = 1;
	      goto find_return;
	    end;

	  i, insert_data.ref_area.count = i + 1;
	  insert_data.ref_area.ptr (i) =
	       allocate (const.local_area_ptr, size (insert_refs));
	end;			/**/
				/* record new name */
        j = insert_data.ref_area.ptr (i) -> insert_refs.count + 1;
        insert_data.ref_area.ptr (i) -> insert_refs.name (j) =
	   fildata.entryname;
      end;			/**/
				/* if a search is needed */
    if search ("<>", given_name) = 0
    then
      do;
        if ^source_file		/* search only for insert files */
        then
	do;
	  call search_paths_$find_dir ("compose", null (), fildata.entryname,
	       refdir, fildata.dir, ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
		 "Searching for ^a", given_name);
	      goto find_return;
	    end;
	end;
      end;

/*    else				/* no search, expand it */
/*      do;
/*        call
/*	expand_pathname_$add_suffix (given_name, suffix, fildata.dir,
/*	fildata.entryname, ercd);
/*        if ercd ^= 0
/*        then
/*	do;
/*	  if source_file
/*	  then call
/*	         com_err_ (ercd, "compose", "Expanding path for ^a",
/*	         given_name);
/*	  else call
/*	         comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
/*	         "Expanding path for ^a", given_name);
/*	  goto find_return;
/*	end;
/*      end; */

    fildata.path = pathname_ (fildata.dir, fildata.entryname);

    if ^source_file			/* an insert file? */
    then
      do;
        insert_data.ref_area.ptr (i) -> insert_refs.count = j;
				/* find out everything we know */
        status_area_ptr = addr (status_area);
        call hcs_$status_long (fildata.dir, fildata.entryname, 0,
	   addr (insert_status), status_area_ptr, ercd);
        if ercd ^= 0
        then
	do;
sts_err:
	  call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
	       "Getting status of ^a", fildata.path);
	  goto find_return;
	end;

        if insert_status.type = Directory & insert_status.bit_count = 0
        then
	do;
dir_err:
	  call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
	       "Directories not allowed, ^a", fildata.path);
	  goto find_return;
	end;

        if insert_status.type = Link
        then
	do;			/* record link target path */
	  status_ptr = addr (insert_status);
	  fildata.path = status_pathname;
				/* now chase the link */
	  call hcs_$status_long (fildata.dir, fildata.entryname, 1,
	       addr (insert_status), null, ercd);
	  if ercd ^= 0
	  then goto sts_err;

	  if insert_status.type = Directory & insert_status.bit_count = 0
	  then goto dir_err;

	  call expand_pathname_$add_suffix ((fildata.path), suffix,
	       fildata.dir, "", ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
		 "Expanding path for ^a", given_name);
	      goto find_return;
	    end;
	end;

        do k = 1 to insert_data.count	/* do we know it by another name? */
	   while (insert_data.ptr (k) -> insert.path ^= fildata.path);
        end;

        if k <= insert_data.count	/* yes */
        then
	do;
	  fildata.charcount = insert_data.ptr (k) -> insert.charcount;
	  fildata.fcb_ptr = insert_data.ptr (k) -> insert.fcb_ptr;
	end;			/* need a new file data block */
				/* check limit */
        if insert_data.count = hbound (insert_data.ptr, 1)
        then
	do;
	  call comp_report_$ctlstr (4, comp_error_table_$limitation,
	       addr (ctl.info), ctl_line,
	       "Cant have more than ^d insert files.",
	       hbound (insert_data.ptr, 1));
	  goto find_return;
	end;

        insertndx, insert_data.count = insert_data.count + 1;
        insert_data.ptr (insertndx) =
	   allocate (const.global_area_ptr, size (insert));
				/* setup file data */
        shared.insert_ptr = insert_data.ptr (insertndx);
        insert.file = fildata;
        insert.insert_ptr = shared.insert_ptr;
        insert.charcount, insert.comp_no = 0;
        insert.fcb_ptr, insert.pointer = null;

        insert_data.ref_area.ptr (i) -> insert_refs.index (j) = insertndx;
				/* make sure user can access it */
        if bool (insert_status.mode, "01000"b, "0001"b) ^= "01000"b
        then
	do;
	  ercd = error_table_$no_r_permission;
	  if source_file
	  then call com_err_ (ercd, "compose", "^a", fildata.path);
	  else call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
		  "^a", fildata.path);
	  goto find_return;
	end;			/* and theres something in it */
        if insert_status.bit_count > 0
        then fildata.charcount = divide (insert_status.bit_count, 9, 21, 0);
        else
	do;
	  ercd = error_table_$zero_length_seg;
	  if source_file
	  then call com_err_ (ercd, "compose", "^a", fildata.path);
	  else call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line,
		  "^a", fildata.path);
	  goto find_return;
	end;
      end;

    call msf_manager_$open (fildata.dir, fildata.entryname, itsptr, ercd);
    if ercd ^= 0 & ercd ^= error_table_$segknown
    then
      do;
        if source_file
        then call com_err_ (ercd, "compose", "Input file ^a", fildata.path);
        else call comp_report_$ctlstr (3, ercd, ctl_info_ptr, ctl_line, "^a",
	        fildata.path);
        goto find_return;
      end;

    fildata.fcb_ptr = itsptr;
    ercd = 0;

    if ^source_file
    then insert.fcb_ptr = fildata.fcb_ptr;

name_found:
    if ^source_file
    then
      do;
        shared.insert_ptr = insert_data.ptr (insertndx);
        insert_data.index, insert.file.info.fileno = insertndx;
        fildata = insert.file;
      end;

find_return:
    if (shared.bug_mode & dt_sw) | (source_file & sf_sw)
    then call ioa_ ("^5x(get_file_$find: ^a)", fildata.path);

    return;			/* end of find */

open:
  entry (fildataptr, source_file, ercd);

/* LOCAL STORAGE */

    dcl bc	   fixed bin (24);	/* local bitcount */
    dcl chrcount	   fixed bin (21);	/* local character count */

    ercd = 0;

    if (shared.bug_mode & dt_sw) | (source_file & sf_sw)
    then call ioa_ ("get_file_$open: (^[S^;I^] ^a)", source_file, fildata.path)
	    ;

    if ^source_file			/* get status of insert file */
    then
      do;
        insertndx = insert_data.index;	/* copy insert data index */
				/* The char count & dtcm must checked
				   for every insertion of a file
				   because of the possibility of
				   dynamically changing insert files */
        call hcs_$status_long (fildata.dir, fildata.entryname, 1,
	   addr (insert_status), null (), ercd);
        if ercd ^= 0
        then
	do;
	  call comp_report_ (3, ercd, "Getting status of insert file.",
	       addr (ctl.info), ctl_line);
	  goto open_return;
	end;

        if insert_status.bit_count = 0
        then
	do;
	  ercd = error_table_$zero_length_seg;
	  call comp_report_ (3, ercd, "Insert file is empty.",
	       addr (ctl.info), ctl_line);
	  goto open_return;
	end;

        chrcount = divide (insert_status.bit_count, 9, 21, 0);
				/* if critical stuff has changed */
        if insert_data.ptr (insert_data.index) -> insert.charcount ^= chrcount
	   | insert_data.ptr (insert_data.index) -> insert.dtcm
	   ^= insert_status.dtcm
        then
	do;			/* record new data */
	  fildata.charcount = chrcount;
	  insert_data.ptr (insert_data.index) -> insert.dtcm =
	       insert_status.dtcm;	/* clear all labels */
	  insert_data.ptr (insert_data.index) -> insert.label.count = 0;
	end;			/* point to new file */
        shared.insert_ptr = insert_data.ptr (insert_data.index);
        insert.insert_ptr = shared.insert_ptr;
        insert.thrb = ctl.info.fileno;
        insert.callers_name = shared.input_filename;
      end;			/**/
				/* fetch component zero */
    call msf_manager_$get_ptr ((fildata.fcb_ptr), 0, "0"b, itsptr, bc, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose",
	   "msf_manager_ attempting to access"
	   || " component 0 of input file ^a", fildata.path);
        goto open_return;
      end;

    fildata.pointer = itsptr;
    if source_file			/* for source files */
    then fildata.charcount = divide (bc, 9, 21, 0);
				/* copy various data to shared */
    shared.input_dirname = rtrim (fildata.dir);
    shared.input_filename = fildata.refname;
open_return:
    if (shared.bug_mode & dt_sw) | (source_file & sf_sw)
    then call ioa_ ("^5x(get_file<_$open) (^d ^a ^p)", insertndx,
	    fildata.refname, fildata.pointer);

    return;

    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

    dcl sf_sw	   bit (1) static init ("0"b);
sfn:
  entry;
    sf_sw = "1"b;
    return;
sff:
  entry;
    sf_sw = "0"b;
    return;

allf:
  entry;
    dt_sw, sf_sw = "0"b;
    return;
%page;
%include comp_entries;
%include comp_fntstk;
%include comp_insert;
%include comp_option;
%include comp_shared;
%include comp_text;
%include compstat;
%include status_structures;
%include translator_temp_alloc;

  end comp_get_file_;




		    comp_head_page_.pl1             04/23/85  1059.2rew 04/23/85  0909.7       63009



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

/* compose subroutine to head a page */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_head_page_:
  proc (head_used);

/* PARAMETERS */

    dcl head_used	   fixed bin (31);	/* space taken by page header */

/* LOCAL STORAGE */

    dcl blank	   bit (1);	/* local copy of blank page flag */
    dcl EMPTY	   bit (1) static options (constant) init ("1"b);
    dcl ftnblkptr	   ptr;		/* footnote block */
    dcl 1 ftnblk	   aligned like text based (ftnblkptr);
    dcl i		   fixed;		/* working index */
    dcl meas	   bit (1);	/* 1= measure of <title> parts */
    dcl parms_ptr	   ptr;		/* parms for the header */
    dcl save_colno	   fixed bin;

    dcl (addr, dec, divide, index, length, max, mod, null)
		   builtin;

    if ^page.hdr.blankpage		/* advance pageno */
    then
      do;
        call comp_util_$pageno (1000, page.hdr.pageno);
				/* set frontpage flag */
        if shared.dot_add_letter = PAD
        then page_header.frontpage, page.hdr.frontpage =
	        mod (shared.pagenum.nmbr (shared.pagenum.index), 2000)
	        = 1000;
        else			/* toggle frontpage flag */
	   page.hdr.frontpage, page_header.frontpage =
	        ^page_header.frontpage;
      end;			/**/
				/* toggle frontpage flag */
    else page.hdr.frontpage, page_header.frontpage = ^page_header.frontpage;

    page.hdr.dot_addltr = shared.dot_add_letter;

    if shared.bug_mode
    then call ioa_ ("head_page: (^[front^;back^]^[,blank^] pag=^a)",
	    page.hdr.frontpage, page.hdr.blankpage, page.hdr.pageno);

    page.hdr.pgc_select = " ";

    save_colno = page.hdr.col_index;	/* go to column 0 for the header */
    page.hdr.col_index = 0;
    shared.colptr = page.column_ptr (0);

    if page.hdr.frontpage
    then
      do;
        page.hdr.net = page_parms.net.odd;
        page.hdr.lmarg = page_parms.lmarg.odd;
        if shared.ophdrptr ^= null
        then parms_ptr = addr (shared.ophdrptr -> hfcblk.parms);
        else parms_ptr = const.text_parms_ptr;
      end;

    else
      do;
        page.hdr.net = page_parms.net.even;
        page.hdr.lmarg = page_parms.lmarg.even;
        if shared.ephdrptr ^= null
        then parms_ptr = addr (shared.ephdrptr -> hfcblk.parms);
        else parms_ptr = const.text_parms_ptr;
      end;

    do i = 0 to page.parms.cols.count;
      if page.column_ptr (i) ^= null
      then page.column_ptr (i) -> col.hdr.net =
	      page.hdr.net - page.column_ptr (i) -> col.ftrusd;
    end;

    call comp_util_$getblk (0, col0.blkptr (1), "ph", parms_ptr, "0"b);
    shared.blkptr = col0.blkptr (1);
    const.current_parms_ptr = parms_ptr;
    text.parms.page = "1"b;
    text.parms.cbar.add,		/* no cbars in page headers */
         text.parms.cbar.mod, text.parms.cbar.del = "0"b;
    text.hdr.tblblk = "0"b;

    if page.hdr.blankpage		/* blank page? */
    then
      do;
        hfcblk_ptr = shared.blank_header_ptr;
        if hfcblk_ptr ^= null
        then text.hdr.tblblk = hfcblk.hdr.tblblk;
      end;

    else if page.hdr.frontpage	/* odd page? */
    then
      do;
        hfcblk_ptr = shared.ophdrptr;
        if hfcblk_ptr ^= null
        then text.hdr.tblblk = hfcblk.hdr.tblblk;
      end;

    else if ^page.hdr.frontpage	/* even page? */
    then
      do;
        hfcblk_ptr = shared.ephdrptr;
        if hfcblk_ptr ^= null
        then text.hdr.tblblk = hfcblk.hdr.tblblk;
      end;

    text.parms.art, text.hdr.art = "0"b;/**/

    page.hdr.hdspc, col0.hdr.pspc = 0;	/* put in top margin */
    if page.parms.margin.top - page.parms.init_page_depth > 0
    then call comp_space_ (page.parms.margin.top - page.parms.init_page_depth,
	    shared.blkptr, "0"b, "0"b, "0"b, "0"b);
    page.hdr.headed = "1"b;		/* the page is now headed */
    page.hdr.hdspc, col0.hdr.pspc = page.parms.margin.top;

    if hfcblk_ptr ^= null ()
    then
      do;
        text.parms = hfcblk.parms;	/* set parms for the header */
        page.hdr.art, text.hdr.art = hfcblk.parms.art;

        if hfcblk.hdr.count > 0	/* build header */
        then call comp_title_block_ (hfcblk_ptr);
        text.input_line = "";		/* clean up input */

        if hfcblk.hdr.white
        then page.hdr.hdspc, col0.hdr.pspc = page.hdr.hdspc + hfcblk.hdr.used;
        else page.hdr.hdspc, col0.hdr.pspc = text.hdr.trl_ws;
      end;

    if page.parms.margin.header > 0
    then
      do;
        call comp_space_ (page.parms.margin.header, shared.blkptr, "0"b, "0"b,
	   "0"b, "0"b);
        page.hdr.hdspc, col0.hdr.pspc =
	   page.hdr.hdspc + page.parms.margin.header;
      end;			/**/
				/* pick up orphan footnotes */
    if shared.ftnblk_data_ptr ^= null
    then
      do i = 1 to ftnblk_data.highndx;
        ftnblkptr = ftnblk_data.blkptr (i);
        if ftnblkptr ^= null
        then if ftnblk.hdr.orphan
	   then
	     do;
	       col0.ftn.ct, text.hdr.ftn.ct = text.hdr.ftn.ct + 1;
	       col0.ftn.usd, text.hdr.ftn.usd =
		  text.hdr.ftn.usd + ftnblk.hdr.used;
	       col0.ftn.blkndx (col0.ftn.ct),
		  text.hdr.ftn.blkndx (text.hdr.ftn.ct) = i;
	     end;
      end;

    head_used, col0.hdr.depth = text.hdr.used;
    page.hdr.hdspc = col0.hdr.pspc;
    page.parms.cols.bal = page_parms.cols.bal;

    page.hdr.col_index = save_colno;
    shared.colptr = page.column_ptr (save_colno);

    if col.hdrptr ^= null		/* running column header? */
    then if col.hdrptr -> text.hdr.count > 0
         then
	 do;
	   call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "ch",
	        addr (col.hdrptr -> text.parms), ^EMPTY);
	   text.hdr.tblblk = "0"b;
	   call comp_title_block_ (col.hdrptr);
/****	   call comp_break_ (header_break, 0);*/
	 end;

    const.current_parms_ptr = const.text_parms_ptr;
    shared.blkptr = null;

return_:
    if shared.pass_counter <= 1	/* if this page is to be printed */
         & page.hdr.pageno = option.pglst (option.pglstndx).from
    then shared.print_flag = "1"b;	/* print flag ON */

    if shared.bug_mode
    then call ioa_ ("^5x(head_page: pag=^a husd=^f hspc=^f^[ A^] "
	    || "^[front^;back^])", page.hdr.pageno,
	    dec (divide (head_used, 12000, 31, 10), 11, 3),
	    dec (divide (page.hdr.hdspc, 12000, 31, 10), 11, 3),
	    page.hdr.art, page.hdr.frontpage);

%include comp_brktypes;
%include comp_column;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

  end comp_head_page_;




		    comp_hft_ctls_.pl1              04/23/85  1059.2rew 04/23/85  0910.0      424872



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

/* compose subroutine implementing the header/footer/title block controls */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_hft_ctls_:
  proc (ctl_index);

/* PARAMETERS */

    dcl ctl_index	   fixed bin;	/* control index */

/* LOCAL STORAGE */

    dcl blnkct	   fixed bin (31);	/* blank line count */
    dcl block_type	   char (1) static init (" ");
    dcl EMPTY	   bit (1) static options (constant) init ("1"b);
    dcl ercd	   fixed bin (35);	/* error code */
    dcl err_sw	   bit (1);
    dcl exit_str	   char (256) var;	/* debug message */
    dcl fnxt	   fixed bin (21);	/* next variable field char */
    dcl hf_lin_key	   char (1) var;	/* a|e|o for hdrs & ftrs */
    dcl hscales	   (7) fixed bin (31) static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl (i, ii, j)	   fixed bin;	/* working index */
    dcl lino	   fixed init (0);	/* line index */
    dcl loc_lead	   fixed bin (31);
    dcl LOOSE	   fixed bin static options (constant) init (-1);
    dcl new_indent	   fixed bin (31);	/* indent value for formatted blocks */
    dcl save_varfld	   char (1020) var;
    dcl tf_art	   bit (1);	/* for art mode promotion */
    dcl tf_keep	   bit (1);	/* for keep mode promotion */
    dcl th_art	   bit (1);	/* for art mode promotion */
    dcl th_keep	   bit (1);	/* for keep mode promotion */
    dcl unscaled	   (1) fixed bin (31) static options (constant) init (1);
				/* control line variable field */
    dcl varfld	   char (1020) var;
    dcl vscales	   (7) fixed bin (31) static options (constant)
		   init (12000, 9000, 72000, 2834.65, 12000, 1000, 0);

    dcl (divide, index, length, max, null, round, substr)
		   builtin;

    dcl comp_abort	   condition;

    dcl ioa_$rsnnl	   entry options (variable);

    exit_str = "";			/* initialize */
    th_keep, th_art = "0"b;
    hfcblk_ptr = null;

    if shared.bug_mode
    then call ioa_ ("hft_ctls: (^d) ""^a""", ctl_index,
	    comp_util_$display (ctl_line, 0, "0"b));
				/* copy variable field */
    varfld = substr (ctl_line, ctl.index);

    goto ctl_ (ctl_index);

ctl_ (20):			/* ".bcf" = begin-column-footer */
    goto return_;			/* HMMM! */

ctl_ (21):			/* ".bch" = begin-column-header */
    goto return_;

ctl_ (32):			/* ".bpf" = begin-page-footer */
bpf_ctl:
    if current_parms.title_mode	/* if already in a formatted block */
    then
      do;
        call comp_report_ (2, 0, "Already processing a formatted title block",
	   addr (ctl.info), ctl_line);
        goto bpf_err;
      end;

    if ctl.index <= length (ctl_line)	/* if a numeric is given */
         & index ("+-0123456789", substr (ctl_line, ctl.index, 1)) ^= 0
    then call comp_util_$set_bin (new_indent, "header indent", 0, 0,
	    page.parms.measure, hscales, comp_dvt.min_WS);
    else new_indent = 0;

    if ctl.index <= length (ctl_line)	/* if type is given */
    then block_type = substr (ctl_line, ctl.index, 1);
    else block_type = "a";		/* otherwise, all */
				/* even or all */
    if (block_type = "e" | block_type = "a")
    then
      do;
        call comp_util_$relblk (LOOSE, shared.epftrptr);
        call comp_util_$getblk (LOOSE, shared.epftrptr, "ef",
	   const.default_parms_ptr, ^EMPTY);
        hfcblk_ptr = shared.epftrptr;
        hfcblk.parms.page = "1"b;

        if shared.ephdrptr ^= null	/* copy art flag from header */
        then hfcblk.hdr.art, hfcblk.parms.art =
	        shared.ephdrptr -> hfcblk.parms.art;
      end;			/**/
				/* odd or all */
    if (block_type = "o" | block_type = "a")
    then
      do;
        call comp_util_$relblk (LOOSE, shared.opftrptr);
        call comp_util_$getblk (LOOSE, shared.opftrptr, "of",
	   const.default_parms_ptr, ^EMPTY);
        hfcblk_ptr = shared.opftrptr;
        hfcblk.parms.page = "1"b;

        if shared.ophdrptr ^= null	/* copy art flag from header */
        then hfcblk.hdr.art, hfcblk.parms.art =
	        shared.ophdrptr -> hfcblk.parms.art;
      end;			/**/
				/* unknown block type? */
    else if index ("aeo", block_type) = 0
    then
      do;
        call comp_report_ (2, 0, "Unknown block type.", addr (ctl.info),
	   ctl_line);

bpf_err:
        do while (substr (ctl_line, verify (ctl_line, " "), 4) ^= ".fbe"
	   & substr (ctl_line, verify (ctl_line, " "), 4) ^= ".epf");
	call_box_ptr = call_stack.ptr (call_stack.index);
	call comp_read_$line (call_box_ptr, "", "1"b);
	ctl.info = call_box.info;
        end;
        goto return_;
      end;

    hfcblk.hdr.blkptr = shared.blkptr;	/* save pointers for end */
    hfcblk.hdr.parms_ptr = const.current_parms_ptr;
				/* switch block pointers */
    if block_type = "a" | block_type = "o"
    then shared.blkptr = shared.opftrptr;
    else shared.blkptr = shared.epftrptr;
				/* dont disturb main body parms */
    const.current_parms_ptr = addr (text.parms);
    text.parms.title_mode = "1"b;	/* set flag */
    text.parms.left.indent = new_indent;
    text.parms.measure = page.parms.measure;

    goto return_;			/* go process the block */

ctl_ (33):			/* ".bph" = begin-page-header */
bph_ctl:
    if current_parms.title_mode	/* if already in a formatted block */
    then
      do;
        call comp_report_ (2, 0, "Already processing a formatted title block",
	   addr (ctl.info), ctl_line);
        goto bph_err;
      end;

    if ctl.index <= length (ctl_line)	/* if a numeric is given */
         & index ("+-0123456789", substr (ctl_line, ctl.index, 1)) ^= 0
    then call comp_util_$set_bin (new_indent, "header indent", 0, 0,
	    page.parms.measure, hscales, comp_dvt.min_WS);
    else new_indent = 0;

    if ctl.index <= length (ctl_line)	/* if type is given */
    then block_type = substr (ctl_line, ctl.index, 1);
    else block_type = "a";		/* otherwise, all */
				/* even or all */
    if (block_type = "e" | block_type = "a")
    then
      do;
        call comp_util_$relblk (LOOSE, shared.ephdrptr);
        call comp_util_$getblk (LOOSE, shared.ephdrptr, "eh",
	   const.default_parms_ptr, ^EMPTY);
        hfcblk_ptr = shared.ephdrptr;
        hfcblk.parms.page = "1"b;
      end;			/**/
				/* odd or all */
    if (block_type = "o" | block_type = "a")
    then
      do;
        call comp_util_$relblk (LOOSE, shared.ophdrptr);
        call comp_util_$getblk (LOOSE, shared.ophdrptr, "oh",
	   const.default_parms_ptr, ^EMPTY);
        hfcblk_ptr = shared.ophdrptr;
        hfcblk.parms.page = "1"b;
      end;			/**/
				/* unknown block type? */
    else if index ("aeo", block_type) = 0
    then
      do;
        call comp_report_ (2, 0, "Unknown block type.", addr (ctl.info),
	   ctl_line);

bph_err:
        do while (substr (ctl_line, verify (ctl_line, " "), 4) ^= ".hbe"
	   & substr (ctl_line, verify (ctl_line, " "), 4) ^= ".eph");
	call_box_ptr = call_stack.ptr (call_stack.index);
	call comp_read_$line (call_box_ptr, "", "1"b);
	ctl.info = call_box.info;
        end;
        goto return_;
      end;

    hfcblk.hdr.blkptr = shared.blkptr;	/* save pointers for end */
    hfcblk.hdr.parms_ptr = const.current_parms_ptr;
				/* switch block pointers */
    if block_type = "a" | block_type = "o"
    then shared.blkptr = shared.ophdrptr;
    else shared.blkptr = shared.ephdrptr;
				/* dont disturb main body parms */
    const.current_parms_ptr = addr (text.parms);
    text.parms.title_mode = "1"b;	/* set flag */
    text.parms.left.indent = new_indent;
    text.parms.measure = page.parms.measure;

    goto return_;

ctl_ (42):			/* ".btc" = begin-text-caption */
    block_type = "c";
    goto join_btt1;

ctl_ (43):			/* ".btt" = begin-text-title */
    block_type = "h";

join_btt1:			/* initialize local storage */
    new_indent = current_parms.left.indent;

    if ctl.index <= length (ctl_line)	/* if a numeric is given */
         & index ("+-0123456789", substr (ctl_line, ctl.index, 1)) ^= 0
    then call comp_util_$set_bin (new_indent, "title indent", new_indent, 0,
	    current_parms.measure, hscales, comp_dvt.min_WS);

join_btt2:
    if search (block_type, "hc") = 0
    then
      do;				/* unknown block type */
        call comp_report_ (2, 0, "Unknown text title block type.",
	   addr (ctl.info), ctl_line);/**/
				/* skip the block */
        do while (substr (ctl_line, 1, 4) ^= ".tbe"
	   & substr (ctl_line, 1, 4) ^= ".tbe");
	call_box_ptr = call_stack.ptr (call_stack.index);
	call comp_read_$line (call_box_ptr, "", "1"b);
	ctl.info = call_box.info;
        end;

        goto return_;
      end;

    if shared.blkptr = null		/* if no text block yet */
    then
      do;
        if ^(page.hdr.headed | option.galley_opt)
        then call comp_head_page_ (0);
        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	   const.current_parms_ptr, ^EMPTY);
      end;

    if block_type = "h"
    then
      do;
        if text.parms.hdrptr = null	/* if no header block yet */
        then call comp_util_$getblk (LOOSE, text.parms.hdrptr, "th",
	        const.current_parms_ptr, ^EMPTY);
        hfcblk_ptr = text.parms.hdrptr; /**/
				/* set parms */
        hfcblk.parms = current_parms;	/* in case they changed */
        hfcblk.parms.title_mode = "1"b;
        hfcblk.parms.left.indent = new_indent;
				/* save pointers for end */
        hfcblk.hdr.blkptr = shared.blkptr;
        hfcblk.hdr.parms_ptr = const.current_parms_ptr;
				/* switch blocks */
        shared.blkptr = text.parms.hdrptr;
        const.current_parms_ptr = addr (text.parms);
      end;

    else if block_type = "c"
    then
      do;
        if text.parms.ftrptr = null	/* if no footer block yet */
        then call comp_util_$getblk (LOOSE, text.parms.ftrptr, "tf",
	        const.current_parms_ptr, ^EMPTY);
        hfcblk_ptr = text.parms.ftrptr; /**/
				/* set parms */
        hfcblk.parms = current_parms;	/* in case they changed */
        hfcblk.parms.title_mode = "1"b;
        hfcblk.parms.left.indent = new_indent;
				/* save pointers for end */
        hfcblk.hdr.blkptr = shared.blkptr;
        hfcblk.hdr.parms_ptr = const.current_parms_ptr;
				/* switch blocks */
        shared.blkptr = text.parms.ftrptr;
        const.current_parms_ptr = addr (text.parms);
      end;			/**/
				/* if multi-column mode */
    if ^shared.table_mode & page.hdr.col_count > 0
    then text.parms.measure, current_parms.measure = col.parms.measure;

    goto return_;

ctl_ (49):			/* ".cfl" = column-footer-line */
    if ctl.index > length (ctl_line)	/* cancelling? */
    then
      do;
        call comp_util_$relblk (LOOSE, col.ftrptr);
				/* if multicolumn, erase all tracks of it */
        do i = 0 to page.parms.cols.count;
	page.column_ptr (i) -> col.hdr.net =
	     page.column_ptr (i) -> col.hdr.net
	     + page.column_ptr (i) -> col.ftrusd;
	page.column_ptr (i) -> col.ftrusd = 0;
	page.column_ptr (i) -> col.ftrptr = null;
        end;
      end;

    else				/* (re)defining the footer */
      do;
        hfcblk_ptr = col.ftrptr;	/* copy the footer pointer */
				/* if no block yet */
        if hfcblk_ptr = null ()
        then
	do;
	  call comp_util_$getblk (LOOSE, hfcblk_ptr, "rf",
	       const.current_parms_ptr, ^EMPTY);
	  col.ftrptr = hfcblk_ptr;	/* record the new pointer */
				/* set all for multicolumn */
	  if page.parms.cols.count > 0
	  then
	    do i = 1 to page.parms.cols.count;
	      page.column_ptr (i) -> col.ftrptr = hfcblk_ptr;
	    end;
	end;

        if hfcblk.hdr.count = 0	/* re-initialize if empty */
        then
	do;
	  hfcblk.parms.linespace = 12000;
	  hfcblk.parms.art, hfcblk.hdr.art = "0"b;
	end;

        call set_hf_lines ("1"b, hfcblk_ptr, 0);
        col.ftrusd = hfcblk.hdr.used;
        col.hdr.net = col.hdr.net - hfcblk.parms.linespace;
        if page.parms.cols.count > 1
        then
	do i = 1 to page.parms.cols.count;
	  page.column_ptr (i) -> col.ftrusd = hfcblk.hdr.used;
	  page.column_ptr (i) -> col.hdr.net =
	       page.column_ptr (i) -> col.hdr.net - hfcblk.parms.linespace;
	end;
      end;

    goto return_;

ctl_ (50):			/* ".chl" = column-header-line */
    if ctl.index > length (ctl_line)	/* cancelling? */
    then if col.hdrptr ^= null
         then
	 do;
	   col.hdrptr -> text.hdr.count = 0;
	   col.hdrusd = 0;		/* erase hdrusd */

	   if page.parms.cols.count > 0
				/* if multicolumn, erase all hdrusd */
	   then
	     do i = 1 to page.parms.cols.count;
	       if page.column_ptr (i) ^= null
	       then page.column_ptr (i) -> col.hdrusd = 0;
	     end;
	 end;
         else ;

    else				/* (re)defining the header */
      do;				/* if no block yet */
        if col.hdrptr = null ()
        then
	do;
	  call comp_util_$getblk (LOOSE, col.hdrptr, "rh",
	       const.current_parms_ptr, ^EMPTY);
	  col.hdrptr -> text.parms.linespace = 12000;
	  col.hdrptr -> text.parms.art, col.hdrptr -> text.hdr.art = "0"b;
	  unspec (col.hdrptr -> text.parms.cbar) = "0"b;

	  if page.parms.cols.count > 0
	  then
	    do i = 1 to page.parms.cols.count;
	      page.column_ptr (i) -> col.hdrptr = col.hdrptr;
	    end;
	end;

        if shared.bug_mode
        then hfcblk_ptr = col.hdrptr;

        call set_hf_lines ("1"b, col.hdrptr, 0);
        col.hdrusd = col.hdrptr -> text.hdr.used;
        if page.parms.cols.count > 1
        then
	do i = 1 to page.parms.cols.count;
	  page.column_ptr (i) -> col.hdrusd = col.hdrptr -> text.hdr.used;
	end;
      end;

    goto return_;

ctl_ (58):			/* ".ecf" = end-column-footer */
    goto return_;			/* HMMM! */

ctl_ (59):			/* ".ech" = end-column-header */
    goto return_;

ctl_ (64):			/* ".epf" = end-page-footer */
epf_ctl:				/* if not a page footer */
    if (shared.blkptr ^= shared.opftrptr & shared.blkptr ^= shared.epftrptr)
    then goto return_;		/* ignore it */

    if shared.blkptr ^= null ()	/* if there is a block */
    then
      do;
        if ^text.parms.title_mode	/* if not a formatted block */
        then goto return_;		/* ignore it */
				/* even footers */
        if (shared.blkptr = shared.epftrptr
	   & text.hdr.used >= page.parms.net.even)
				/* odd footers */
	   | (shared.blkptr = shared.opftrptr
	   & text.hdr.used >= page.parms.net.odd)
        then
	do;
	  call comp_report_ (2, 0,
	       "Footer block exceeds page size. It will be ignored.",
	       addr (ctl.info), ctl_line);

	  text.hdr.count = 0;	/* erase the whole block */
	  text.input = text_entry;	/* overwrite old text */
	  text.input.ptr = addr (text.input_line);
	  line_area_ptr, hfcblk.line_area.cur = hfcblk.line_area.first;
	  line_area.ndx = 0;
	  text_area_ptr, hfcblk.text_area.cur = hfcblk.text_area.first;
	  text_area.ndx = 1;
	  hfcblk.next_text = text_area.strareaptr (1);
	end;

        else
	do;			/* finish the block */
	  call comp_break_ (format_break, 0);
				/* shut off title flag */
	  text.parms.title_mode = "0"b;

	  if ^option.galley_opt
	  then call comp_util_$set_net_page ("0"b);

	  if block_type = "a"	/* if type is all */
	  then			/* current block is the odd footer */
	    do;			/* copy odd footer to even footer */
	      hfcblk_ptr = shared.epftrptr;
	      hfcblk.parms = text.parms;
	      hfcblk.hdr.count, hfcblk.hdr.used = 0;
				/* overwrite old text */
	      line_area_ptr, hfcblk.line_area.cur = hfcblk.line_area.first;
	      line_area.ndx = 0;
	      text_area_ptr, hfcblk.text_area.cur = hfcblk.text_area.first;
	      text_area.ndx = 1;
	      hfcblk.next_text = text_area.strareaptr (1);

	      do line_area_ptr = text.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do i = 1 to line_area.ndx;
		txtlinptr = line_area.linptr (i);
		call comp_util_$add_text (shared.epftrptr, "0"b, "0"b,
		     "0"b, "0"b, txtlinptr);
	        end;
	      end;

	      if shared.bug_mode
	      then call ioa_$rsnnl (
		      "^5x(hft_ctls: ef=^d e^d u^f hspc=col^d ^f pag^f)",
		      exit_str, 0, shared.epftrptr -> hfcblk.blkndx,
		      shared.epftrptr -> hfcblk.hdr.count,
		      dec (
		      divide (shared.epftrptr -> hfcblk.hdr.used, 12000,
		      31, 10), 11, 3), page.hdr.col_index,
		      dec (divide (col.hdr.pspc, 12000, 31, 10), 11, 3),
		      dec (divide (page.hdr.hdspc, 12000, 31, 10), 11, 3));

	      if ^option.galley_opt
	      then call comp_util_$set_net_page ("0"b);
	    end;			/**/
				/* switch back to text block */
	  const.current_parms_ptr = text.hdr.parms_ptr;
	  shared.blkptr = text.hdr.blkptr;

	  if shared.blkptr ^= null
	  then ctl.font = text.input.font;
	end;
      end;
    goto return_;

ctl_ (65):			/* ".eph" = end-page-header */
eph_ctl:				/**/
				/* if not a page header */
    if (shared.blkptr ^= shared.ophdrptr & shared.blkptr ^= shared.ephdrptr)
    then goto return_;		/* ignore it */

    if shared.blkptr ^= null ()	/* if there is a block */
    then
      do;
        if ^text.parms.title_mode	/* if not a formatted block */
        then goto return_;		/* ignore it */
				/* even headers */
        if (shared.blkptr = shared.ephdrptr
	   & text.hdr.used >= page.parms.net.even)
				/* odd headers */
	   | (shared.blkptr = shared.ophdrptr
	   & text.hdr.used >= page.parms.net.odd)
        then
	do;
	  call comp_report_ (2, 0,
	       "Header block exceeds page size. It will be ignored.",
	       addr (ctl.info), ctl_line);

	  text.hdr.count = 0;	/* erase the whole block */
	  text.input = text_entry;	/* overwrite old text */
	  text.input.ptr = addr (text.input_line);
	  line_area_ptr, hfcblk.line_area.cur = hfcblk.line_area.first;
	  line_area.ndx = 0;
	  text_area_ptr, hfcblk.text_area.cur = hfcblk.text_area.first;
	  text_area.ndx = 1;
	  hfcblk.next_text = text_area.strareaptr (1);
	end;

        else
	do;			/* finish the block */
	  call comp_break_ (format_break, 0);
				/* turn off the block flag */
	  text.parms.title_mode = "0"b;

	  if ^option.galley_opt
	  then call comp_util_$set_net_page ("1"b);

	  if block_type = "a"	/* if odd block of all */
	       & shared.blkptr = shared.ophdrptr
	  then
	    do;			/* copy it to the even block */
	      hfcblk_ptr = shared.ephdrptr;
	      hfcblk.parms = text.parms;
	      hfcblk.hdr.count, hfcblk.hdr.used = 0;
				/* overwrite old text */
	      line_area_ptr, hfcblk.line_area.cur = hfcblk.line_area.first;
	      line_area.ndx = 0;
	      text_area_ptr, hfcblk.text_area.cur = hfcblk.text_area.first;
	      text_area.ndx = 1;
	      hfcblk.next_text = text_area.strareaptr (1);

	      do line_area_ptr = text.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do i = 1 to line_area.ndx;
		txtlinptr = line_area.linptr (i);

		call comp_util_$add_text (shared.ephdrptr, "0"b, "0"b,
		     "0"b, "0"b, txtlinptr);
	        end;
	      end;

	      if shared.bug_mode
	      then call ioa_$rsnnl ("^5x(hft_ctls: eh=^d e^d u^f"
		      || " hspc=col^d ^f pag^f)", exit_str, 0,
		      hfcblk.blkndx, hfcblk.hdr.count,
		      dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
		      page.hdr.col_index,
		      dec (divide (col.hdr.pspc, 12000, 31, 10), 11, 3),
		      dec (divide (page.hdr.hdspc, 12000, 31, 10), 11, 3));

	      if ^option.galley_opt
	      then call comp_util_$set_net_page ("1"b);
	    end;			/**/
				/* switch back to text block */
	  const.current_parms_ptr = text.hdr.parms_ptr;
	  shared.blkptr = text.hdr.blkptr;
	end;
      end;
    goto return_;

ctl_ (68):			/* ".etc" = end-text-caption */
etf_ctl:
ctl_ (69):			/* ".ett" = end-text-title */
ett_ctl:
    if shared.blkptr ^= null ()	/* if there is a block */
    then
      do;
        hfcblk_ptr = shared.blkptr;	/* for debugging */
        if ^text.parms.title_mode	/* not a formatted block? */
        then goto return_;		/* ignore it */
				/* finish the block */
        call comp_break_ (format_break, 0);
				/* save modes for promotion */
        if text.blktype = "th"	/* is this a text header? */
        then
	do;
	  th_keep = text.parms.keep;
	  th_art = text.parms.art;
	end;

        else			/* its a caption */
	do;
	  tf_keep = text.parms.keep;
	  tf_art = text.parms.art;
	end;			/**/
				/* switch back to text block */
        const.current_parms_ptr = text.hdr.parms_ptr;
        shared.blkptr = text.hdr.blkptr;/**/
				/* promote art and keep modes */
        if hfcblk.blktype = "th"	/* is this a text header? */
        then
	do;
	  current_parms.keep = current_parms.keep | th_keep;
	  text.hdr.art, current_parms.art = current_parms.art | th_art;
	end;

        else			/* its a caption */
	do;
	  current_parms.keep = current_parms.keep & tf_keep;
	  current_parms.art = current_parms.art & tf_art;
	end;
      end;

    goto return_;

ctl_ (71):			/* ".fb" = footer-block-begin */
ctl_ (72):			/* ".fbb" = footer-block-begin */
    goto bpf_ctl;

ctl_ (73):			/* ".fbe" = footer-block-end */
    goto epf_ctl;

ctl_ (77):			/* ".fl" ".fla" = footer-line-all */
ctl_ (78):
    hf_lin_key = "a";
    goto join_pfl;

/* ".fle" = footer-line-even */
ctl_ (79):
    hf_lin_key = "e";
    goto join_pfl;

/* ".flo" = footer-line-odd */
ctl_ (80):
    hf_lin_key = "o";
    goto join_pfl;

ctl_ (90):			/* ".hb" = header-block-begin */
ctl_ (91):			/* ".hbb" = header-block-begin */
    goto bph_ctl;

ctl_ (92):			/* ".hbe" = header-block-end */
    goto eph_ctl;

ctl_ (95):			/* ".hl" = header-line */
ctl_ (96):			/* ".hla" = header-line-all */
    hf_lin_key = "a";
    goto join_phl;

/* ".hle" = header-line-even */
ctl_ (97):
    hf_lin_key = "e";
    goto join_phl;

/* ".hlf" = header-line-footnote */
ctl_ (98):			/* if no block yet */
    if shared.footnote_header_ptr = null ()
    then
      do;
        call comp_util_$getblk (LOOSE, shared.footnote_header_ptr, "fh",
	   addr (footnote_parms), ^EMPTY);
				/* no cbars on headers */
        unspec (ftnhdr.parms.cbar) = "0"b;
      end;

    if ctl.index <= length (ctl_line)
    then call set_hf_lines ("1"b, shared.footnote_header_ptr, 0);

    else
      do;
        ftnhdr.hdr.count = 1;
        txtlinptr = ftnhdr.line_area.first -> line_area.linptr (1);
        txtlin.title = "1"b;
        txtlin.linespace, loc_lead = 12000;
        txtlin.font.famndx = comp_dvt.init_fam;
        txtlin.font.memndx = comp_dvt.init_mem;
        txtlin.font.size = comp_dvt.init_ps;
        txtlin.lmarg = 0;
        txtlin.default = "1"b;	/* set default flag */
      end;

    goto return_;

ctl_ (99):			/* ".hlo" = header-line-odd */
    hf_lin_key = "o";
    goto join_phl;

ctl_ (125):			/* ".pfl" = page-footer-line */
pfl_ctl:
    if search (varfld, "aeo") = 1
    then
      do;
        hf_lin_key = comp_read_$name (varfld, 1, fnxt, addr (ctl.info));
        varfld = ltrim (substr (varfld, fnxt));
      end;
    else hf_lin_key = "a";

join_pfl:
    if hf_lin_key = "a" | hf_lin_key = "e"
    then
      do;
        save_varfld = varfld;		/* save for other page if "a" */

        if varfld = ""		/* if cancelling */
        then if shared.epftrptr ^= null
	   then call comp_util_$relblk (LOOSE, shared.epftrptr);
	   else ;

        else
	do;			/* no block yet? */
	  if shared.epftrptr = null ()/* if no block yet */
	  then call comp_util_$getblk (LOOSE, shared.epftrptr, "ef",
		  const.default_parms_ptr, ^EMPTY);
	  hfcblk_ptr = shared.epftrptr;

	  if hfcblk.hdr.count = 0	/* re-initialize if empty */
	  then
	    do;			/* set default parms */
	      hfcblk.parms = current_parms;
	      hfcblk.parms.page = "1"b;
	      hfcblk.parms.linespace = 12000;
	      hfcblk.input.lmarg = 0;
	      hfcblk.input.rmarg, hfcblk.input.net = page.parms.measure;
	    end;

	  call set_hf_lines ("1"b, shared.epftrptr, 0);
	end;

        if ^option.galley_opt
        then
	do;
	  call comp_util_$set_net_page ("0"b);
	  if page.parms.net.even <= 0
	  then
	    do;
	      call comp_report_ (4, 0,
		 "Page footer size results in zero net page size.",
		 addr (ctl.info), ctl_line);
	      signal comp_abort;
	      goto return_;
	    end;
	end;

        if hf_lin_key = "a"
        then
	do;
	  varfld = save_varfld;
	  goto do_pflo;
	end;
      end;

    else if hf_lin_key = "a" | hf_lin_key = "o"
    then
      do;
do_pflo:
        if varfld = ""		/* if cancelling */
        then if shared.opftrptr ^= null
	   then call comp_util_$relblk (LOOSE, shared.opftrptr);
	   else ;

        else
	do;			/* no block yet? */
	  if shared.opftrptr = null ()
	  then call comp_util_$getblk (LOOSE, shared.opftrptr, "of",
		  const.default_parms_ptr, ^EMPTY);
	  hfcblk_ptr = shared.opftrptr;

	  if hfcblk.hdr.count = 0	/* re-initialize if empty */
	  then
	    do;			/* set default parms */
	      hfcblk.parms = current_parms;
	      hfcblk.parms.page = "1"b;
	      hfcblk.parms.linespace = 12000;
	    end;

	  call set_hf_lines ("1"b, shared.opftrptr, 0);
	end;

        if ^option.galley_opt
        then
	do;
	  call comp_util_$set_net_page ("0"b);
	  if page.parms.net.odd <= 0
	  then
	    do;
	      call comp_report_ (4, 0,
		 "Page footer size results in zero net page size.",
		 addr (ctl.info), ctl_line);
	      signal comp_abort;
	      goto return_;
	    end;
	end;
/****        if ^option.galley_opt
/****        then call comp_util_$set_net_page ("0"b);*/
      end;

    else call comp_report_ (2, 0, "Unknown footer position keyword.",
	    addr (ctl.info), ctl_line);

    goto return_;

ctl_ (126):			/* ".phl" = page-header-line */
phl_ctl:
    if search (varfld, "aeo") = 1
    then
      do;
        hf_lin_key = comp_read_$name (varfld, 1, fnxt, addr (ctl.info));
        varfld = ltrim (substr (varfld, fnxt));
      end;
    else hf_lin_key = "a";

join_phl:
    if hf_lin_key = "a" | hf_lin_key = "e"
    then
      do;
        save_varfld = varfld;		/* in case its 'a' */

        if varfld = ""		/* if cancelling */
        then if shared.ephdrptr ^= null
	   then call comp_util_$relblk (LOOSE, shared.ephdrptr);
	   else ;

        else
	do;			/* no block yet? */
	  if shared.ephdrptr = null ()
	  then
	    do;
	      call comp_util_$getblk (LOOSE, shared.ephdrptr, "eh",
		 const.default_parms_ptr, ^EMPTY);
	      hfcblk_ptr = shared.ephdrptr;
	      hfcblk.parms.page = "1"b;
	    end;
	  else hfcblk_ptr = shared.ephdrptr;

	  if hfcblk.hdr.count = 0	/* reset flags if empty */
	  then hfcblk.parms.art, hfcblk.hdr.art = "0"b;

	  call set_hf_lines ("1"b, shared.ephdrptr, 0);
	end;

        if ^option.galley_opt
        then
	do;
	  call comp_util_$set_net_page ("1"b);
	  if page.parms.net.even <= 0
	  then
	    do;
	      call comp_report_ (4, 0,
		 "Page header size results in zero net page size.",
		 addr (ctl.info), ctl_line);
	      signal comp_abort;
	      goto return_;
	    end;
	end;

        if hf_lin_key = "a"
        then varfld = save_varfld;
        else goto return_;
      end;

    if hf_lin_key = "a" | hf_lin_key = "o"
    then
      do;
        if varfld = ""		/* if cancelling */
        then if shared.ophdrptr ^= null
	   then call comp_util_$relblk (LOOSE, shared.ophdrptr);
	   else ;

        else
	do;			/* no block yet? */
	  if shared.ophdrptr = null ()
	  then
	    do;
	      call comp_util_$getblk (LOOSE, shared.ophdrptr, "oh",
		 const.default_parms_ptr, ^EMPTY);
	      hfcblk_ptr = shared.ophdrptr;
	      hfcblk.parms.page = "1"b;
	    end;
	  else hfcblk_ptr = shared.ophdrptr;

	  if hfcblk.hdr.count = 0	/* re-initialize if empty */
	  then
	    do;			/* set default parms */
	      hfcblk.parms.page = "1"b;
	      hfcblk.parms.linespace = 12000;
	      hfcblk.parms.art, hfcblk.hdr.art = "0"b;
	    end;

	  call set_hf_lines ("1"b, shared.ophdrptr, 0);

	  if hfcblk.hdr.count = 0	/* reset flags if empty */
	  then hfcblk.parms.art, hfcblk.hdr.art = "0"b;
	end;

        if ^option.galley_opt
        then
	do;
	  call comp_util_$set_net_page ("1"b);
	  if page.parms.net.odd <= 0
	  then
	    do;
	      call comp_report_ (4, 0,
		 "Page header size results in zero net page size.",
		 addr (ctl.info), ctl_line);
	      signal comp_abort;
	      goto return_;
	    end;
	end;
        goto return_;
      end;

    else call comp_report_ (2, 0, "Unknown header keyword.", addr (ctl.info),
	    ctl_line);

    goto return_;

ctl_ (143):			/* ".stl" = split_header_line */
    if shared.spcl_blkptr ^= null () | ctl.index <= length (ctl_line)
    then
      do;				/* if no block yet */
        if shared.spcl_blkptr = null ()
        then call comp_util_$getblk (LOOSE, shared.spcl_blkptr, "sh",
	        addr (current_parms), ^EMPTY);
        hfcblk_ptr = shared.spcl_blkptr;

        if hfcblk.hdr.count = 0	/* re-initialize if empty */
        then hfcblk.parms = current_parms;

        call set_hf_lines ("1"b, shared.spcl_blkptr, 0);

        if hfcblk.hdr.count = 0	/* reset flags if empty */
        then hfcblk.parms.art, hfcblk.hdr.art = "0"b;
      end;

    goto return_;

ctl_ (148):			/* ".tb" = title-block-begin */
ctl_ (149):			/* ".tbb" = title-block-begin */
    new_indent = current_parms.left.indent;

    if ctl.index <= length (ctl_line)	/* if a numeric is given */
         & index ("+-0123456789", substr (ctl_line, ctl.index, 1)) ^= 0
    then call comp_util_$set_bin (new_indent, "title indent", new_indent, 0,
	    current_parms.measure, hscales, comp_dvt.min_WS);

    if ctl.index < length (ctl_line)	/* skip white space */
    then ctl.index =
	    ctl.index - 1 + verify (substr (ctl_line, ctl.index), " ");

    if ctl.index <= length (ctl_line)
    then block_type = substr (ctl_line, ctl.index, 1);
    else block_type = "h";

    goto join_btt2;

ctl_ (150):			/* ".tbe" = title-block-end */
    goto ett_ctl;

ctl_ (151):			/* ".tcl" = text-caption-line */
tcl_ctl:
    if shared.blkptr = null ()	/* need a text block for hdr ptr */
    then call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	    addr (current_parms), ^EMPTY);

    if text.parms.ftrptr = null ()	/* if no block yet */
    then call comp_util_$getblk (LOOSE, text.parms.ftrptr, "tf",
	    addr (current_parms), ^EMPTY);

    hfcblk_ptr = text.parms.ftrptr;
    hfcblk.parms = current_parms;	/* update parms in case they're old */
    hfcblk.parms.linespace = 12000;

    varfld = substr (ctl_line, ctl.index);

    if search (varfld, "0123456789") = 1
    then				/* is a blank line count given? */
      do;
        blnkct =
	   comp_read_$number (varfld, vscales, 1, fnxt, addr (ctl.info), 0);
        varfld = ltrim (substr (varfld, fnxt));
      end;
    else blnkct = 0;		/* non-numeric = no blank lines */

    if blnkct > 0			/* add leading blank lines */
    then
      do;
        ctl.linespace = blnkct;	/* add white space */
        call comp_space_ (blnkct, text.parms.ftrptr, "1"b, "1"b, "1"b, "0"b);
        ctl.linespace = 12000;
      end;

    if varfld ^= ""			/* if theres more */
    then
      do;
        call set_hf_lines ("0"b, text.parms.ftrptr, 0);
				/* if title isnt null */
/****        if search (varfld, shared.ttl_delim) ^= 0
/****        then col.hdr.pspc = 0;*/
      end;

    if shared.blkptr ^= null ()
    then text.hdr.cap_used = hfcblk.hdr.used;
    goto return_;

ctl_ (153):			/* ".thl" = text-header-line */
thl_ctl:
    if shared.blkptr = null ()	/* if no text block yet */
    then
      do;				/* head page? */
        if ^(page.hdr.headed | option.galley_opt)
        then call comp_head_page_ (0);	/**/

        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "tx",
	   addr (current_parms), ^EMPTY);

        if text.parms.hdrptr = null ()	/* if no block yet */
        then call comp_util_$getblk (LOOSE, text.parms.hdrptr, "th",
	        addr (current_parms), ^EMPTY);
        hfcblk_ptr = text.parms.hdrptr;

        hfcblk.parms = current_parms;	/* update parms in case they're old */
      end;

    else if text.parms.hdrptr ^= null
    then hfcblk_ptr = text.parms.hdrptr;

    else hfcblk_ptr = shared.blkptr;	/**/
				/* numeric = blank line count */
    if search (varfld, "0123456789") = 1
    then
      do;
        blnkct =
	   comp_read_$number (varfld, vscales, 1, fnxt, addr (ctl.info),
	   ercd);
        if ercd ^= 0
        then goto return_;
        varfld = ltrim (substr (varfld, fnxt));
      end;
    else blnkct = 0;		/* non-numeric = no blank lines */
				/* set change bar flags */
    hfcblk.input.cbar = current_parms.cbar;
    current_parms.cbar.del = "0"b;
    if hfcblk.input.cbar.del
    then shared.cbar_type = "";

    if varfld ^= ""			/* if theres more */
    then call set_hf_lines ("0"b, hfcblk_ptr, blnkct);
    else call comp_space_ (blnkct, hfcblk_ptr, "1"b, "1"b, "1"b, "0"b);

/****    col.hdr.pspc = blnkct;*/

    goto return_;

ctl_ (154):			/* ".tlc" = title-line-caption */
    goto tcl_ctl;

ctl_ (155):			/* ".tlh" = title-line-heading */
    goto thl_ctl;

ctl_ (159):			/* ".ttl" = text-title-line */
    goto thl_ctl;

return_:
    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("^5x(hft_ctls:");
        if hfcblk_ptr ^= null
        then call ioa_$nnl (" ^a=^d e^d u^f(^f) hspc=col^d ^f pag^f)^[^/^a^]",
	        hfcblk.blktype, hfcblk.blkndx, hfcblk.hdr.count,
	        dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
	        dec (divide (hfcblk.hdr.trl_ws, 12000, 31, 10), 11, 3),
	        page.hdr.col_index,
	        dec (divide (col.hdr.pspc, 12000, 31, 10), 11, 3),
	        dec (divide (page.hdr.hdspc, 12000, 31, 10), 11, 3),
	        (exit_str ^= ""), exit_str);
        call ioa_ (")");
      end;

    return;
%page;
title:
  entry (blkptr, linptr, line_text, lead);

/* PARAMETERS */

    dcl blkptr	   ptr;		/* the containing block */
    dcl linptr	   ptr;		/* line to added */
    dcl line_text	   char (*) var;	/* title line to be parsed */
    dcl lead	   fixed bin (31);	/* total lead for line */

    hfcblk_ptr = blkptr;		/* copy the block pointer */

    if shared.bug_mode
    then call ioa_ ("title: (^a=^d ld=^f ""^a"")", hfcblk.blktype,
	    hfcblk.blkndx, dec (divide (lead, 12000, 31, 10), 11, 3),
	    comp_util_$display (line_text, 0, "0"b));
				/* if theres no delimiter */
    if index (line_text, shared.ttl_delim) ^= 1
    then
      do;
        call comp_report_ (0, 0, "<title> must start with a title delimiter.",
	   addr (ctl.info), ctl_line);
        goto ttl_return;
      end;

    if index (line_text, "*") ^= 0 & ^hfcblk.parms.art
    then call comp_util_$escape (line_text, addr (ctl.info));

    call title_ (lead, linptr, line_text,
         bin (hfcblk_ptr = shared.blank_footer_ptr
         | hfcblk_ptr = shared.blank_header_ptr
         | hfcblk_ptr = shared.opftrptr | hfcblk_ptr = shared.ophdrptr
         | hfcblk_ptr = shared.epftrptr | hfcblk_ptr = shared.spcl_blkptr));

    blkptr = hfcblk_ptr;		/* in case the block grew */

ttl_return:
    if shared.bug_mode
    then call ioa_ ("^5x(title: ^a=^d e^d u^f(^f)^[ A^]", hfcblk.blktype,
	    hfcblk.blkndx, hfcblk.hdr.count,
	    dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
	    dec (divide (hfcblk.hdr.trl_ws, 12000, 31, 10), 11, 3),
	    hfcblk.hdr.art);
%page;
set_hf_lines:
  proc (ndx_flag, blkptr, lead);

/* PARAMETERS */

    dcl ndx_flag	   bit (1);	/* 1 = indexed block,
				   0 = formatted block */
    dcl blkptr	   ptr;		/* pointer to receiving block */
    dcl lead	   fixed bin (31);	/* total lead */

    dcl (index, max)   builtin;

    hfcblk_ptr = blkptr;		/* copy the block pointer */

    if shared.bug_mode
    then call ioa_ ("set_hf_lines: (^[NDX^;FMT^] "
	    || "^a=^d e^d u^f(^f) xld=^f) ^[^/^5x^]""^a""", ndx_flag,
	    hfcblk.blktype, hfcblk.blkndx, hfcblk.hdr.count,
	    dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
	    dec (divide (hfcblk.hdr.trl_ws, 12000, 31, 10), 11, 3),
	    dec (divide (lead, 12000, 31, 10), 11, 3),
	    (length (varfld) > 40), comp_util_$display (varfld, 0, "0"b));

    if varfld = ""			/* if no variable field */
    then
      do;
cancel_all:
        hfcblk.hdr.mx_ttl_ndx, hfcblk.hdr.count, hfcblk.hdr.used = 0;
        goto set_return;
      end;

    if ndx_flag			/* if an indexed block */
    then
      do;
        if search (varfld, "0123456789") = 1
        then
	do;			/* if a line index is given */
	  lino =
	       comp_read_$number (varfld, unscaled, 1, fnxt, addr (ctl.info),
	       0);
	  varfld = ltrim (substr (varfld, fnxt));
				/* check lino for ... */
	  if (lino > divide (page.parms.net.even, 12000, 31, 10)
	       & (hfcblk_ptr = shared.spcl_blkptr
				/* even pages */
	       | hfcblk_ptr = shared.epftrptr))
	       | (lino > divide (page.parms.net.odd, 12000, 31, 10)
				/* odd pages */
	       & (hfcblk_ptr = shared.ophdrptr | blkptr = shared.opftrptr))
	  then
	    do;
	      call comp_report_ (2, 0,
		 "Invalid header/footer index value,"
		 || " it exceeds lines left on page.", addr (ctl.info),
		 ctl_line);
	      goto set_return;
	    end;

	  else if lino = 0		/* cancel all for a zero and */
	  then if varfld = ""	/* theres nothing more */
	       then goto cancel_all;
	       else goto replace_all;
	end;

        else
	do;
replace_all:
	  lino = 1;		/* otherwise, this is line 1 of 1 */
	  hfcblk.hdr.count = 0;	/* erase the block */
				/* overwrite old text */
	  line_area_ptr, hfcblk.line_area.cur = hfcblk.line_area.first;
	  line_area.ndx = 0;
	  text_area_ptr, hfcblk.text_area.cur = hfcblk.text_area.first;
	  text_area.ndx = 1;
	  hfcblk.next_text = text_area.strareaptr (1);
	end;			/**/
				/* the line may already exist */
        if lino <= hfcblk.hdr.mx_ttl_ndx
        then
	do line_area_ptr = hfcblk.line_area.first
	     repeat (line_area.next) while (line_area_ptr ^= null);
	  do ii = 1 to line_area.ndx;
	    txtlinptr = line_area.linptr (ii);
				/* discard lines with this index */
	    if txtlin.title_index = lino
	    then
	      do;			/* adjust space used */
	        hfcblk.hdr.used = hfcblk.hdr.used - txtlin.linespace;
	        txtlin.linespace = 0; /* make it null */
	        txtlin.ptr -> txtstr = "";
	      end;
	  end;
	end;
      end;
    else lino = 0;			/* for text titles */
				/* if theres more */
    if varfld ^= ""			/* and its numeric */
         & search (varfld, "+-0123456789") = 1
    then
      do;
        if index ("+-", substr (varfld, 1, 1)) ^= 0
        then hfcblk.input.lmarg =	/* an adjustment */
	        max (0,
	        current_parms.left.indent
	        +
	        comp_read_$number (varfld, hscales, 1, fnxt, addr (ctl.info),
	        0));
        else hfcblk.input.lmarg =	/* a column */
	        comp_read_$number (varfld, hscales, 1, fnxt, addr (ctl.info),
	        0);
        varfld = ltrim (substr (varfld, fnxt));
      end;

    else if ndx_flag
    then hfcblk.input.lmarg = 0;

    else hfcblk.input.lmarg =
	    hfcblk.parms.left.indent - hfcblk.parms.left.undent;

    hfcblk.input.rmarg =
         hfcblk.parms.measure - hfcblk.parms.right.indent
         + hfcblk.parms.right.undent;

    if varfld ^= ""			/* if theres more */
    then
      do;
        if index (varfld, shared.ttl_delim) ^= 1
        then
	do;			/* if theres no delimiter */
	  call comp_report_ (0, 0,
	       "<title> must start with a title delimiter.", addr (ctl.info),
	       ctl_line);
	  goto set_return;
	end;

        if ndx_flag
        then
	do;
	  call title_ (hfcblk.parms.linespace, addr (hfcblk.input), varfld,
	       lino);
/****	  call comp_space_ (hfcblk.parms.linespace, hfcblk_ptr, "1"b, "1"b,
/****	       (unspec (hfcblk.parms.cbar) ^= "0"b), "0"b);*/
	end;

        else
	do;
	  call title_ (hfcblk.parms.linespace, addr (hfcblk.input), varfld,
	       lino);
/****	  call comp_space_ (hfcblk.parms.linespace, hfcblk_ptr, "1"b, "1"b,
/****	       (unspec (hfcblk.parms.cbar) ^= "0"b), "0"b);*/
	end;

        if lead > 0			/* add the extra lead */
        then call comp_space_ (lead, hfcblk_ptr, "1"b, "1"b,
	        (unspec (hfcblk.parms.cbar) ^= "0"b), "0"b);
      end;

    if ndx_flag
    then
      do;
        hfcblk.hdr.mx_ttl_ndx = max (hfcblk.hdr.mx_ttl_ndx, lino);

        hfcblk.hdr.used = 0;
        do line_area_ptr = hfcblk.line_area.first repeat (line_area.next)
	   while (line_area_ptr ^= null);
	do ii = 1 to line_area.ndx;
	  txtlinptr = line_area.linptr (ii);
	  hfcblk.hdr.used = hfcblk.hdr.used + txtlin.linespace;
	end;
        end;
      end;

set_return:
    if shared.bug_mode
    then call ioa_ ("^5x(set_hf_lines: ^a=^d e=^d u=^f(^f))", hfcblk.blktype,
	    hfcblk.blkndx, hfcblk.hdr.count,
	    dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
	    dec (divide (hfcblk.hdr.trl_ws, 12000, 31, 10), 11, 3));

    return;
  end set_hf_lines;
%page;
/* contruct an expanded <title> line */
title_:
  proc (lead, linptr, p_field, lndx);

/* PARAMETERS */

    dcl lead	   fixed bin (31);	/* total lead for line */
    dcl linptr	   ptr;		/* line to be expanded */
    dcl p_field	   char (*) var;
    dcl lndx	   fixed bin;	/* line index for page header/footer,
				   0 for all other */

/* LOCAL STORAGE */

    dcl artline	   char (1020) var; /* title line with artwork */
    dcl field	   char (1020) var;
    dcl (ipart, k, l)  fixed;		/* working index */
    dcl 1 line	   aligned like text_entry based (linptr);
    dcl meas	   bit (1);	/* controls part measuring */
				/* for title measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl part	   char (1020) var based (addr (hfcblk.input_line));
    dcl part_added	   bit (1);
    dcl pquad	   (3) bit (6);	/* part alignments */
    dcl pwidth	   fixed bin (31);	/* width of a part */
    dcl 1 shift_ctl	   like dclong_val; /* for part positioning */
    dcl shift_str	   char (7) based (shift_str_ptr);
    dcl shift_str_ptr  ptr;		/* expanded text */
    dcl tlen	   fixed bin (21);	/* for WS control */

    dcl (index, max)   builtin;

    if shared.bug_mode
    then call ioa_ ("title_: (ln=^d ld=^f ""^a"")", lndx,
	    dec (divide (lead, 12000, 31, 10), 11, 3),
	    comp_util_$display (p_field, 0, "0"b));

    field = p_field;		/* copy the field */

    shift_str_ptr = addr (shift_ctl);
    shift_ctl.leng = dclong1_len;
    shift_ctl.mark = DC1;
    shift_ctl.type = type_slx;
    part_added = "0"b;
    artline, part = "";
    pquad (1) = quadl;
    pquad (2) = quadc;
    pquad (3) = quadr;

    hfcblk.input.info = ctl.info;
    hfcblk.input.width, hfcblk.input.linespace = 0;
    hfcblk.input.title_index = lndx;
    hfcblk.input.title = "1"b;
    hfcblk.input.art = hfcblk.parms.art;
    hfcblk.input.cbar = hfcblk.parms.cbar;
    hfcblk.input.cur.font, hfcblk.input.font =
         hfcblk.parms.fntstk.entry (hfcblk.parms.fntstk.index);
    tlen = 0;			/* title starts out null */
				/* trim opening delimiter */
    field = after (field, shared.ttl_delim);
				/* for each title part */
    do ipart = 1 to 3 while (field ^= "");
				/* extract a part */
      part = before (field, shared.ttl_delim);
      field = after (field, part);
find_closer:			/* if its escaped */
      if (index (reverse (part), "ż") = 1 | index (reverse (part), "*") = 1)
	 & index (reverse (part), "ż" || "ż") ^= 1
	 & index (reverse (part), "*" || "*") ^= 1
	 & index (reverse (part), "*" || "ż") ^= 1
      then
        do;
	part = part || shared.ttl_delim;
	field = after (field, shared.ttl_delim);
	part = part || before (field, shared.ttl_delim);
	field = shared.ttl_delim || after (field, shared.ttl_delim);
	goto find_closer;
        end;

      if part ^= ""			/* anything there? */
      then
        do;
	if hfcblk.hdr.colno >= 0	/* measure now? */
	then meas = (ipart > 1) & ^hfcblk.input.art;
	else meas = "0"b;		/* measure later */
	tlen = tlen + length (part);	/**/
				/* if no art, add part to block */
	if ^hfcblk.input.art
	then
	  do;
	    hfcblk.input.quad = pquad (ipart);
	    hfcblk.input_line = part;
	    part_added = "1"b;
	    call comp_util_$add_text (hfcblk_ptr, meas, ^hfcblk.input.art,
	         "0"b, "0"b, addr (hfcblk.input));
	  end;

	else
	  do;			/* accumulate artwork parts */
	    unspec (meas1) = "0"b;
	    call comp_measure_ (part, addr (hfcblk.input.font), "0"b, "1"b,
	         pquad (ipart), 0, addr (meas1), addr (meas2),
	         addr (ctl.info));
	    pwidth = meas1.width + meas1.avg;

	    if ipart = 1		/* first part */
	    then
	      do;
	        artline = part;
	        hfcblk.input.width = pwidth;
	      end;

	    else if ipart = 2	/* second part */
	    then
	      do;
	        shift_ctl.v1 =
		   -hfcblk.input.width
		   + comp_dvt.min_WS
		   *
		   round (
		   divide (hfcblk.input.net - pwidth - ctl.lmarg,
		   2 * comp_dvt.min_WS, 31, 1), 0);
	        artline = artline || shift_str || part;
	        hfcblk.input.width =
		   hfcblk.input.width + shift_ctl.v1 + pwidth;
	      end;

	    else if ipart = 3	/* third part */
	    then
	      do;
	        shift_ctl.v1 =
		   hfcblk.input.net - max (pwidth, shared.EN_width)
		   - hfcblk.input.width;
	        artline = artline || shift_str || part;
	        hfcblk.input.width =
		   hfcblk.input.width + shift_ctl.v1 + pwidth;
	      end;
	  end;
        end;

      field = after (field, shared.ttl_delim);
    end;

    if hfcblk.input.art		/* add art line to block */
    then
      do;
        hfcblk.input_line = artline;
        hfcblk.input.quad = quadl;
        part_added = "1"b;
        call comp_util_$add_text (hfcblk_ptr, "0"b, "0"b, "0"b, "0"b,
	   addr (hfcblk.input));
      end;

    if lead > 0			/* add given lead */
    then
      do;
        if part_added		/* if anything was added */
        then
	do;
	  line_area_ptr = hfcblk.line_area.cur;
	  line_area.linptr (line_area.ndx) -> txtlin.linespace = lead;
	  hfcblk.hdr.used = hfcblk.hdr.used + lead;

	  if (shared.table_mode | hfcblk.tblblk) & hfcblk.colno >= 0
	  then
	    do;
	      tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
	      tblcolptr = tblfmt.colptr (tblfmt.ccol);
	      tblcol.depth = tblcol.depth + lead;
	      tblfmt.maxdepth = max (tblfmt.maxdepth, tblcol.depth);
	    end;
	end;

        else
	do;
	  call comp_space_ (lead, hfcblk_ptr, "1"b, "1"b,
	       (unspec (hfcblk.parms.cbar) ^= "0"b), "0"b);
	  hfcblk.line_area.cur
	       -> line_area.linptr (hfcblk.line_area.cur -> line_area.ndx)
	       -> txtlin.title_index = lino;
	end;
      end;

    hfcblk.input_line = "";		/* erase leftovers */
    hfcblk.input.linespace = hfcblk.parms.linespace;
    hfcblk.input.quad = hfcblk.parms.quad;

    if shared.bug_mode
    then call ioa_ ("^5x(title_: ^a=^d e^d u^f(^f)^[ A^])", hfcblk.blktype,
	    hfcblk.blkndx, hfcblk.hdr.count,
	    dec (divide (hfcblk.hdr.used, 12000, 31, 10), 11, 3),
	    dec (divide (hfcblk.hdr.trl_ws, 12000, 31, 10), 11, 3),
	    hfcblk.hdr.art);

  end title_;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_DCdata;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include comp_dvt;
%include compstat;

  end comp_hft_ctls_;




		    comp_init_.pl1                  04/23/85  1059.2rew 04/23/85  0910.0      287280



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

/*	compose subroutine to initialize the internal data base */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_init_:
  proc;
    return;			/* no entry here */

/* LOCAL STORAGE */

    dcl date_time_string
		   char (16);	/* current date and time */
    dcl debug_sw	   bit (1);	/* effective debug switch */
    dcl ercd	   fixed bin (35);	/* system error code */

    dcl (addr, min, null, size)
		   builtin;
    dcl cleanup	   condition;

    dcl clock_	   entry returns (fixed bin (71));
    dcl com_err_	   entry options (variable);
    dcl date_time_	   entry (fixed bin (71), char (*));
    dcl translator_temp_$get_segment
		   entry (char (*) aligned, ptr, fixed bin (35));

/* CONSTANT STATIC STORAGE */

    dcl builtin_names  (80) char (32) static options (constant)
		   init ("AlignMode", "ArgCount", "Args", "ArtMode",
		   "BlockIndex", "BlockName", "CallingFileName",
		   "CallingLineNo", "ChangeBar", "CommandArgCount", "Date",
		   "Device", "DeviceClass", "DeviceName", "DotAddLetter",
		   "Eqcnt", "EqMode", "ExtraMargin", "FileName",
		   "FillMode", "FirstPass", "FontName", "Footcnt",
		   "FootnoteMode", "FootReset", "From", "FrontPage",
		   "Galley", "HeadSpace", "Hyphenating", "Indent",
		   "IndentRight", "InputDirName", "InputFileName",
		   "InputLineno", "InsertIndex", "KeepMode",
		   "LineNumberOpt", "LineInput", "LinesLeft", "LineSpace",
		   "Measure", "NextPageNo", "OutputFileOpt", "PageBlock",
		   "PageCount", "PageLength", "PageLine", "PageNo",
		   "PageSpace", "PageWidth", "Parameter", "ParamPresent",
		   "Pass", "PictureCount", "PointSize", "Print", "StopOpt",
		   "SymbolDelimiter", "TableMode", "TextDepth",
		   "TextWidth", "Time", "TitleDelimiter", "To", "TrTable",
		   "Undent", "UndentRight", "UserInput", "VMargBottom",
		   "VMargFooter", "VMargHeader", "VMargTop", "WaitOpt",
		   "Widow", "WidowFoot",
				/**/
		   (4) (32)"");	/* set spares to PADs */

    dcl 1 initial_page_parms		/* initial page formatting parms */
		   aligned static options (constant),
	2 init_page_depth
		   fixed bin (31),	/* initial page depth */
	2 length	   fixed bin (31) init (792000),
				/* page length */
	2 lmarg,			/* page left margins */
	  3 even	   fixed bin (31) init (0),
	  3 odd	   fixed bin (31) init (0),
	2 margin,			/* margin values */
	  3 top	   fixed bin (31),
	  3 header   fixed bin (31),
	  3 footer   fixed bin (31),
	  3 bottom   fixed bin (31),
	2 measure	   fixed bin (31),	/* line space available for text */
	2 net,			/* net usable space on page */
	  3 even	   fixed bin (31),	/* even pages */
	  3 odd	   fixed bin (31),	/* odd pages */
	2 cols,			/* columns defined for the page */
				/* 1= balance columns */
	  3 bal	   bit (1) unal init ("1"b),
	  3 MBZ	   bit (17) unal init ((17)"0"b),
				/* the number of columns */
	  3 count	   fixed bin unal init (0);
				/* force following structure to even */
    dcl dummy	   ptr init (null ()) static options (constant);

    dcl 1 initial_shared		/* initial shared data values */
		   aligned static options (constant),
	2 version	   fixed bin (35),	/* version of this structure */
	2 chars,			/**/
	( 3 sym_delim		/* delimiter for symbols */
		   init ("%"),
	  3 ttl_delim		/* delimiter for title parts */
		   init ("|"),
	  3 wrd_brkr init (" ")	/* word break character */
	  )	   char (1) unal,
	  3 PAD	   char (1) unal init (""),
	2 cbar_type		/* change bar type */
		   char (4) var init (""),
	2 dot_add_letter		/* dot page add letter (= PAD) */
		   char (1) var init (""),
				/* width of EN in current font */
	2 EN_width   fixed bin (31) init (0),
				/* equation reference counter */
	2 eqn_refct  fixed bin init (1),
	2 footref_fcs		/* footnote ref FCS string */
		   char (8) init (""),
				/* footnote reset mode */
	2 ftn_reset  char (8) var init ("paged"),
				/* footnote ref counter */
	2 ftnrefct   fixed bin init (1),
				/* least word part size for hyphing */
	2 hyph_size  fixed bin (31) init (3),
	2 if_nest,		/* if/then/else logic control */
				/* depth of logic nest */
	  3 ndx	   fixed bin init (0),
	  3 e	   (25),		/* nest entries */
				/* .if control switch */
	    4 sw	   fixed bin,	/* 0=off, 1=(then), -1=(else) */
	    4 info   like text_entry.info,
	    4 line   char (256) var,	/* the control line */
	2 indctl,			/* indent ctls stack */
				/* current level */
	  3 ndx	   fixed bin init (0),
				/* switch bits */
	  3 stk	   (0:35) bit (1) unal init ((36) (1)"0"b),
	2 input_dirname		/* dir containing current input file */
		   char (168) var init (""),
	2 input_filename		/* current input file name */
		   char (200) var init (""),
	2 lead			/* current linespacing value */
		   fixed bin (31) init (0),
	2 lit_count  fixed bin (35) init (0),
				/* count of literal lines */
	2 next_pagenmbr		/* next page number */
		   char (32) var init ("1"),
	2 output_file		/* output file identifier */
		   char (32) var init (""),
	2 pagecount		/* number of pages produced */
		   fixed bin init (0),
	2 pagenum,		/* page number structure */
				/* level currently counting */
	  3 index	   fixed bin init (1),
				/* separator chars (NULs) */
	  3 sep	   (20) char (1) unal init ((20) (1)""),
				/* the counters */
	  3 nmbr	   (20) fixed bin (31) init ((20) 0),
				/* display modes */
	  3 mode	   (20) fixed bin (8) unal init ((20) 0),
				/* command line parameter */
	2 parameter  char (254) var init (""),
				/* passed parameter flag */
	2 param_pres bit (1) unal init ("0"b),
	2 pass_counter
		   fixed bin init (1),
				/* pass counter */
	2 picture,		/* picture blocks */
	  3 count	   fixed bin init (0),
	  3 space			/* total picture space */
		   fixed bin (31) init (0),
	  3 blk	   (10),		/* picture blocks */
	    4 type		/* type = page/col */
		   char (4) init ((10) (0)""),
	    4 place		/* place = top/cen/bot */
		   char (4) init ((10) (0)""),
	    4 ptr			/* pointer to block */
		   ptr init ((10) null),
	    4 size		/* size of picture */
		   fixed bin (31) init ((10) 0),
	2 ptrs,
	( 3 aux_file_data_ptr,	/* -> auxiliary file data */
	  3 blank_footer_ptr,	/* -> blank page footer */
	  3 blank_header_ptr,	/* -> blank page header */
	  3 blank_text_ptr,		/* -> blank page text */
	  3 blkptr,		/* -> active text */
	  3 colptr,		/* current column */
	  3 compout_ptr,		/* iocb pointer for output */
	  3 compx_ptr,		/* iocb pointer for compx file */
	  3 ctb_ptr,		/* current line artwork table */
	  3 epftrptr,		/* even page footer block */
	  3 ephdrptr,		/* even page header block */
	  3 fcb_ptr,		/* input file control block pointer */
	  3 ftnblk_data_ptr,	/* footnote block data */
	  3 footnote_header_ptr,	/* footnote header */
	  3 graphic_page_ptr,	/* graphic output page */
	  3 hit_data_ptr,		/* hit data pointer */
	  3 htab_ptr,		/* horizontal tab tables */
	  3 hwrd_data_ptr,		/* local hyphenation table */
	  3 insert_ptr,		/* data entry for current file */
	  3 opftrptr,		/* odd page footer block */
	  3 ophdrptr,		/* odd page header block */
	  3 ptb_ptr,		/* previous line artwork table */
	  3 spcl_blkptr,		/* "special" block pointer */
	  3 tbldata_ptr,		/* table column data */
	  3 tblkdata_ptr,		/* text block data array */
	  3 text_header_ptr		/* empty text header structure */
	  )	   ptr init (null),
	2 scale,			/* space conversion scale factors */
	  3 horz	   fixed bin (31) init (7200),
				/* horizontal */
	  3 vert	   fixed bin (31) init (12000),
				/* vertical */
	2 source_filename		/* source file name */
		   char (200) var init (""),
	2 sws,			/* switch bits */
	( 3 bug_mode init ("0"b),	/* debug mode */
	  3 compout_not_headed	/* compout not headed */
		   init ("1"b),
	  3 end_input		/* EOF for current input file */
		   init ("0"b),
	  3 end_output		/* 1 = no more output is wanted */
		   init ("0"b),
	  3 firstpass		/* 1 = first pass over input */
		   init ("1"b),
	  3 ftn_mode init ("0"b),	/* 1 = in footnote mode */
	  3 hyph_mode		/* hyphenating mode */
		   init ("0"b),
	  3 inserting_hfc		/* inserting hdr, ftr, or cap */
		   init ("0"b),
	  3 literal_mode		/* literal line mode flag */
		   init ("0"b),
	  3 pageblock		/* blocks belong to page */
		   init ("0"b),
	  3 picture_mode		/* building a picture */
		   init ("0"b),
	  3 print_flag		/* producing output */
		   init ("0"b),
	  3 purge_ftns		/* purging footnotes */
		   init ("0"b),
	  3 suppress_footref	/* supress number */
		   init ("0"b),
	  3 table_mode		/* 1 = in table mode */
		   init ("0"b)
	  )	   bit (1) unal,
	  3 MBZ	   bit (21) unal init ((21)"0"b),
	2 trans,			/* trans table for .tr */
	  3 in	   char (128) var init (""),
				/* input chars */
	  3 out	   char (128) var init (""),
				/* output chars */
	2 widow_size fixed bin (31) init (2),
				/* widow size */
	2 widow_foot fixed bin (31) init (1);
				/* widow size for footnotes */

    dcl 1 init_default_parms
		   aligned static options (constant),
	2 sws,			/* control switches */
				/* text alignment mode */
	  3 quad	   bit (6) unal init ("000001"b),
				/* artwork block flag */
	  3 art	   bit (1) unal init ("0"b),
	  3 cbar,			/* change bar flags */
				/* text addition flag */
	    4 add	   bit (1) unal init ("0"b),
				/* text deletion flag */
	    4 del	   bit (1) unal init ("0"b),
				/* text modification flag */
	    4 mod	   bit (1) unal init ("0"b),
	  3 fill_mode		/* fill mode */
		   bit (1) unal init ("1"b),
				/* block is a footnote */
	  3 footnote bit (1) unal init ("0"b),
				/* OBSOLETE */
	  3 hfc	   bit (1) unal init ("0"b),
	  3 htab_mode		/* horizontal tab mode flag */
		   bit (1) unal init ("0"b),
				/* keep mode */
	  3 keep	   bit (1) unal init ("0"b),
				/* block belongs to page */
	  3 page	   bit (1) unal init ("0"b),
	  3 title_mode		/* 1 = <title>s OK */
		   bit (1) unal init ("0"b),
	  3 MBZ	   bit (19) unal init ((19)"0"b),
	2 ftrptr	   ptr init (null), /* text caption block */
	2 cbar_level		/* change level for cbars */
		   char (1) aligned init (""),
	2 hdrptr	   ptr init (null), /* text header block */
	2 left,			/* left margin data */
	  3 indent   fixed bin (31) init (0),
	  3 undent   fixed bin (31) init (0),
				/* line spacing */
	2 linespace  fixed bin (31) init (12000),
				/* line space available for text */
	2 measure	   fixed bin (31) init (0),
	2 right	   like init_default_parms.left,
				/* arrays to the back of the bus, please! */
	2 fntstk,			/* stack of last 20 font changes */
				/* which one in use */
	  3 index	   fixed bin init (0),
	  3 entry	   (0:19) like fntstk_entry;
				/* the stack entries */
				/* empty text header structure */
    dcl 1 initial_text_header
		   aligned static options (constant),
	2 sws,			/* control switches */
	( 3 art	   init ("0"b),	/* block has artwork */
	  3 dfrftn   init ("0"b),	/* block is a deferred footnote */
	  3 modified init ("0"b),	/* block has modified lines */
	  3 no_trim  init ("0"b),	/* dont trim WS block */
	  3 oflo_ftn init ("0"b),	/* overflow footnote */
	  3 orphan   init ("0"b),	/* footnote is an orphan */
	  3 picture  init ("0"b),	/* picture block */
	  3 tblblk   init ("0"b),	/* a table block */
	  3 unref	   init ("0"b),	/* block is an unreffed footnote */
	  3 white	   init ("0"b)	/* block is a white space block */
	  )	   bit (1) unal,
	  3 MBZ	   bit (26) unal init ((26)"0"b),
				/* artwork line counter */
	2 art_count  fixed bin unal init (0),
	2 blkptr	   ptr init (null), /* pointer to suspended block */
				/* line count of text caption */
	2 cap_size   fixed bin unal init (0),
				/* size of text caption */
	2 cap_used   fixed bin (31) init (0),
				/* containing column */
	2 colno	   fixed bin unal init (0),
				/* line count for block */
	2 count	   fixed bin unal init (0),
				/* counter for equation lines */
	2 eqn_line_count
		   fixed bin unal init (0),
				/* OBSOLETE */
	2 first_text fixed bin unal init (0),
	2 ftn,			/* footnotes in the block */
				/* number */
	  3 ct	   fixed bin init (0),
				/* space needed */
	  3 usd	   fixed bin (31) init (0),
				/* block index values */
	  3 blkndx   (40) fixed bin init ((40) 0),
				/* line count of text header */
	2 head_size  fixed bin init (0),
				/* size of text header */
	2 head_used  fixed bin (31) init (0),
				/* block index of next output line */
	2 index	   fixed bin unal init (1),
				/* to count input keep lines */
	2 keep_count fixed bin unal init (0),
				/* last text line in column */
	2 last_line  fixed bin init (0),
				/* max title index value in block */
	2 mx_ttl_ndx fixed bin init (0),
				/* block name, if any */
	2 name	   char (32) var init (""),
	2 nofill_count		/* to count nofill lines */
		   fixed bin init (0),
	2 parms_ptr  ptr init (null), /* pointer to suspended parms */
				/* inter-unit reference */
	2 refer	   fixed bin init (0),
	2 refer_index		/* OBSOLETE */
		   fixed bin init (0),
	2 split			/* split point for balancing */
		   fixed bin init (0),
	2 trl_ws			/* trailing WS */
		   fixed bin (31) init (0),
	2 used			/* space used by a block */
		   fixed bin (31) init (0);
				/* initial symbol tree structure */
    dcl 1 init_tree_var		/* dimension MUST = MAX_TREE_AREA_CT */
		   (80) aligned static options (constant),
				/* type flags */
	2 flags	   bit (9) aligned init
				/**/
		   ("001001000"b,	/* AlignMode - string function */
		   "100010001"b,	/* ArgCount - stack numeric */
		   "001000001"b,	/* Args - stack string */
		   "000101000"b,	/* ArtMode - flag function*/
		   "100001000"b,	/* BlockIndex - binary function */
		   "001001000"b,	/* BlockName - string function */
		   "001001000"b,	/* CallingFileName - string function */
		   "100001000"b,	/* CallingLineNo - binary function */
		   "001000000"b,	/* ChangeBar - string */
		   "100000000"b,	/* CommandArgCount - binary */
		   "001000000"b,	/* Date - string */
		   "001000000"b,	/* Device - string */
		   "001001000"b,	/* DeviceClass - string function */
		   "001001000"b,	/* DeviceName - string function */
		   "001001000"b,	/* DotAddLetter - string function */
		   "100000000"b,	/* Eqcnt - binary */
		   "000101000"b,	/* EqMode - flag function */
		   "100000100"b,	/* ExtraMargin - horiz numeric */
		   "001000000"b,	/* FileName - string */
		   "000101000"b,	/* FillMode - flag function */
		   "000100000"b,	/* FirstPass - flag */
		   "001001000"b,	/* FontName - string function */
		   "100000000"b,	/* Footcnt - binary */
		   "000100000"b,	/* FootnoteMode - flag */
		   "001000000"b,	/* FootReset - string */
		   "001000000"b,	/* From - string */
		   "000101000"b,	/* FrontPage - flag function */
		   "000100000"b,	/* Galley - flag */
		   "100001010"b,	/* HeadSpace - vert numeric function */
		   "000100000"b,	/* Hyphenating - flag */
		   "100001100"b,	/* Indent - horiz num fcn */
		   "100001100"b,	/* IndentRight - horiz num fcn */
		   "001000000"b,	/* InputDirName - string */
		   "001000000"b,	/* InputFileName - string */
		   "100001000"b,	/* InputLineno - binary function */
		   "100000000"b,	/* InsertIndex - binary */
		   "000101000"b,	/* KeepMode - flag function */
		   "000100000"b,	/* LineNumberOpt - flag */
		   "001001000"b,	/* LineInput - string function */
		   "100001010"b,	/* LinesLeft - vert numeric function */
		   "100001010"b,	/* LineSpace - vert numeric function */
		   "100001100"b,	/* Measure - horiz numeric function */
		   "001001000"b,	/* NextPageNo - string function */
		   "000100000"b,	/* OutputFileOpt - flag */
		   "000100000"b,	/* PageBlock - flag */
		   "100001000"b,	/* PageCount - binary function */
		   "100001010"b,	/* PageLength - vert num function */
		   "100001010"b,	/* PageLine - vert num function */
		   "001001000"b,	/* PageNo - string function */
		   "100000000"b,	/* PageSpace - binary */
		   "100000100"b,	/* PageWidth - horiz numeric */
		   "001000000"b,	/* Parameter - string */
		   "000100000"b,	/* ParamPresent - flag */
		   "100000000"b,	/* Pass - binary */
		   "100000000"b,	/* PictureCount - binary */
		   "100011000"b,	/* PointSize - num function */
		   "000100000"b,	/* Print - flag */
		   "000100000"b,	/* StopOpt - flag */
		   "001001000"b,	/* SymbolDelimiter - string function */
		   "000100000"b,	/* TableMode - flag */
		   "100001010"b,	/* TextDepth - vert num function */
		   "100001100"b,	/* TextWidth - horiz num function */
		   "001000000"b,	/* Time - string */
		   "001001000"b,	/* TitleDelimiter - string function */
		   "001000000"b,	/* To - string */
		   "001001000"b,	/* TrTable - string function */
		   "100001100"b,	/* Undent - horiz num fcn */
		   "100001100"b,	/* UndentRight - horiz num fcn */
		   "001001000"b,	/* UserInput - string function */
		   "100001010"b,	/* VMargBottom - vert bin function */
		   "100001010"b,	/* VMargFooter - vert bin function */
		   "100001010"b,	/* VMargHeader - vert bin function */
		   "100001010"b,	/* VMargTop - vert numeric function */
		   "000100000"b,	/* WaitOpt - flag */
		   "100000000"b,	/* Widow - binary */
		   "100000000"b,	/* WidowFoot - binary */
		   (4) (9)"0"b),	/**/
				/* numeric display mode */
	2 mode	   fixed bin init ((80) 0),
	(
	2 flag_loc,		/* flag value pointer */
	2 num_loc,		/* num value pointer */
	2 incr_loc,		/* num increment pointer */
	2 str_loc			/* str value pointer */
	)	   ptr init ((80) null);

one:
  entry;				/* step 1 - enough to process args */
    if db_sw
    then call ioa_ ("init_$one:");	/**/
				/* pre-set all pointers */
    const.colhdrptr, const.call_stk_ptr, const.ctl_ptr, const.errblk_ptr,
         const.init_page_parms_ptr, const.default_parms_ptr,
         const.global_area_ptr, const.insert_data_ptr, const.local_area_ptr,
         const.option_ptr, const.page_ptr, const.page_header_ptr,
         const.page_parms_ptr, const.save_shared_ptr, const.shared_ptr,
         const.text_header_ptr, const.text_entry_ptr, const.fnttbldata_ptr,
         const.text_parms_ptr, const.tree_ptr, const.loctbl_ptr,
         const.outproc_ptr = null ();

/* initialize the constants */
    const.builtin_count = 80;		/* 76 + 4 spares */
				/* date of invocation */
    call date_time_ (clock_ (), date_time_string);
    const.date_value = before (date_time_string, "  ");
    const.null_str = "";		/* an empty string */
    const.time_value = after (date_time_string, "  ");
				/* global storage area */
    call translator_temp_$get_segment ("compose", const.global_area_ptr, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose", "Defining a global storage area.");
        signal cleanup;
        return;
      end;			/**/
				/* command options structure */
    const.option_ptr = allocate (const.global_area_ptr, size (option));
    unspec (option) = "0"b;		/* initialize them */
    option.version = option_version;
    option.cbar.level, option.pgc_select = " ";
    option.cbar.place = "o";
    option.cbar.space = 14400;
    option.cbar.left.mark, option.cbar.right.mark = modmark;
    option.cbar.del.mark = delmark;
    option.cbar.left.sep, option.cbar.right.sep, option.cbar.del.sep = 7200;
    option.cbar.left.width, option.cbar.right.width, option.cbar.del.width =
         7200;
    option.db_before_line, option.db_line_end, option.line_2 = 500000;
    option.db_file = " ";
    option.hyph_size = 3;
    option.linespace = 12000;
    option.pglst.from = "1";
    option.passes = 1;		/**/
				/* shared dynamic data */
    const.shared_ptr = allocate (const.global_area_ptr, size (shared));
    shared = initial_shared;		/* preset so cleanup doesn't barf */
    shared.version = shared_version;	/* version of shared structure */

    if db_sw
    then call ioa_ ("^5x(init_$one)");

    return;			/* end of step one */

two:
  entry;
    debug_sw = shared.bug_mode & db_sw;


    if debug_sw
    then call ioa_ ("init_$two:");	/* continue global allocations */
				/* control line */
    const.ctl_ptr = allocate (const.global_area_ptr, size (ctl));
				/* and buffer */
    ctl.ptr = allocate (const.global_area_ptr, size (ctl));
				/* default page formatting parms */
    const.init_page_parms_ptr =
         allocate (const.global_area_ptr, size (init_page_parms));
				/* default text formatting parms */
    const.default_parms_ptr =
         allocate (const.global_area_ptr, size (default_parms));
    default_parms = init_default_parms; /**/
				/* footnote formatting parms */
    const.footnote_parms_ptr =
         allocate (const.global_area_ptr, size (footnote_parms));
    footnote_parms = init_default_parms;/**/
				/* insert file data structure */
    const.insert_data_ptr =
         allocate (const.global_area_ptr, size (insert_data));
    insert_data.count, insert_data.index, insert_data.ref_area.count = 0;
				/* insert call stack */
    const.call_stk_ptr = allocate (const.global_area_ptr, size (call_stack));
				/* current page layout parms */
    const.page_parms_ptr = allocate (const.global_area_ptr, size (page_parms));
    shared.parameter = option.parameter;/* copy option data */
    shared.hyph_mode = option.hyph_opt; /**/
				/* current formatting parms */
    const.text_parms_ptr = allocate (const.global_area_ptr, size (text_parms));
    text_parms = init_default_parms;	/**/
				/* program variable symbol tree */
    const.tree_ptr = allocate (const.global_area_ptr, size (tree));
    tree.flag_ptr, tree.incr_ptr, tree.name_ptr, tree.num_ptr, tree.var_ptr =
         null;

    tree.count = 1;			/* storage for builtins */
    tree.flag_ptr (1) = allocate (const.global_area_ptr, size (tree_flags));
    tree.incr_ptr (1) = allocate (const.global_area_ptr, size (tree_incrs));
    tree.name_ptr (1) = allocate (const.global_area_ptr, size (tree_names));
    tree.num_ptr (1) = allocate (const.global_area_ptr, size (tree_nums));
    tree.var_ptr (1) = allocate (const.global_area_ptr, size (tree_var));
				/* output page structure */
    const.page_ptr = allocate (const.global_area_ptr, size (page));
    page.version = page_version;	/* and initialize */
				/* empty column header */
    const.colhdrptr = allocate (const.global_area_ptr, size (colhdr));
				/* empty text structures */
    const.text_entry_ptr = allocate (const.global_area_ptr, size (text_entry));
    const.text_header_ptr =
         allocate (const.global_area_ptr, size (text_header));
    text_header = initial_text_header;
    const.page_header_ptr =
         allocate (const.global_area_ptr, size (page_header));
    const.fnttbldata_ptr = allocate (const.global_area_ptr, size (fnttbldata));
    fnttbldata.ndx, fnttbldata.count = 0;
    fnttbldata.medsel_ptr = null;

    if debug_sw
    then call ioa_ ("^5x(init_$two)");

    return;			/* end of step two */

three:
  entry;
    debug_sw = shared.bug_mode & db_sw;

    if debug_sw
    then call ioa_ ("init_$three:");	/**/
				/* initialize variable tree */
    tree.count, tree.areandx = 1;	/* builtins go in the first area */
    tree.entry_ct (*) = 0;
    tree.entry_ct (1) = MAX_TREE_AREA_CT;
    tree_names_ptr = tree.name_ptr (1);
    string (tree_names) = string (builtin_names);
    tree_var_ptr = tree.var_ptr (1);
    tree_var = init_tree_var;		/**/
				/* AlignMode */
    tree_var.num_loc (1) = addr (tree.align_mode);
				/* ArgCount */
    stkbox_ptr = allocate (const.global_area_ptr, size (stack_box));
    stack_box = init_stack_box;
    tree_var.num_loc (2), tree_var.str_loc (2) = stkbox_ptr;
				/* Args */
    stkbox_ptr = allocate (const.global_area_ptr, size (stack_box));
    stack_box = init_stack_box;
    tree_var.num_loc (3), tree_var.str_loc (3) = stkbox_ptr;
				/* ArtMode */
    tree_var.num_loc (4) = addr (tree.art_mode);
				/* BlockIndex */
    tree_var.num_loc (5) = addr (tree.block_index);
				/* BlockName */
    tree_var.num_loc (6) = addr (tree.block_name);
				/* CallingFileName */
    tree_var.num_loc (7) = addr (tree.calling_file_name);
				/* CallingLineNo */
    tree_var.num_loc (8) = addr (tree.callers_lineno);
				/* ChangeBar */
    tree_var.str_loc (9) = addr (shared.cbar_type);
				/* CommandArgCount */
    tree_var.num_loc (10) = addr (option.arg_count);
				/* Date */
    tree_var.str_loc (11) = addr (const.date_value);
				/* Device */
    tree_var.str_loc (12) = addr (option.device);
				/* DeviceClass */
    tree_var.num_loc (13) = addr (tree.devclass);
				/* DeviceName */
    tree_var.num_loc (14) = addr (tree.devname);
				/* DotAddLetter - func */
    tree_var.num_loc (15) = addr (tree.dot_addltr);
				/* DotAddLetter - val */
    tree_var.str_loc (15) = addr (shared.dot_add_letter);
				/* Eqcnt */
    tree_var.num_loc (16) = addr (shared.eqn_refct);
				/* EqMode */
    tree_var.num_loc (17) = addr (tree.equation_mode);
				/* ExtraMargin */
    tree_var.num_loc (18) = addr (option.extra_indent);
				/* FileName */
    tree_var.str_loc (19) = addr (shared.source_filename);
				/* FillMode */
    tree_var.num_loc (20) = addr (tree.fill_mode);
				/* FirstPass */
    tree_var.flag_loc (21) = addr (shared.firstpass);
				/* FontName */
    tree_var.num_loc (22) = addr (tree.fontname);
				/* Footcnt */
    tree_var.num_loc (23) = addr (shared.ftnrefct);
				/* FootnoteMode */
    tree_var.flag_loc (24) = addr (shared.ftn_mode);
				/* FootReset */
    tree_var.str_loc (25) = addr (shared.ftn_reset);
				/* From */
    tree_var.str_loc (26) = addr (option.pglst (0).from);
				/* FrontPage */
    tree_var.num_loc (27) = addr (tree.frontpage);
				/* Galley */
    tree_var.flag_loc (28) = addr (option.galley_opt);
				/* HeadSpace */
    tree_var.num_loc (29) = addr (tree.head_space);
				/* Hyphenating */
    tree_var.flag_loc (30) = addr (shared.hyph_mode);
				/* Indent */
    tree_var.num_loc (31) = addr (tree.left_indent);
				/* IndentRight */
    tree_var.num_loc (32) = addr (tree.right_indent);
				/* InputDirName */
    tree_var.str_loc (33) = addr (shared.input_dirname);
				/* InputFileName */
    tree_var.str_loc (34) = addr (shared.input_filename);
				/* InputLineno */
    tree_var.num_loc (35) = addr (tree.text_lineno);
				/* InsertIndex */
    tree_var.num_loc (36) = addr (insert_data.index);
				/* KeepMode */
    tree_var.num_loc (37) = addr (tree.keep_mode);
				/* LineNumberOpt */
    tree_var.flag_loc (38) = addr (option.number_opt);
				/* LineInput */
    tree_var.num_loc (39) = addr (tree.line_input);
				/* LinesLeft */
    tree_var.num_loc (40) = addr (tree.linesleft);
				/* LineSpace */
    tree_var.num_loc (41) = addr (tree.linespace);
				/* Measure */
    tree_var.num_loc (42) = addr (tree.measure_bif);
				/* NextPageNo */
    tree_var.num_loc (43) = addr (tree.next_pageno);
				/* OutputFileOpt */
    tree_var.flag_loc (44) = addr (option.output_file_opt);
				/* PageBlock */
    tree_var.flag_loc (45) = addr (shared.pageblock);
				/* PageCount */
    tree_var.num_loc (46) = addr (tree.pagecount);
				/* PageLength */
    tree_var.num_loc (47) = addr (tree.page_length);
				/* PageLine */
    tree_var.num_loc (48) = addr (tree.pagelines);
				/* PageNo */
    tree_var.num_loc (49) = addr (tree.pageno);
    tree_var.num_loc (50) = null;	/* PageSpace */
				/* PageWidth */
    tree_var.num_loc (51) = addr (page_parms.measure);
				/* Parameter */
    tree_var.str_loc (52) = addr (shared.parameter);
				/* ParamPresent */
    tree_var.flag_loc (53) = addr (shared.param_pres);
				/* Pass */
    tree_var.num_loc (54) = addr (shared.pass_counter);
				/* PictureCount */
    tree_var.num_loc (55) = addr (shared.picture.space);
				/* PointSize */
    tree_var.num_loc (56) = addr (tree.pointsize);
				/* Print */
    tree_var.flag_loc (57) = addr (shared.print_flag);
				/* StopOpt */
    tree_var.flag_loc (58) = addr (option.stop_opt);
				/* SymbolDelimiter func */
    tree_var.num_loc (59) = addr (tree.symbol_delimiter);
				/* TableMode */
    tree_var.flag_loc (60) = addr (shared.table_mode);
				/* TextDepth */
    tree_var.num_loc (61) = addr (tree.text_depth);
				/* TextWidth */
    tree_var.num_loc (62) = addr (tree.text_width);
				/* Time */
    tree_var.str_loc (63) = addr (const.time_value);
				/* TitleDelimiter func */
    tree_var.num_loc (64) = addr (tree.title_delimiter);
				/* To */
    tree_var.str_loc (65) = addr (option.pglst (0).to);
				/* TrTable */
    tree_var.num_loc (66) = addr (tree.trans);
				/* Undent */
    tree_var.num_loc (67) = addr (tree.left_undent);
				/* UndentRight */
    tree_var.num_loc (68) = addr (tree.right_undent);
				/* UserInput */
    tree_var.num_loc (69) = addr (tree.userinput);
				/* VMargBottom */
    tree_var.num_loc (70) = addr (tree.bottom_margin);
				/* VMargFooter */
    tree_var.num_loc (71) = addr (tree.footer_margin);
				/* VMargHeader */
    tree_var.num_loc (72) = addr (tree.header_margin);
				/* VMargTop */
    tree_var.num_loc (73) = addr (tree.top_margin);
				/* WaitOpt */
    tree_var.flag_loc (74) = addr (option.wait_opt);
				/* Widow */
    tree_var.num_loc (75) = addr (shared.widow_size);
				/* WidowFoot */
    tree_var.num_loc (76) = addr (shared.widow_foot);
				/* page formatting parms */
    init_page_parms = initial_page_parms;
    if comp_dvt.pdl_max > 0
    then init_page_parms.length = min (792000, comp_dvt.pdl_max);
    init_page_parms.init_page_depth = comp_dvt.vmt_min;
    init_page_parms.margin.top = comp_dvt.def_vmt;
    init_page_parms.margin.header = comp_dvt.def_vmh;
    init_page_parms.margin.footer = comp_dvt.def_vmf;
    init_page_parms.margin.bottom = comp_dvt.def_vmb;
    init_page_parms.measure = min (comp_dvt.pdw_max, 468000);
    init_page_parms.net.even, init_page_parms.net.odd =
         init_page_parms.length - init_page_parms.margin.top
         - init_page_parms.margin.header - init_page_parms.margin.footer
         - init_page_parms.margin.bottom;
				/* page structure */
    page.image_ptr, page.column_ptr (*), page.col_image_ptr (*) = null ();
				/* local storage area */
    call translator_temp_$get_segment ("compose", const.local_area_ptr, ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose", "Defining a local storage area.");
        signal cleanup;
        return;
      end;			/**/
				/* continue allocations */
    call_stack.count, call_stack.index = 0;
				/* call box for source file */
    call_stack.ptr (0) = allocate (const.local_area_ptr, size (call_box));
				/* column 0 structure */
    page.column_ptr (0) = allocate (const.local_area_ptr, size (col));
    col0.margin.left = 0;		/* set initial column parms */
    col0.margin.right, col0.parms.measure = 468000;
    col0.hdrptr, col0.ftrptr = null ();
    col0.hdrusd, col0.ftrusd = 0;
    col0.blkptr (*) = null ();	/* make sure block pointers are null */
				/* text block data */
    shared.tblkdata_ptr = allocate (const.local_area_ptr, size (tblkdata));
    unspec (tblkdata) = "0"b;
    tblkdata.block.ptr, tblkdata.line_area.ptr, tblkdata.text_area.ptr =
         null ();
    tblkdata.block.free, tblkdata.line_area.free, tblkdata.text_area.free =
         "1"b;

    if debug_sw
    then call ioa_ ("^5x(init_$three)");

    return;			/* end of step three */

    dcl db_sw	   bit (1) static init ("0"b);
				/* local debug swtich */
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;
%page;
%include comp_column;
%include comp_DCcodes;
%include comp_dvt;
%include comp_fntstk;
%include comp_font;
%include comp_footnotes;
%include comp_insert;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_stack_box;
%include comp_text;
%include comp_tree;
%include compstat;
%include translator_temp_alloc;

  end comp_init_;




		    comp_insert_ctls_.pl1           04/23/85  1059.2rew 04/23/85  0910.1      325665



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

/* compose subroutine for insertion of external objects into the text */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_insert_ctls_:
  proc (ctl_index);

/* PARAMETERS */

    dcl ctl_index	   fixed bin;	/* control token index */

/* LOCAL STORAGE */

    dcl argct	   fixed bin;	/* count of .ifi args */
    dcl argstr	   char (1020) var; /* given Arg list */
    dcl ercd	   fixed bin (35);	/* error code */
				/* for debug */
    dcl exit_str	   char (256) var init ("");
    dcl ftn_headed	   bit (1);	/* 1 = note header has been written */
    dcl ftndx	   fixed bin;	/* footnote block index */
				/* string for default ftn header */
    dcl ftnhdrlin	   char (7) based (DCxx_p);
    dcl ftnrefblk	   fixed bin;	/* reference block index */
    dcl ftnreflin	   fixed bin;	/* footref line index */
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl 1 ifi_file	   like insert.file;/* local file data structure */
    dcl ifi_filename   char (200);
    dcl input_bitcount fixed (35);
    dcl iref	   fixed bin;	/* working index */
    dcl locolptr	   ptr;		/* for local reference */
    dcl 1 locol	   aligned like col based (locolptr);
    dcl qt_found	   bit (1);	/* 1= closing quote found */
    dcl refblkptr	   ptr;		/* for local reference */
    dcl 1 refblk	   aligned like text based (refblkptr);
    dcl refctr	   fixed bin;	/* footref counter */
    dcl save_blkptr	   ptr;		/* to save galley block */
    dcl suffix	   char (6) var;	/* file suffix */
    dcl what	   (107:117) char (8) var static options (constant)
		   init ("block", (2) (1)"", "file", "footnote", "graphic",
		   (4) (1)"", "index");

/* EXTERNAL STORAGE */

    dcl comp_error_table_$limitation
		   fixed bin (35) ext static;
    dcl comp_error_table_$program_error
		   fixed bin (35) ext static;
    dcl error_table_$noentry
		   fixed bin (35) ext static;
    dcl error_table_$segknown
		   fixed bin (35) ext static;


    dcl (addr, char, copy, index, length, ltrim, max, min, mod, null, rtrim,
        size, substr)  builtin;
    dcl (cleanup, comp_abort)
		   condition;

    dcl expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*), char (*),
		   fixed (35));
    dcl get_pdir_	   entry returns (char (168));
    dcl hcs_$make_seg  entry (char (*), char (*), char (*), fixed bin (5), ptr,
		   fixed bin (35));
    dcl hcs_$status_mins
		   entry (ptr, fixed bin (2), fixed bin (24),
		   fixed bin (35));
    dcl ioa_$rsnnl	   entry options (variable);
    dcl msf_manager_$get_ptr
		   entry (ptr, fixed, bit (1), ptr, fixed (35), fixed (35))
		   ;
    dcl msf_manager_$open
		   entry (char (*), char (*), ptr, fixed (35));
    dcl search_paths_$find_dir
		   entry (char (*) aligned, ptr, char (*),
		   char (*) aligned, char (*), fixed (35));

    if shared.bug_mode
    then call ioa_$nnl ("insert_ctls: (^a", what (ctl_index));

    goto ctl_ (ctl_index);

ctl_ (107):			/* ".ibl" = insert-block */
    if shared.bug_mode
    then call ioa_ (")");
    return;

ctl_ (110):			/* ".ifi" = insert file */
    if shared.bug_mode
    then call ioa_ (")");

    if ctl.index > length (ctl_line)	/* no filename? */
    then
      do;
        call comp_report_ (2, 0, "Missing insert file name.", addr (ctl.info),
	   ctl_line);
        goto return_;
      end;

    suffix = "compin";
join_ifi:				/* extract file name */
    ifi_file = init_file_data;
    ifi_filename = before (substr (ctl_line, ctl.index), " ");
				/* & step over it */
    if index (substr (ctl_line, ctl.index), " ") ^= 0
    then
      do;
        ctl.index = ctl.index + index (substr (ctl_line, ctl.index), " ");
        if ctl.index <= length (ctl_line)
				/* step over extra blanks */
        then if index (substr (ctl_line, ctl.index), " ") = 1
	   then ctl.index =
		   ctl.index - 1
		   + verify (substr (ctl_line, ctl.index), " ");
      end;
    else ctl.index = length (ctl_line) + 1;

    if insert_data.ref_area.count = 0	/* need 1st insert ref area? */
    then
      do;
        insert_data.ref_area (1).ptr =
	   allocate (const.local_area_ptr, size (insert_refs));
        insert_data.ref_area.count = 1; /* make it empty */
        insert_data.ref_area (1).ptr -> insert_refs.count = 0;
      end;

    call comp_get_file_$find (ifi_filename, addr (ifi_file),
         (shared.input_dirname), "0"b, suffix, ercd);
    if ercd = 0
    then call comp_get_file_$open (addr (ifi_file), "0"b, ercd);
    if ercd ^= 0
    then
      do;
        if abrt_sw
        then signal comp_abort;
        goto return_;
      end;

    else insert.file = ifi_file;

    argct = 0;
    if ctl.index <= length (ctl_line)	/* do parameter and Args */
    then
      do;				/* save for Arg processing */
        argstr = substr (ctl_line, ctl.index);
				/* if its quoted */
        if index (substr (ctl_line, ctl.index), """") = 1
        then shared.parameter =
	        comp_extr_str_ ("0"b, ctl_line, ctl.index, ctl.index, 0,
	        addr (ctl.info));
        else shared.parameter = argstr;
        shared.param_pres = "1"b;	/* we have a parameter */
				/* now do the Args */
        call comp_update_symbol_ ("1"b, "1"b, "0"b, "Args", argstr);
				/* count them */
        do argct = 1 by 1 while (argstr ^= "");
				/* if quoted */
	if substr (argstr, 1, 1) = """"
	then
	  do;
	    i = 2;		/* look for closer */
	    qt_found = "0"b;
	    do while (^qt_found);
	      j = index (substr (argstr, i), """");

	      if j = 0		/* no more quotes in string */
	      then
	        do;
		call comp_report_ (2, 0, "Missing string delimiter.",
		     addr (ctl.info), ctl_line);
		qt_found = "1"b;	/* to exit the loops */
		argstr = "";
	        end;		/**/
				/* found a quote */
	      else if i + j > 3
	      then
	        do;		/* is it protected? */
		if substr (argstr, i + j - 2, 1) = "*"
		     & substr (argstr, i + j - 3, 2) ^= "**"
		     & substr (argstr, i + j - 3, 2) ^= "ż*"
		then i = i + j;

		else
		  do;		/* found the closer */
		    qt_found = "1"b;
		    argstr = ltrim (substr (argstr, i + j));
		  end;
	        end;

	      else
	        do;		/* found the closer */
		qt_found = "1"b;
		argstr = ltrim (substr (argstr, i + j));
	        end;
	    end;
	  end;			/**/
				/* not quoted */
	else argstr = ltrim (after (argstr, " "));
        end;
        argct = argct - 1;		/* loop counts 1 too many */
      end;
    else shared.param_pres = "0"b;	/**/
				/* record the count */
    call comp_update_symbol_ ("1"b, "1"b, "0"b, "ArgCount",
         ltrim (char (argct)));

    shared.input_filename = insert.refname;
    shared.input_dirname = rtrim (insert.dir);

    insert.posn = 1;		/* start at BOF */
    call_box_ptr = call_stack.ptr (call_stack.index);
    call_box.exit_lineno = ctl.lineno;	/* record caller's lineno */
				/* stack this call */
    i, call_stack.index = call_stack.index + 1;
    if i > call_stack.count		/* need a new box? */
    then
      do;
        if i > hbound (call_stack.ptr, 1)
        then
	do;
	  call comp_report_$ctlstr (2, comp_error_table_$limitation,
	       addr (ctl.info), ctl_line,
	       "The insert file call depth limit of ^d has been"
	       || " reached.", hbound (call_stack.ptr, 1));
	  signal comp_abort;
	  goto return_;
	end;
        call_stack.ptr (i) = allocate (const.local_area_ptr, size (call_box));
        call_stack.count = i;
      end;

    call_box_ptr = call_stack.ptr (i);
    call_box = insert.file;

    call comp_;			/* process the inserted file */
				/* pop the call stack */
    call_stack.index = call_stack.index - 1;
    call_box_ptr = call_stack.ptr (call_stack.index);
    ctl.fileno, insert_data.index = call_box.fileno;
    shared.input_filename = call_box.refname;
    shared.input_dirname = call_box.dir;
    shared.insert_ptr = call_box.insert_ptr;

    if argct > 0			/* pop argument stack */
    then call comp_util_$pop ("Args");
    call comp_util_$pop ("ArgCount");	/* and the count */

    if shared.bug_mode
    then call ioa_$rsnnl ("^d ^d ^a", exit_str, 0, call_stack.index,
	    insert_data.index, shared.input_filename);

    goto return_;

ctl_ (111):			/* ".ift" = insert-footnotes */
				/* ift_ctl_index */
    ftn_headed = "0"b;

    if page.hdr.col_index >= 0	/* set local pointers */
    then locolptr = page.column_ptr (page.hdr.col_index);
    else locolptr = null;
    refblkptr = null;

    if shared.bug_mode
    then call ioa_ (" col=^d count=^d/^d)", page.hdr.col_index,
	    locol.hdr.ftn.ct, ftnblk_data.highndx);

    if locol.hdr.ftn.ct = 0		/* no notes for column? */
         | ftnblk_data.highndx = 0	/* or there are no notes */
    then goto return_;		/**/
				/* for the default header */
    line_area_ptr = ftnhdr.line_area.first;
    if line_area.linptr (1) -> txtlin.default
    then
      do;				/* set up the vector */
        DCxx_p = addr (ftnhdrvec);
        ftnhdrvec.mark = DC1;
        ftnhdrvec.type = type_vlx;
        ftnhdrvec.leng = 4;
        txtlinptr = line_area.linptr (1);
        ftnhdrvec.v1 = locol.parms.measure;
        txtlin.ptr -> txtstr = ftnhdrlin;
        txtlin.info = ctl.info;
      end;

    if option.galley_opt
    then save_blkptr = shared.blkptr;

    shared.blkptr = null ();		/* no block */

    do i = 1 to locol.hdr.ftn.ct;
      ftndx = locol.hdr.ftn.blkndx (i);
      if ftndx > 0
      then if ftnblk_data.blkptr (ftndx) ^= null ()
	 then call do_a_note;
    end;

    if option.galley_opt		/* if galley mode */
    then
      do;				/* write another header in galley */
        call comp_util_$getblk (page.hdr.col_index, shared.blkptr, "fh",
	   addr (current_parms), "0"b);

        do line_area_ptr = ftnhdr.line_area.first repeat (line_area.next)
	   while (line_area_ptr ^= null);
	do j = 1 to line_area.ndx;
	  txtlinptr = line_area.linptr (j);
	  call comp_util_$add_text (shared.blkptr,
	       (txtlin.quad ^= quadl & txtlin.quad ^= just), "1"b, "1"b,
	       "0"b, txtlinptr);
	end;
        end;			/**/
				/* more space, too */
        call comp_space_ (12000, shared.blkptr, "1"b, "1"b, "0"b, "0"b);
        call comp_break_ (footnote_break, 0);
				/* restore galley block ptr */
        shared.blkptr = save_blkptr;
      end;

    if shared.bug_mode
    then call ioa_$rsnnl ("ftnblkct=^d", exit_str, 0, ftnblk_data.highndx);

/* process a footnote */
do_a_note:
  proc;

/* LOCAL STORAGE */

    dcl ftnlinptr	   ptr;		/* a footnote line */
    dcl 1 ftnlin	   aligned like text_entry based (ftnlinptr);
    dcl ftnptr	   ptr;		/* a footnote block */
    dcl 1 ftnblk	   aligned like text based (ftnptr);
    dcl held_space	   fixed bin (31);	/* space for held notes */
    dcl icol	   fixed bin;	/* local column number */
    dcl (ii, jj)	   fixed bin;	/* working index */
    dcl save_colno	   fixed bin;
    dcl save_colptr	   ptr;
    dcl space	   fixed bin (31);	/* space down to footnotes */

    dcl (index, max)   builtin;

    ftnptr = ftnblk_data.blkptr (ftndx);

    if shared.bug_mode
    then call ioa_ ("^5x(do_a_note: ftn=^d ^d/^f)", ftndx, ftnblk.hdr.count,
	    dec (divide (ftnblk.hdr.used, 12000, 31, 10), 11, 3));

    save_colno = page.hdr.col_index;
    save_colptr = shared.colptr;
    page.hdr.col_index, icol = max (page.hdr.col_index, 0);
    shared.colptr = page.column_ptr (icol);
    call comp_util_$getblk (icol, shared.blkptr, "fn", addr (current_parms),
         "0"b);

    if ^ftn_headed			/* need a header? */
    then
      do;
        if ^option.galley_opt		/* if paging */
        then
	do;
	  held_space = 0;
	  if shared.ftn_reset = "hold"
	  then
	    do jj = 1 to ftnblk_data.highndx;
	      if ftnblk_data.blkptr (jj) ^= null
	      then held_space =
		      held_space
		      + ftnblk_data.blkptr (jj) -> text.hdr.used;
	    end;

	  space =			/* amount to get to note depth */
	       page.hdr.net - page.hdr.used - col0.hdr.ftn.usd + 12000;

	  if space < 0 & shared.ftn_reset ^= "hold"
	  then call comp_report_$ctlstr (4, comp_error_table_$program_error,
		  addr (ctl.info), ctl_line,
		  "Footnote extends into margin on page ^a.",
		  page.hdr.pageno);

	  else
	    do;
	      page.hdr.depth, col.hdr.depth = page.hdr.depth + space;
	      page.hdr.used = page.hdr.used + space;
	      col.hdr.used = col.hdr.used + space;
	    end;

	  if shared.bug_mode
	  then call ioa_ ("^5x(ftnspc=^f depth=^f col=^d u^f pag=^a u^f)",
		  dec (divide (space, 12000, 31, 10), 11, 3),
		  dec (divide (page.hdr.depth, 12000, 31, 10), 11, 3),
		  icol, dec (divide (col.hdr.used, 12000, 31, 10), 11, 3),
		  page.hdr.pageno,
		  dec (divide (page.hdr.used, 12000, 31, 10), 11, 3));
	end;			/**/
				/* galley mode */
        else call comp_space_ (12000, shared.blkptr, "1"b, "1"b, "1"b, "0"b);
				/* no lineno or cbar for dflt header */
        line_area_ptr = ftnhdr.line_area.first;
        txtlinptr = line_area.linptr (1);
        if txtlin.default
        then
	do;
	  txtlin.info.lineno, txtlin.fileno = 0;
	  txtlin.cbar = "0"b;
	end;

        do line_area_ptr = ftnhdr.line_area.first repeat (line_area.next)
	   while (line_area_ptr ^= null);
	do jj = 1 to line_area.ndx;	/* add the footnote header */
	  ftnlinptr = line_area.linptr (jj);
	  txtstrptr = ftnlin.ptr;

	  if index (txtstr, shared.sym_delim) ^= 0
	  then call comp_use_ref_ (txtstr, ftnlin.art, "1"b,
		  addr (ftnlin.info));

	  call comp_util_$add_text (shared.blkptr,
	       (ftnlin.quad ^= quadl & ftnlin.quad ^= just), "1"b, "1"b,
	       "0"b, ftnlinptr);
	end;
        end;

        ftn_headed = "1"b;		/* we now have a header */
      end;			/**/
				/* we already have a header */
    else if shared.bug_mode
    then call ioa_ (" depth=^f col=^d u^f pag=^a u^f)",
	    dec (divide (page.hdr.depth, 12000, 31, 10), 11, 3), icol,
	    dec (divide (col.hdr.used, 12000, 31, 10), 11, 3),
	    page.hdr.pageno,
	    dec (divide (page.hdr.used, 12000, 31, 10), 11, 3));

    if shared.blkptr = null ()	/* need a block? */
    then call comp_util_$getblk (max (page.hdr.col_index, 0), shared.blkptr,
	    "fn", addr (current_parms), "0"b);

    text.hdr.art = ftnblk.hdr.art;	/**/
				/* separator */
    call comp_space_ (12000, shared.blkptr, "1"b, "1"b, "0"b, "0"b);

    ii = 0;
    do line_area_ptr = ftnblk.line_area.first repeat (line_area.next)
         while (ii < ftnblk.hdr.count);
      do jj = 1 to line_area.ndx;	/* move the note */
        ftnlinptr = line_area.linptr (jj);

        if ftnblk.hdr.count = 1	/* in case we have the ref only */
        then ftnlin.linespace = ftnblk.parms.linespace;

        call comp_util_$add_text (shared.blkptr,
	   (ftnlin.quad ^= just & ftnlin.quad ^= quadl), "0"b, "0"b, "0"b,
	   ftnlinptr);
        ii = ii + 1;
      end;
    end;				/**/
				/* separator */

/*    call comp_space_ (12000, shared.blkptr, "1"b, "1"b, "0"b, "0"b);*/

    if locolptr ^= null
    then locol.blkptr (locol.hdr.blkct) = shared.blkptr;
    else col0.blkptr (col0.hdr.blkct) = shared.blkptr;
    call comp_break_ (footnote_break, 0);
    page.hdr.depth, col.hdr.depth = max (page.hdr.depth, col.hdr.depth);
				/* return footnote block */
    call comp_util_$relblk (-1, ftnblk_data.blkptr (ftndx));
    if refblkptr ^= null
    then refblk.hdr.ftn.ct = refblk.hdr.ftn.ct - 1;

    if ftndx = ftnblk_data.highndx
    then
      do ftnblk_data.highndx = ftnblk_data.highndx to 1 by -1
	 while (ftnblk_data.blkptr (ftnblk_data.highndx) = null);
      end;

  end do_a_note;

    goto return_;			/* end of ift */

ctl_ (112):			/* ".igr" = insert-graphic */
/**** INACTIVE AND UNDOCUMENTED */
				/*    dcl 1 grafline	   aligned like text_entry;
/*				/* pseudoline for graphic structure */
				/*    dcl 1 grafstack	   (0:20),	/* a graphic recursion stack */
				/*	2 name	   char (32) var,
/*	2 elem	   fixed bin (24),
/*	2 matrix	   (3, 3) float bin,
/*	2 rot	   (3) fixed bin,
/*	2 scl	   (3) float bin;
/*    dcl grafvec_bitcount
/*		   fixed bin (24);	/* bitcount of graphic vector file */
				/*    dcl grafvec_charcount
/*		   fixed bin (21);	/* charcount of graphic vector file */
				/*    dcl grafvec_charpos
/*		   fixed bin (21);	/* position in graphic vector file */
				/*    dcl grafvec_ptr	   ptr;		/* pointer to graphic vector file */
				/*    dcl name_node	   fixed bin (18);	/* name node for graphic structure */
				/*    dcl pgs_dir	   char (168);	/* dir for PGS */
				/*    dcl pgs_file	   char (32);	/* name of PGS */
				/*    dcl pgs_name	   char (32);	/* name of graphic structure */
				/*    dcl pgs_path	   char (200) var;	/* path for PGS */
				/*    dcl struc_node	   fixed bin (18);	/* origin node for graphic structure */
				/*dcl typ_str	(0:33) char (8) static options (constant) init (
/*    "setposit", "setpoint", "vector  ", "shift   ", "point   ", "05", "06",
/*    "07", "scaling ", "rotation", "clipping", "11", "12", "13", "14", "15",
/*    "16", "17", "sensitiv", "blink   ", "color   ", "21", "22", "23",
/*    "symbol  ", "text    ", "databloc", "27", "28", "29", "30", "31",
/*    "list    ", "array   ");
/*    dcl wgs_ptr	   ptr;		/* pointer to WGS - for debug */
				/*    dcl grafchars	   char (1020) var based (grafline.ptr);
/*    dcl grafvec_chars  char (const.max_seg_chars) based (grafvec_ptr);
/*    dcl (
/*        graphic_error_table_$recursive_structure,
/*        graphic_error_table_$bad_node
/*        )		   fixed bin (35) ext static;
/*    dcl graphic_matrix_util_$make_matrix
/*		   entry ((3) fixed bin, (3) float bin, (3, 3) float bin);
/*    dcl graphic_matrix_util_$multiply_3x3_x_1x3
/*		   entry ((3, 3) float bin, (3) float bin, (3) float bin);
/*    dcl remove_graphics
/*		   entry;
/*    dcl setup_graphics entry options (variable);
/*
/*    if shared.bug_mode
/*    then call ioa_ (")");
/*
/*    if "0"b			/* DISABLER */
				/*    then goto return_;
/*
/*    if ctl.index > length (ctl_line)	/* must have a PGS path */
				/*    then
/*      do;
/*graf_err_1:
/*        call comp_report_ (2, 0, "No graphic path given.", addr (ctl.info),
/*	   ctl_line);
/*        goto return_;
/*      end;
/*
/*    pgs_path =
/*         comp_read_$name (ctl_line, ctl.index, ctl.index, addr (ctl.info));
/*				/* read the PGS path */
				/*    if pgs_path = ""		/* check null path */
				/*    then goto graf_err_1;
/*
/*    if search ("><", pgs_path) ^= 0	/* if a path */
				/*    then
/*      do;
/*        call expand_pathname_$add_suffix ((pgs_path), "pgs", pgs_dir, pgs_file,
/*	   ercd);
/*        if ercd ^= 0
/*        then
/*	do;
/*	  call comp_report_ (4, ercd, "Expanding path for " || pgs_path,
/*	       addr (ctl.info), ctl_line);
/*	  goto return_;
/*	end;
/*      end;
/*
/*    else
/*      do;				/* a simple name, have to search */
				/*        if length (pgs_path) > 4	/* check suffix */
				/*        then if substr (pgs_path, length (pgs_path) - 3, 4) ^= ".pgs"
/*	   then pgs_file = pgs_path || ".pgs";
/*	   else ;
/*        else pgs_file = pgs_path || ".pgs";
/*
/*        call search_paths_$find_dir ("compose", null (), pgs_file,
/*	   const.comp_dir, pgs_dir, ercd);
/*        if ercd ^= 0
/*        then
/*	do;
/*	  call comp_report_ (4, ercd, "Searching for " || rtrim (pgs_file),
/*	       addr (ctl.info), ctl_line);
/*	  goto return_;
/*	end;
/*      end;
/*
/*    pgs_path = rtrim (pgs_dir) || ">" || rtrim (pgs_file);
/*				/* we have a PGS */
				/*
/*    if ctl.index <= length (ctl_line)	/* PGS structure name */
				/*    then pgs_name =
/*	    comp_read_$name (ctl_line, ctl.index, ctl.index, addr (ctl.info))
/*	    ;
/*    else pgs_name = rtrim (rtrim (pgs_file), ".pgs");
/*
/*    call hcs_$make_seg ("", "grafvec.compose." || rtrim (option.device), "",
/*         bin ("1010"b), grafvec_ptr, ercd);
/*    if ercd ^= 0 & ercd ^= error_table_$segknown
/*    then
/*      do;
/*        call comp_report_ (4, ercd, "Creating graphic vector file.",
/*	   addr (ctl.info), ctl_line);
/*        goto return_;
/*      end;			/* all set, set up MGS */
				/*    call setup_graphics ("-table", rtrim (option.device), "-output_file",
/*         rtrim (get_pdir_ ()) || ">grafvec.compose." || rtrim (option.device));
/*
/*    on cleanup call clean_;		/* we now have something to clean */
				/*
/*    call gm_$init (ercd);		/* clear the WGS and get drawing */
				/*    if ercd ^= 0
/*    then
/*      do;
/*graf_err_2:
/*        call comp_report_ (4, ercd,
/*	   "Initializing the working graphics segment.", addr (ctl.info),
/*	   ctl_line);
/*        call clean_;
/*        goto return_;
/*      end;
/*    call gm_$segp (wgs_ptr, ercd);
/*    if ercd ^= 0
/*    then goto graf_err_2;
/*    call gm_$get_struc (pgs_dir, pgs_file, pgs_name, 0, ercd);
/*    if ercd ^= 0
/*    then
/*      do;
/*        call comp_report_ (4, ercd,
/*	   "Retrieving " || rtrim (pgs_name) || " from " || pgs_path,
/*	   addr (ctl.info), ctl_line);
/*        call clean_;
/*        goto return_;
/*      end;			/* locate the desired structure */
				/*    name_node = gm_$find_structure (pgs_name, struc_node, ercd);
/*    if ercd ^= 0
/*    then
/*      do;
/*        call comp_report_ (4, ercd, "Locating " || pgs_name || " in the WGS.",
/*	   addr (ctl.info), ctl_line);
/*        call clean_;
/*        goto return_;
/*      end;			/* how big is it? */
				/*    dcl comp_graphic_util_$size
/*		   entry (char (*), fixed bin (18), (3) fixed bin (31),
/*		   (3) fixed bin (31), (3) fixed bin (31), fixed bin (35));
/*    dcl xyz_last	   (3) fixed bin (31);
/*				/* final coordinates of structure */
				/*    dcl xyz_min	   (3) fixed bin (31);
/*				/* min coordinates of structure */
				/*    dcl xyz_max	   (3) fixed bin (31);
/*				/* max coordinates of structure */
				/*
/*    call comp_graphic_util_$size (pgs_name, name_node, xyz_last, xyz_min,
/*         xyz_max, ercd);
/*    if ercd ^= 0
/*    then
/*      do;
/*        call comp_report_ (4, ercd,
/*	   "Processing graphic structure " || pgs_name, addr (ctl.info),
/*	   ctl_line);
/*        call clean_;
/*        goto return_;
/*      end;
/*
/* convert it to device vectors */
				/*    call gc_$display (struc_node, ercd);
/*    if ercd ^= 0
/*    then
/*      do;
/*        call comp_report_ (4, ercd,
/*	   "Converting " || rtrim (pgs_name) || " to "
/*	   || rtrim (option.device) || " device vectors.", addr (ctl.info),
/*	   ctl_line);
/*        call clean_;
/*        goto return_;
/*      end;
/*
/*    call remove_graphics;		/* done with MGS */
				/*    revert cleanup;
/*
/*    call hcs_$status_mins (grafvec_ptr, 0, grafvec_bitcount, ercd);
/*    if ercd ^= 0
/*    then
/*      do;
/*        call comp_report_ (4, ercd,
/*	   "Finding length of the graphic vector file.", addr (ctl.info),
/*	   ctl_line);
/*        goto return_;
/*      end;
/*
/*    if grafvec_bitcount = 0		/* nothing there? */
				/*    then
/*      do;
/*        call comp_report_ (2, 0,
/*	   "No vectors generated for " || rtrim (pgs_name), addr (ctl.info),
/*	   ctl_line);
/*        goto return_;
/*      end;
/*
/*    grafvec_charcount = divide (grafvec_bitcount, 9, 21, 0);
/*    grafvec_charpos = 1;
/*
/*    grafline = text_entry;		/* initialize the graphic "line" */
				/*    grafline.info = ctl.info;		/* copy info */
				/*    grafline.font = ctl.font;		/* and typographic stuff */
				/*    grafline.quad = quadl;		/* set it left */
				/*    grafline.art = "1"b;		/* treat like artwork */
				/*    grafline.rmarg = col.parms.right.margin;
/*    grafline.width = xyz_max (1) - xyz_min (1);
/*    grafline.linespace = xyz_max (2) - xyz_min (2);
/*      allocate text_area in (comp_free) set (grafline.ptr);*/
				/*    grafchars = substr (grafvec_chars, 1, grafvec_charcount);
/*
/*    if shared.blkptr = null ()	/* need a block? */
				/*    then call comp_util_$getblk (0, page.hdr.col_index, shared.blkptr, "tx",
/*	    addr (current_parms));
/*
/*    call comp_util_$add_text (shared.blkptr,  "0"b, "0"b, "0"b, "0"b,
/*         addr (grafline));
/*
/*clean_:
/*  proc;
/*    call remove_graphics;
/*  end clean_;*/
    goto return_;

ctl_ (117):			/* ".indx" - insert-index */
    suffix = "index";
    goto join_ifi;

return_:
    if shared.bug_mode
    then call ioa_ ("^5x(insert_ctls:^[ ^a)^])", (exit_str ^= ""), exit_str);
    return;

dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;
    dcl db_sw	   bit (1) int static init ("0"b);
%page;
/* Recursive internal procedure to compile a node in the working graphic seg */
/* Recurses on the higher-level lists and arrays, iterates on all others */

/* compile_node_recurse: procedure (node_no, node_name) recursive;
   /*
   /*dcl  node_no fixed bin (18) parameter;	/* number of node being compiled */
/* dcl  node_name char (*) parameter;	/* name of the structure */
/*
   /*dcl  array (200) fixed bin (18);	/* an array or list */
/* dcl  chars char (32);		/* to hold symbols */
/* dcl  curl fixed bin;		/* number of list/array elements */
/* dcl  grstk_entry_ptr ptr;	/* graphic stack entry pointer */
/* dcl  nchars fixed bin;		/* number of symbol chars */
/* dcl (node_type, sub_type) fixed bin;	/* graphic node type code */
/* dcl 1 grstk_entry like grafstack based (grstk_entry_ptr); /* graphic stack entry */
/* dcl  level fixed bin;
   /*
   /*
   /*       grstk_entry.name = node_name;	/* copy name parameter */
/*       grstk_entry.elem = 0;		/* clear element count */
/*				/* start with given node */
/*       call graphic_manipulator_$examine_type (node_no, "0"b, node_type, ercd);
   /*       if ercd ^= 0
   /*       then goto node_err;
   /*
   /*dcl  org (3) float bin;
   /*       if shared.bug_mode & db_sw
   /*       then call ioa_ ("^vx^a ^a ^.3f,^.3f,^.3f", level, msg (),
   /*	typ_str (node_type), org);
   /*
   /*       goto Type (node_type);		/* dispatch on node type */
/*
   /*Type (32):			/* list */
/* Type (33):			/* array */
/*       call graphic_manipulator_$examine_list (node_no, array, curl, ercd);
   /*       if ercd ^= 0
   /*       then goto node_err;
   /*
   /*       do grstk_entry.elem = 1 to curl; /* go through it */
/*	call graphic_manipulator_$examine_type (array (grstk_entry.elem),
   /*	   "0"b, sub_type, ercd);
   /*	if ercd ^= 0
   /*	then goto node_err;
   /*
   /*	if shared.bug_mode & db_sw
   /*	then call ioa_ ("^vx^a ^a ^.3f,^.3f,^.3f", level, msg (),
   /*	   typ_str (sub_type), org);
   /*
   /*	if sub_type < Null | sub_type > Array
   /*	then goto bad_type; */
/*
   /*	goto Sub_type (sub_type);	/* dispatch on node type */
/*
   /*Sub_type (0):			/* setposition */
/* Sub_type (1):			/* setpoint */
/*	call comp_report_ (2, 0, "Graphic structure node " || msg () ||
   /*	   " is an absolute element.", addr (ctl.info),
   /*	   ctl_line);
   /*	goto Sub_type_end;
   /*
   /*Sub_type (3):			/* shift */
/*	if level = 1 & grstk_entry.elem = curl
   /*	then do;
   /*	   grafstack (2).rot (*) = mod (-grafstack (1).rot (*), 360);
   /*	   grafstack (2).scl (*) = -1./grafstack (1).scl (*);
   /*	   call graphic_matrix_util_$make_matrix (addr (grafstack (2)) -> grstk_entry.rot, addr (grafstack (2)) -> grstk_entry.scl, addr (grafstack (2)) -> grstk_entry.matrix);
   /*	   call graphic_matrix_util_$multiply_3x3_x_1x3 (addr (grafstack (2)) -> grstk_entry.matrix, org, 0);
   /*	end;
   /*
   /*Sub_type (2):			/* vector */
/* Sub_type (4):			/* point */
/*	call position_node (array (grstk_entry.elem));
   /*	goto Sub_type_end;
   /*Sub_type (8):			/* scaling */
/*				/*	call scale_node (array (grstk_entry.elem)); */
/*
   /*Sub_type (9):			/* rotation */
/*				/*	call rotate_node (array (grstk_entry.elem)); */
/*	goto Sub_type_end;
   /*
   /*Sub_type (10):			/* clipping */
/* Sub_type (16):			/* intensity */
/* Sub_type (17):			/* linetype */
/* Sub_type (18):			/* sensitivity */
/* Sub_type (19):			/* blink */
/* Sub_type (20):			/* color */
/*	goto Sub_type_end;
   /*Sub_type (24):			/* symbol */
/*	call graphic_manipulator_$examine_symbol ((array (grstk_entry.elem)), array (grstk_entry.elem), nchars, chars, ercd);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*	call compile_node_recurse (array (grstk_entry.elem), substr (chars, 1, nchars));
   /*	goto Sub_type_end;
   /*
   /*Sub_type (25):			/* text */
/*				/*	call text_node (array (grstk_entry.elem)); */
/*	goto Sub_type_end;
   /*
   /*Sub_type (26):			/* datablock */
/*	goto Sub_type_end;
   /*
   /*Sub_type (32):			/* list */
/* Sub_type (33):			/* array */
/*	call compile_node_recurse (array (grstk_entry.elem), "");
   /*
   /*Sub_type (-1):			/* null */
/* Sub_type_end: end;
   /*       goto Type_end;
   /*
   /*Type (0):				/* setposition */
/*       call ioa_ ("setposition should not be used");
   /*       goto Type_end;
   /*
   /*Type (1):				/* setpoint */
/*       call ioa_ ("setpoint should not be used");
   /*       goto Type_end;
   /*
   /*Type (2):				/* vector */
/* Type (3):				/* shift */
/* Type (4):				/* point */
/*       call position_node (node_no);
   /*       goto Type_end;
   /*Type (8):				/* scaling */
/*       call scale_node;
   /*
   /*Type (9):				/* rotation */
/*       call rotate_node;
   /*       goto Type_end;
   /*
   /*Type (10):			/* clipping */
/* Type (16):			/* intensity */
/* Type (17):			/* linetype */
/* Type (18):			/* sensitivity */
/* Type (19):			/* blink */
/* Type (20):			/* color */
/*       goto Type_end;
   /*Type (24):			/* symbol */
/*       call graphic_manipulator_$examine_symbol ((node_no), node_no, nchars, chars, ercd);
   /*       if (ercd ^= 0)
   /*       then goto node_err;
   /*       call compile_node_recurse (node_no, substr (chars, 1, nchars));
   /*       goto Type_end;
   /*
   /*Type (25):			/* text */
/*       call text_node;
   /*       goto Type_end;
   /*
   /*Type (26):			/* datablock */
/*       goto Type_end;
   /*
   /*Type_end:
   /*       level = level - 1;		/* pop the stack */
/*       return;
   /*
   /* These labels represent node types which are undefined.  If we get here, something is wrong. */
/*
   /*Type (5): Sub_type (5):
   /*Type (6): Sub_type (6):
   /*Type (7): Sub_type (7):
   /*Type (11): Sub_type (11):
   /*Type (12): Sub_type (12):
   /*Type (13): Sub_type (13):
   /*Type (14): Sub_type (14):
   /*Type (15): Sub_type (15):
   /*Type (21): Sub_type (21):
   /*Type (22): Sub_type (22):
   /*Type (23): Sub_type (23):
   /*Type (27): Sub_type (27):
   /*Type (28): Sub_type (28):
   /*Type (29): Sub_type (29):
   /*Type (30): Sub_type (30):
   /*Type (31): Sub_type (31): goto bad_type;
   /*
   /*dcl  flta (3) float bin;
   /*
   /*position_node: proc (node);
   /*
   /*dcl  node fixed bin (18);
   /*
   /*	call graphic_manipulator_$examine_position (node, 0,
   /*	   flta (1), flta (2), flta (3), ercd);
   /*	if ercd ^= 0
   /*	then goto node_err;
   /*
   /*	call graphic_matrix_util_$multiply_3x3_x_1x3 (grstk_entry.matrix,
   /*	   flta, 0);
   /*	if ercd ^= 0
   /*	then goto node_err;
   /*
   /*	org (*) = org (*) + fltb (*); */
/* /*	vmin (*) = min (vmin (*), org (*)); */
/* /*	vmax (*) = max (vmax (*), org (*)); */
/*
   /*	if shared.bug_mode & db_sw
   /*	then call ioa_ ("     org (^.3f,^.3f,^.3f) min (^.3f,^.3f,^.3f)" ||
   /*	   " max (^.3f,^.3f,^.3f)", 0, 0, vmax);
   /*       end position_node;
   /*
   /*scale_node: proc;
   /*
   /*
   /*dcl (x, y, z) float bin;
   /*	call graphic_manipulator_$examine_position (struc_node, 0, x, y, z, ercd);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*	flta (1) = x;
   /*	flta (2) = y;
   /*	flta (3) = z;
   /*	do i = 1 to 3;
   /*	   grafstack.scl (level, i) = flta (name_node) * grafstack.scl (level-1, i);
   /*	end;
   /*	call graphic_matrix_util_$make_matrix (grstk_entry.rot, grstk_entry.scl, grstk_entry.matrix);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*       end;
   /*
   /*rotate_node: proc;
   /*
   /*
   /*
   /*dcl (x, y, z) float bin;
   /*	call graphic_manipulator_$examine_position (struc_node, 0, x, y, z, ercd);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*				/*	fixa (1) = x;
   /*				   /*	fixa (2) = y;
   /*				   /*	fixa (3) = z;
   /*				   /*	do i = 1 to 3;
   /*				   /*	   grafstack.rot (level, i) = mod (fixa (name_node)+grafstack.rot (level-1, i), 360);
   /*				   /*	end; */
/*	call graphic_matrix_util_$make_matrix (grstk_entry.rot, grstk_entry.scl, grstk_entry.matrix);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*       end;
   /*
   /*text_node: proc;
   /*dcl  jflt float bin;
   /*dcl  ch char (1);
   /*dcl (ali) fixed bin;
   /*dcl  nchars fixed bin;
   /*dcl  chars char (200);
   /*
   /*	call graphic_manipulator_$examine_text (struc_node, ali, nchars, chars, ercd);
   /*	if (ercd ^= 0)
   /*	then goto node_err;
   /*	flta (*) = org (*);
   /*	jflt = 0.;
   /*	do i = 1 to nchars;
   /*	   ch = substr (chars, i, 1);
   /*	   if (ch = "")
   /*	   then jflt = jflt - 1.;
   /*	   else jflt = jflt + 1.;
   /*	end;
   /*	goto align (ali);
   /*
   /*align (1):			/* upper_left */
/*	flta (1) = flta (1)-3.6;
   /*	flta (2) = flta (2)-7.5;
   /*	goto check;
   /*
   /*align (2):			/* upper_center */
/*	flta (1) = flta (1)- jflt*3.6;
   /*	flta (2) = flta (2) - 10.;
   /*	goto check;
   /*
   /*align (3):			/* upper_right */
/*	flta (1) = flta (1) - jflt*7.2 +3.6;
   /*	flta (2) = flta (2) - 10.;
   /*	goto check;
   /*
   /*align (4):			/* left */
/*	flta (1) = flta (1) +3.6;
   /*	flta (2) = flta (2) - 1.5;
   /*	goto check;
   /*
   /*align (5):			/* center */
/*	flta (1) = flta (1) - jflt*3.6;
   /*	flta (2) = flta (2) - 1.5;
   /*	goto check;
   /*
   /*   align (6):			/* right */
/*    flta (1) = flta (1) - jflt*7.2 +3.6;
   /*    flta (2) = flta (2) - 1.5;
   /*	goto check;
   /*
   /*align (7):			/* lower_left */
/*	flta (1) = flta (1) +3.6;
   /*	flta (2) = flta (2) + 4.5;
   /*	goto check;
   /*
   /*align (8):			/* lower_center */
/*	flta (1) = flta (1) - jflt*3.6;
   /*	flta (2) = flta (2) + 4.5;
   /*	goto check;
   /*
   /*align (9):			/* lower_right */
/*	flta (1) = flta (1) - jflt*7.2 +3.6;
   /*	flta (2) = flta (2) + 4.5;
   /*	goto check;
   /*
   /*check:
   /*	flta (1) = flta (1) - 3.6;
   /*				/*	vmin (1) = min (vmin (1), flta (1)); */
/*	vmax (1) = max (vmax (1), flta (1)+jflt*7.2);
   /*				/*	vmin (2) = min (vmin (2), flta (2)-4.5); */
/*	vmax (2) = max (vmax (2), flta (2)+7.5);
   /*dcl  vmin (3) float bin;
   /*	if shared.bug_mode & db_sw
   /*	then call ioa_ ("     min ^5.1f,^5.1f^s max ^5.1f,^5.1f^s  ^5.1f,^5.1f^s ""^va""", vmin, vmax, flta, nchars-1, substr (chars, 1, nchars-1));
   /*       end text_node;
   /*
   /*recursive_structure:
   /*       ercd = graphic_error_table_$recursive_structure;
   /*       return;
   /*
   /*bad_type:
   /*       ercd = graphic_error_table_$bad_node;
   /*node_err:
   /*       return;
   /*
   /*    end compile_node_recurse; */

/* msg: proc returns (char (200) var);
   /*
   /*dcl  ms char (200) var;
   /*
   /*       ms = rtrim (grafstack (1).name);
   /*       do i = 1 to level;
   /*	ms = ms || "." || ltrim (char (bin (grafstack (i).elem)));
   /*       end;
   /*
   /*       return (ms);
   /*    end msg; */

    dcl abrt_sw	   bit (1) static init ("0"b);
abrtn:
  entry;
    abrt_sw = "1"b;
    return;
abrtf:
  entry;
    abrt_sw = "0"b;
    return;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_text;
    dcl 1 insert_status
		   aligned like branch_status;
%include branch_status;
/* DISORDER DUE TO SYMBOL TABLE SIZE LIMIT */
    dcl 1 ftnhdrvec	   like dclong_val; /* vector for default ftn header */
%include comp_DCdata;
%include comp_dvid;
%include comp_tree;
%include compstat;
%include translator_temp_alloc;

%include gc_entry_dcls;
%include gm_entry_dcls;

  end comp_insert_ctls_;




		    comp_make_page_.pl1             04/23/85  1059.2rew 04/23/85  0910.2      858942



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

/* compose subroutine to make up pages */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_make_page_:
  proc (break_type, force_balance);

/* PARAMETERS */

    dcl break_type	   fixed bin;	/* break type flag; 0 = format,
				   1 = block, 2 = column, 3 = need,
				   4 = page, 5 = fnote, 6 = footer */
    dcl force_balance  bit (1);	/* 1 = force a page balance */

/* LOCAL STORAGE */

    dcl balnet	   fixed bin (31);	/* local value for balancing */
    dcl balusd	   fixed bin (31);	/* local value for balancing */
    dcl bal_sw	   bit (1);	/* page balance switch */
    dcl blkftnct	   fixed bin;	/* block footnote count */
    dcl blkftnusd	   fixed bin (31);	/* block footnote space */
    dcl blk_mod	   bit (1);	/* local value used in balancing */
    dcl blk_split	   (0:20) bit (1);	/* 1 = last col block has been split */
    dcl blkno	   fixed bin;	/* local value */
    dcl blkusd	   fixed bin (31);	/* local space accumulator */
    dcl blkptr	   ptr;		/* local block pointer */
    dcl 1 block	   aligned like text based (blkptr);
				/* break types */
    dcl breaks	   (0:6) char (4) static options (constant)
		   init ("fmt", "blk", "col", "pag", "need", "ftn", "ftr");
    dcl bug_sw	   bit (1);	/* effective debug switch */
    dcl cap_count	   fixed bin;	/* for caption line counting */
    dcl coldepth	   fixed bin (31);	/* current depth in a column */
				/* col space discarded */
    dcl coldisc	   (0:20) fixed bin (31);
    dcl 1 colftn	   like colhdr.balftn;
    dcl colhdrusd	   fixed bin (31);	/* space used by column header */
    dcl colnet	   fixed bin (31);	/* local value for balancing */
    dcl colusd	   fixed bin (31);	/* local value for balancing */
    dcl curbalblk	   fixed bin;	/* current balance point */
				/* footnotes deferred by widowing */
    dcl 1 dfrftn	   like colhdr.balftn;
    dcl done	   bit (1);
    dcl force_bal	   bit (1);
    dcl force_this_page
		   bit (1);	/* 1= force-print a trimmed page */
    dcl ftnblkptr	   ptr;		/* a footnote */
    dcl 1 ftnblk	   aligned like text based (ftnblkptr);
    dcl ftn_held	   bit (1);	/* footnote processing control */
    dcl ftnct	   fixed bin;	/* local footnote counter */
    dcl ftndx	   fixed bin;	/* footnote block index */
    dcl ftnusd	   fixed bin (31) init (0);
				/* local footnote space */
    dcl head_used	   fixed bin (31) init (0);
				/* page header block space */
    dcl (i, j, k)	   fixed bin;	/* working index */
    dcl iblk	   fixed bin;	/* block counter */
    dcl icol	   fixed bin;	/* column counter */
    dcl ilin	   fixed bin;	/* line counter */
    dcl keeping	   bit (1);	/* local keep mode flag */
    dcl keepsz	   fixed bin (31);	/* keep size */
    dcl last_line	   fixed bin;	/* last line for widowing, etc. */
    dcl last_unbal	   fixed bin (31);
    dcl line_area_ndx  fixed bin;
    dcl linftnct	   fixed bin;	/* line footnote counter */
    dcl maxcoldepth	   fixed bin (31);	/* local value depth for balancing */
    dcl maxcolusd	   fixed bin (31);	/* local value for balancing */
    dcl mincolusd	   fixed bin (31);	/* local value for balancing */
    dcl need_page	   bit (1);	/* page needed for need break */
    dcl note_oflo	   bit (1);	/* loop control switch */
    dcl 1 oflo	   static,	/* page overflow data */
				/* block count */
	2 ct	   fixed bin init (0),
				/* column space used */
	2 used	   fixed bin (31) init (0),
				/* the blocks */
	2 blkptr	   (100) ptr init ((100) null),
	2 ftn,			/* footnotes */
	  3 ct	   fixed bin init (0),
	  3 usd	   fixed bin (31) init (0),
	  3 blkndx   (50) fixed bin init ((50) 0);
    dcl ofloblkptr	   ptr;		/* overflow block */
    dcl 1 ofloblk	   aligned like text based (ofloblkptr);
    dcl orph_ftn	   bit (1);	/* orphan footnote flag */
    dcl orphftnct	   fixed bin;	/* orphan footnote count */
    dcl orphftnusd	   fixed bin (31);	/* orphan footnote space */
    dcl pagenet	   fixed bin (31);	/* for column balancing */
    dcl pagoflo	   bit (1);	/* page overflow signal */
    dcl pagusd	   fixed bin (31) static;
    dcl pgc_select	   char (1) static init ("");
    dcl rebalnet	   fixed bin (31);	/* net column space for rebalancing */
    dcl rebal_sw	   bit (1);
    dcl savblkusd	   fixed bin (31);	/* used for widowing */
    dcl 1 savcolftn	   like colhdr.balftn;
    dcl savcolusd	   fixed bin (31);	/* used for widowing */
    dcl savftnct	   fixed bin;	/* used for widowing */
    dcl savftnusd	   fixed bin (31);	/* used for widowing */
    dcl spcl_line	   char (512) var;	/* "special" control line */
    dcl spcl_linespace fixed bin (31);	/* lead for special line */
    dcl spcl_lndx	   fixed bin;	/* block line index of special line */
    dcl text_added	   bit (1) aligned;
    dcl tmpdepth	   fixed bin (31);	/* temporary depth counter */
    dcl tmpnet	   fixed bin (31);
    dcl tmpusd	   fixed bin (31);	/* temporary space value */
    dcl unbal	   fixed bin (31);	/* amount of column unbalance */
    dcl widct	   fixed bin;	/* local widow count */
    dcl widow	   fixed bin (31);	/* local widow size value */
    dcl widsiz	   fixed bin;	/* local widow line count */
    dcl widusd	   fixed bin (31);	/* used in block widowing */

    dcl (addr, bin, ceil, char, dec, divide, floor, hbound, index, length,
        ltrim, max, min, mod, null, substr)
		   builtin;
    dcl (cleanup, comp_abort, end_output)
		   condition;

    dcl continue_to_signal_
		   entry (fixed bin (35));

    bug_sw = shared.bug_mode | db_sw;	/**/
				/* if col 0 or last col */
    if (page.hdr.col_index = 0 |	/* and it has overflowed */
         page.hdr.col_index = page.parms.cols.count)
         & (col.hdr.used + col.hdr.ftn.usd + col.depth_adj > col.hdr.net)
    then pagoflo = "1"b;
    else pagoflo = "0"b;

    force_bal = force_balance;
    bal_sw =
         (pagoflo | force_bal
         | (break_type = page_break & page.parms.cols.bal
         | break_type = column_break
         & page.hdr.col_index = page.parms.cols.count))
         & page.parms.cols.count > 1;

    need_page =
         break_type = need_break & page.hdr.col_index = page.parms.cols.count;
    blkptr = null;
    blk_split (*) = "0"b;
    oflo.ct, oflo.used, oflo.ftn.ct, oflo.ftn.usd = 0;
    widsiz = shared.widow_size;
    widow = current_parms.linespace * widsiz;
    ftn_held = (shared.ftn_reset = "hold");
    keepsz, orphftnct, orphftnusd, dfrftn = 0;

    on cleanup, comp_abort
      begin;
        call clean_oflo;		/* give back the overflow */
        call continue_to_signal_ (0);	/* and pass the buck */
      end;

    on end_output
      begin;
        call clean_oflo;		/* give back the overflow */
        page.hdr.depth, page.hdr.used, pagusd = 0;
      end;

    if bug_sw
    then
      do;
        call ioa_ ("make_page: (brk=^a pag=^a ^[front^;back^] bal=d^f u^f"
	   || "^[ FORCE^]^[ BAL^])", breaks (break_type), page.hdr.pageno,
	   page.hdr.frontpage, show (page.hdr.baldepth, 12000),
	   show (page.hdr.balusd, 12000), force_bal, bal_sw);

        call ioa_ ("^5x(col=^d b^d u^f(^f)/^f(^f)^[ ftn^d/^f^;^2s^]"
	   || " pag=^a c^d u^f(^f)/^f)^[ (pi=^d ^f)^]", page.hdr.col_index,
	   col.hdr.blkct, show (col.hdr.used, 12000),
	   show (col.hdr.pspc, 12000), show (col.hdr.net, 12000),
	   show (col.depth_adj, 12000), col.hdr.ftn.ct > 0, col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), page.hdr.pageno,
	   page.parms.cols.count, show (page.hdr.used, 12000),
	   show (page.hdr.hdspc, 12000), show (page.hdr.net, 12000),
	   (shared.picture.count > 0), shared.picture.count,
	   show (shared.picture.space, 12000));
      end;			/**/
				/* head the page if necessary */
    if ^(option.galley_opt | page.hdr.headed)
    then call comp_head_page_ (head_used);
    else head_used = col0.blkptr (1) -> text.hdr.used;

    rebalnet, tmpnet, unbal, last_unbal = 0;
    force_this_page, rebal_sw = "0"b;

    pagusd = page.hdr.balusd;
    maxcoldepth = 0;
    orph_ftn = "0"b;

COL_LOOP:
    coldisc (*) = 0;
coloop:				/* for all active columns */
    do icol = 0 by 1 while (icol <= page.hdr.col_count);
      page.hdr.col_index = icol;	/* set column pointer */
      shared.colptr = page.column_ptr (icol);
				/* initialize for this column */
      curbalblk = col.hdr.balblk;
      colusd = col.hdr.balusd;
      colftn = col.hdr.balftn;

      if col.hdrptr ^= null		/* running column header */
      then colhdrusd = col.hdrptr -> text.hdr.used;
      else colhdrusd = 0;

rebal:
      if icol = 0			/* for column 0 */
      then
COL0:
        do;
	if curbalblk = 1		/* page header? */
	then coldepth, tmpdepth = col.depth_adj;
	else coldepth, tmpdepth =
		max (head_used,
		col.hdr.baldepth
		+ bin (col.hdr.balusd = 0) * col.depth_adj);

	colnet, balnet = col.hdr.net;

	if bug_sw
	then
	  do;
	    call ioa_ ("^5x(pag=^a^21tusd=^f/^f bal=d^f u^f"
	         || " h^f^[ OFLO^] ^[^^^]BAL)^[ (pi=^d ^f)^;^2s^]",
	         page.hdr.pageno, show (page.hdr.used, 12000),
	         show (page.hdr.net, 12000), show (page.hdr.baldepth, 12000),
	         show (page.hdr.balusd, 12000), show (page.hdr.hdspc, 12000),
	         pagoflo, ^bal_sw, (shared.picture.count > 0),
	         shared.picture.count, show (shared.picture.space, 12000));

	    call ioa_ ("^5x(col=0 b^d^21tusd=^f/^f(^f)^[ ftn=^d/^f^;^2s^]"
	         || " bal=b^d d^f u^f^[ ftn=^d/^f^;^2s^] ftr=^f h^f)",
	         col.hdr.blkct, show (col.hdr.used, 12000),
	         show (colnet, 12000), show (col.depth_adj, 12000),
	         col.hdr.ftn.ct > 0, col.hdr.ftn.ct,
	         show (col.hdr.ftn.usd, 12000), curbalblk,
	         show (col.hdr.baldepth, 12000),
	         show (col.hdr.balusd, 12000), (col.hdr.balftn.ct > 0),
	         col.hdr.balftn.ct, show (col.hdr.balftn.usd, 12000),
	         show (col.ftrusd, 12000), show (col.hdr.pspc, 12000));
	  end;
        end COL0;

      else			/* icol > 0 */
NOT_COL0:
        do;
	coldepth, tmpdepth =
	     max (head_used,
	     col.hdr.baldepth + bin (col.hdr.balusd = 0) * col.depth_adj);

	if bal_sw			/* column balancing wanted? */
	then			/* balance the columns */
	  do;
	    if ^rebal_sw		/* if not a rebalance pass */
	    then
	      do;
	        if icol = 1
	        then
		do;
		  balnet, balusd, keepsz = 0;
				/* for all columns */
		  do i = 1 to page.parms.cols.count;
		    locolptr = page.column_ptr (i);

		    balusd =
		         balusd + locol.hdr.used + locol.hdr.ftn.usd
		         + locol.ftrusd + locol.depth_adj;

		    balnet = balnet + locol.hdr.net;

		    if bug_sw
		    then call ioa_$nnl ("^[   (bal=^;,^]^f", (i = 1),
			    show (locol.hdr.used + locol.hdr.ftn.usd
			    + locol.depth_adj, 12000));
		  end;

		  pagenet =
		       page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd;

		  if balnet <= balusd
		  then balnet = pagenet;
		  else balnet =
			  max (widow + bin (pagoflo) * widow,
			  min (pagenet,
			  12000
			  *
			  ceil (
			  divide (balusd, page.parms.cols.count * 12000,
			  31, 10))));

		  balnet, colnet = max (balnet, keepsz) - col.ftrusd;
/****		  colnet =
/****		       max (balnet, col.hdr.used + col.depth_adj)
/****		       - col.ftrusd;*/

		  if bug_sw
		  then call ioa_ ("=^f)", show (balnet, 12000));
		end;
	      end;

	    else if rebal_sw
	    then
	      do;
	        colnet, balnet = rebalnet;

	        if bug_sw & icol = 1
	        then call ioa_ ("   (rebal=^f)", show (rebalnet, 12000));
	      end;
	  end;

	else colnet =
		min (col.hdr.net,
		page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd
		- col0.ftrusd - col0.depth_adj);

	if bug_sw
	then call ioa_ ("^5x(col=^d b^d^21tusd=^f/^f(^f)^[ ftn=^d/^f^;^2s^]"
		|| " bal=b^d d^f u^f^[ ftn=^d/^f^;^2s^]" || " ftr=^f h^f)",
		icol, col.hdr.blkct, show (col.hdr.used, 12000),
		show (colnet, 12000), show (col.depth_adj, 12000),
		(col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
		show (col.hdr.ftn.usd, 12000), curbalblk,
		show (col.hdr.baldepth, 12000),
		show (col.hdr.balusd, 12000), (col.hdr.balftn.ct > 0),
		col.hdr.balftn.ct, show (col.hdr.balftn.usd, 12000),
		show (col.ftrusd, 12000), show (col.hdr.pspc, 12000));
        end NOT_COL0;

      if col.hdr.blkct >= curbalblk	/* if blocks were added */
      then
BLKLOOP:
        do iblk = curbalblk by 1 while (iblk <= col.hdr.blkct);
	blkptr = col.blkptr (iblk);

	if block.hdr.count > 0	/* if not an empty block */
	then
block_begin:
	  begin;			/* to allocate loclinptr */

	    dcl loclindx	   fixed bin;
	    dcl 1 loclin	   (block.hdr.count),
		2 landx	   bin,	/* line_area index */
		2 laptr	   ptr,	/* line_area pointer */
		2 ptr	   ptr;	/* line pointer */
				/**/
				/* copy line storage data into */
	    loclindx = 0;		/* a single array */
	    do line_area_ptr = block.line_area.first
	         repeat (line_area.next)
	         while (line_area_ptr ^= null & loclindx < block.hdr.count);
	      do i = 1 to line_area.ndx while (loclindx < block.hdr.count);
	        loclindx = loclindx + 1;
	        loclin (loclindx).landx = i;
	        loclin (loclindx).laptr = line_area_ptr;
	        loclin (loclindx).ptr = line_area.linptr (i);
	      end;
	    end;

	    block.hdr.trl_ws = 0;	/* count trimmable WS if this */
	    if icol + iblk > 1	/* isnt the page header */
	    then
	      do last_line = block.hdr.count to 1 by -1
		 while (loclin (last_line).ptr -> txtlin.white
		 & ^loclin (last_line).ptr -> txtlin.no_trim
		 & ^loclin (last_line).ptr -> txtlin.keep);
	        block.hdr.trl_ws =
		   block.hdr.trl_ws
		   + loclin (last_line).ptr -> txtlin.linespace;
	      end;
	    else last_line = block.hdr.count;

	    if bug_sw
	    then call ioa_ ("^7xblk=^d(^d)^[(W^[n^])^;^s^] siz=^d/^f(^f) "
		    || "^a^[ M^]^[ ftn=^d/^f^[(first)^]^;^3s^]"
		    || " col=d^f u^f(^f)^[/^f/^f^;^s^]", iblk,
		    block.blkndx, block.hdr.white, block.hdr.no_trim,
		    block.hdr.count, show (block.hdr.used, 12000),
		    show (block.hdr.trl_ws, 12000), block.blktype,
		    block.hdr.modified, block.hdr.ftn.ct > 0,
		    block.hdr.ftn.ct, show (block.hdr.ftn.usd, 12000),
		    (colftn.ct = 0), show (coldepth, 12000),
		    show (colusd, 12000), show (coldisc (icol), 12000),
		    (colftn.ct > 0), show (colftn.usd, 12000),
		    show (colusd + colftn.usd, 12000));

/* trim leading white space from first column blocks */
	    if (icol = 0 & iblk = 2 + bin (col0.hdrusd > 0)
	         & coldepth = head_used)
	         | (icol > 0 & iblk = curbalblk & page.hdr.col_count >= 1
	         & coldepth = page.hdr.baldepth)
	    then
TRIM_LWS:
	      do;			/* if trimmable WS, throw it away */
	        if block.hdr.white & ^block.hdr.no_trim & ^block.parms.keep
	        then
		do;
		  if icol < 2 | ^bal_sw
		  then
		    do;
		      if bug_sw
		      then call ioa_ ("   (Trimming ^f leading WS"
			      || " in col ^d)",
			      show (block.hdr.used, 12000), icol);

		      col.hdr.used = col.hdr.used - block.hdr.used;
		      col.hdr.baldepth = coldepth;
/****		      col.hdr.pspc =
/****			 max (col.hdr.pspc - block.hdr.used, 0);*/
				/* page, too? */
		      if page.hdr.col_count < 2 | icol = 0
		      then page.hdr.used = page.hdr.used - block.hdr.used;
				/* give the block back */
		      call comp_util_$relblk (icol, col.blkptr (iblk));
				/* close up block ptr array */
		      do j = iblk + 1 to col.hdr.blkct + 1;
		        col.blkptr (j - 1) = col.blkptr (j);
		      end;
		      col.blkptr (j - 1) = null ();
				/* balance at this block */
		      col.hdr.balblk, curbalblk = iblk;
				/* if page now doesnt overflow, */
				/* go back for more */
		      if page.hdr.used + col0.hdr.ftn.usd < page.hdr.net
			 & break_type = block_break & pagoflo
		      then
		        do;
			col.hdr.baldepth, page.hdr.baldepth =
			     max (coldepth, page.hdr.baldepth);
			pagusd = page.hdr.used;
			pagoflo = "0"b;
			goto return_;
		        end;
		    end;

		  if icol > 1 & bal_sw
		  then
		    do;
		      rebalnet =
			 colnet
			 - 12000
			 *
			 floor (
			 divide (block.hdr.used,
			 12000 * page.parms.cols.count, 31, 10));
				/* advance to next block */
		      curbalblk = curbalblk + 1;

		      if bug_sw
		      then call ioa_ (
			      "^/   (Ignoring ^f leading WS in col "
			      || "^d used=^f rebal=^f)",
			      show (block.hdr.used, 12000), icol,
			      show (locol.hdr.used - block.hdr.trl_ws,
			      12000), show (rebalnet, 12000));
		    end;
		  goto rebal;
		end;
	      end TRIM_LWS;

	    tmpdepth = coldepth;	/* fill in page depth */
	    do ilin = 1 to block.hdr.count;
	      txtlinptr = loclin (ilin).ptr;
	      txtlin.depth = coldepth;
	      coldepth = coldepth + txtlin.linespace;
	    end;

	    if block.hdr.art	/* expand artwork */
				/* except the page header */
	         & block.blktype ^= "ph"
	    then call comp_art_ (blkptr, "0"b);

	    blkusd, blkftnct, blkftnusd = 0;

	    if icol + iblk = 1	/* page header? */
	    then
	      do;
	        if page.hdr.col_count > 0
	        then
		do i = 1 to page.hdr.col_count;
		  page.column_ptr (i) -> col.hdr.baldepth =
		       max (coldepth,
		       page.column_ptr (i) -> col.hdr.baldepth);
		end;

	        page.hdr.baldepth = max (coldepth, page.hdr.baldepth);
	        goto block_fits;
	      end;

	    spcl_line = "";		/* erase special line */
	    tmpusd =
	         colusd + colftn.usd + block.hdr.used + block.hdr.ftn.usd
	         + 24000 * bin (colftn.usd = 0 & block.hdr.ftn.usd > 0);
				/* does it all fit? */
	    if tmpusd <= colnet - col.depth_adj | option.galley_opt
	    then goto block_fits;	/**/
				/* does it fit without the trl WS ? */
	    else if tmpusd - block.hdr.trl_ws <= colnet - col.depth_adj
	    then
	      do;
	        block.hdr.trl_ws = tmpusd - colnet;
				/* adjust trailing WS */
				/* force if last block on 1-up page */
	        if page.parms.cols.count <= 1 & icol <= 1
		   & iblk = col.hdr.blkct
	        then force_this_page = "1"b;
	        goto block_fits;
	      end;		/**/
				/* will short block fit sans notes? */
	    if tmpusd - block.hdr.ftn.usd <= colnet - col.depth_adj
	         & last_line
	         < 2 * widsiz + block.hdr.head_size + block.hdr.cap_size
	         & block.hdr.used - block.hdr.trl_ws
	         < 2 * widow + block.hdr.head_used + block.hdr.cap_used
	    then goto block_fits;	/**/
				/* special case for last text on */
	    else if shared.end_output /* last multi-column page */
	         & icol = page.parms.cols.count & iblk = col.hdr.blkct
	         & col.hdr.net > colnet - col.depth_adj
	    then
	      do;
	        force_this_page = "1"b;
	        goto block_fits;
	      end;

	    else goto inner_keep;

block_fits:
	    coldisc (icol) = block.hdr.trl_ws;

	    do ilin = 1 to block.hdr.count;
	      txtlinptr = loclin (ilin).ptr;

	      if txtlin.blk_splt	/* a split header line? */
	      then
	        do;		/* erase it */
		txtlin.ptr -> txtstr = "";
		txtlin.linespace = 0;

		if bug_sw & dt_sw
		then call ioa_ ("^9xlin=^d/^d^-^8xsplt hdr", ilin,
			txtlin.info.lineno);
	        end;

	      else
	        do;
		blkusd = blkusd + txtlin.linespace;
				/* if block is not the page header */
				/* or this is a galley block */
		if icol + iblk > 1 | option.galley_opt
		then colusd = colusd + txtlin.linespace;

		if bug_sw & dt_sw
		then call ioa_ (
			"^9xlin=^d/^d d^f ld=^f blk=^f^[/^f/^f^;^2s^]"
			|| " col=^f^[/^f/^f^;^2s^]^[ white^]^[ null^]"
			|| "^[ A^]", ilin, txtlin.info.lineno,
			show (txtlin.depth, 12000),
			show (txtlin.linespace, 12000),
			show (blkusd, 12000), (blkftnct > 0),
			show (blkftnusd, 12000),
			show (blkusd + blkftnusd, 12000),
			show (colusd, 12000), (colftn.ct > 0),
			show (colftn.usd, 12000),
			show (colusd + colftn.usd, 12000), txtlin.white,
			(txtlin.linespace = 0
			& txtlin.ptr -> txtstr = ""), txtlin.art);

		if coldepth > maxcoldepth
		then maxcoldepth = coldepth;
	        end;
	    end;

	    if icol + iblk = 1	/* page header? */
	    then maxcoldepth = coldepth;

	    if block.hdr.ftn.ct > 0 & block.hdr.ftn.usd > 0
	    then call take_block_notes;

	    page.hdr.modified = page.hdr.modified | block.hdr.modified;
	    goto end_block;

/* block wont fit, try widowing */
inner_keep:
	    ilin = 1;		/* in case the whole block pushes */
	    line_area_ptr = loclin (ilin).laptr;
	    line_area_ndx = loclin (ilin).landx;

	    if block.hdr.white	/* cant widow white space */
	    then
	      do;			/* too big? */
	        if block.hdr.used > col.hdr.net - col.depth_adj
	        then block.hdr.used, loclin (1).ptr -> txtlin.linespace =
		        colnet - col.depth_adj;
	        goto wont_fit;	/* move the whole block */
	      end;

	    if block.blktype = "pi"	/* cant widow pictures */
	    then
	      do;
	        if block.hdr.used > col.hdr.net - col.depth_adj
	        then
		do;
		  blkusd = block.hdr.used;
		  blkftnusd = block.hdr.ftn.usd;
		  savcolusd = colusd;
		  savcolftn = colftn;
		  goto oversize_keep;
		end;

	        goto wont_fit;	/* move the whole block */
	      end;

	    blk_mod = "0"b;		/* reset change bar control flag */
	    ilin = block.hdr.count;	/* preset counter for short block */
	    line_area_ptr = loclin (ilin).laptr;
	    line_area_ndx = loclin (ilin).landx;
				/* is block big enough? */
	    if (last_line
	         >= 2 * widsiz + block.hdr.head_size + block.hdr.cap_size
	         & block.hdr.used - block.hdr.trl_ws
	         >= 2 * widow + block.hdr.head_used + block.hdr.cap_used)
				/* or its the only one */
	         | iblk = col.hdr.blkct & iblk = curbalblk
	    then
WIDOW_BLK:
	      do;			/* clear block accumulators */
	        blkusd, blkftnct, blkftnusd, keepsz = 0;
	        keeping = "0"b;

/* first, go thru block header, top widow, and any initial keep */
	        savcolusd = colusd;
	        savcolftn = colftn;

	        do ilin = 1 to block.hdr.count
		   while (keeping | blkusd < widow + block.hdr.head_used);
		txtlinptr = loclin (ilin).ptr;

		if txtlin.blk_splt	/* a split header line? */
		then
		  do;
		    spcl_lndx = ilin;
		    spcl_line = txtlin.ptr -> txtstr;
		    txtlin.ptr -> txtstr = "";
		    spcl_linespace = txtlin.linespace;
		    txtlin.linespace = 0;

		    if bug_sw & dt_sw
		    then call ioa_ ("^9xlin=^dK/^d^2-splt hdr", ilin,
			    txtlin.info.lineno);
		  end;

		else
		  do;
		    blkusd = blkusd + txtlin.linespace;
		    colusd = colusd + txtlin.linespace;

		    if bug_sw & dt_sw
		    then call ioa_ ("^9xlin=^dK^[^^K^]/^d d^f ld=^f"
			    || "^[ |^]^[ *^]^[ ftn=^d/^f^;^2s^]"
			    || " blk=^f^[/^f/^f^;^2s^]"
			    || " col=^f^[/^f/^f^;^2s^]"
			    || "^[ white^]^[ null^]"
			    || "^[ (initial keep/widow)^]", ilin,
			    txtlin.end_keep, txtlin.info.lineno,
			    show (txtlin.depth, 12000),
			    show (txtlin.linespace, 12000),
			    (txtlin.cbar.add | txtlin.cbar.mod),
			    txtlin.cbar.del, (txtlin.ftn.ct > 0),
			    txtlin.ftn.ct, show (txtlin.ftn.used, 12000),
			    show (blkusd, 12000), (blkftnct > 0),
			    show (blkftnusd, 12000),
			    show (blkusd + blkftnusd, 12000),
			    show (colusd, 12000), (colftn.ct > 0),
			    show (colftn.usd, 12000),
			    show (colusd + colftn.usd, 12000),
			    txtlin.white,
			    (txtlin.linespace = 0
			    & txtlin.ptr -> txtstr = ""), (ilin = 1));
				/**/
				/* any footnotes for this line? */
		    if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0 & ^ftn_held
		    then
		      do;
		        call take_line_notes (ilin);
		        if note_oflo & linftnct = 0
		        then
			do;
			  ilin = 1;
			  goto wont_fit;
			end;

		        if rebal_sw
		        then goto COL_LOOP;
		      end;	/**/
				/* count keep */
		    if txtlin.keep | txtlin.end_keep
		    then
		      do;
		        keepsz = keepsz + txtlin.linespace;
		        if txtlin.keep
		        then keeping = "1"b;
		        else keeping = "0"b;
		      end;	/**/
				/* change bars */
		    blk_mod =
		         blk_mod | txtlin.cbar.mod | txtlin.cbar.add
		         | txtlin.cbar.del;
		  end;
	        end;		/**/
				/* oversize keep */
	        if blkusd + blkftnusd > col.hdr.net - col.depth_adj
	        then
		do;
		  ilin = 1;
		  goto oversize_keep;
		end;		/**/
				/* keep wont fit */
	        if colusd + colftn.usd > col.hdr.net - col.depth_adj
	        then
		do;
		  colusd = savcolusd;
		  colftn = savcolftn;
		  ilin = 1;
		  line_area_ptr = loclin (ilin).laptr;
		  line_area_ndx = loclin (ilin).landx;

		  if db_sw
		  then call ioa_ ("^-(push keep)");

		  goto wont_fit;
		end;
	      end WIDOW_BLK;

	    else
	      do;			/* block cant be widowed */
	        if icol > 0		/* if a multicolumn page */
		   & force_bal	/* and a forced balance */
/****		   & rebal_sw	/* and rebalancing */
	        then
		do;		/* a short page? */
		  if balnet < col.hdr.net
		       & block.hdr.used + col.depth_adj > balnet
		  then tmpnet =
			  min (col.hdr.net,
			  colusd + block.hdr.used + col.depth_adj);
				/* if we got any */
		  if tmpnet > colnet
		  then
		    do;
		      if bug_sw
		      then call ioa_ ("^3x(Extending col ^d by ^f "
			      || "for keep/widow)", icol,
			      show (tmpnet - colnet, 12000));

		      colusd = col.hdr.balusd;
		      colftn = col.hdr.balftn;
		      rebalnet = tmpnet;
		      rebal_sw = "1"b;
		      goto rebal;
		    end;
		end;

	        blkusd = block.hdr.used;
	        blkftnusd = block.hdr.ftn.usd;
	        blkftnct = block.hdr.ftn.ct;
	        ilin = 1;
	        line_area_ptr = loclin (ilin).laptr;
	        line_area_ndx = loclin (ilin).landx;
	        goto wont_fit;
	      end;

/* if even header/widow/keep wont fit */
	    if colusd + colftn.usd > colnet
	    then
	      do;			/**/
	        colusd = savcolusd;	/* restore space used */

	        if icol > 0		/* if a multicolumn page */
		   & (pagoflo	/* and page overflow */
		   | bal_sw)	/* or balance break */
	        then
		do;
/****		  rebalnet = 0;	/**/
				/* keep block on a short page? */
		  if ilin > block.hdr.count
		  then		/* does keep fit? */
		       if balnet < col.hdr.net
			  & colusd + blkusd
			  <= col.hdr.net - col.depth_adj
		       then tmpnet = min (col.hdr.net, colusd + blkusd);
				/* trailing widow? get extra space */
		       else if ilin
			  >= block.hdr.count - widsiz
			  - block.hdr.cap_size
		       then tmpnet =
			       min (colnet + widow, col.hdr.used,
			       page.hdr.net - col0.hdr.used
			       - col0.hdr.ftn.usd);
				/* if we got any */
		  if tmpnet > colnet
		  then
		    do;
		      if bug_sw
		      then call ioa_ ("^3x(Extending col ^d by ^f "
			      || "for keep/widow)", icol,
			      show (tmpnet - colnet, 12000));

		      colusd = col.hdr.balusd;
		      colftn = col.hdr.balftn;
		      rebalnet = tmpnet;
		      rebal_sw = "1"b;
		      goto rebal;
		    end;
		end;

/* if an oversize keep or too many widow footnotes */
oversize_keep:
	        line_area_ptr = loclin (ilin).laptr;
	        line_area_ndx = loclin (ilin).landx;
	        if blkusd + blkftnusd + 12000 * bin (blkftnusd > 0)
		   > page.hdr.net
	        then
		do;		/* restore column data */
		  colusd = savcolusd;
		  colftn = savcolftn;

		  if block.hdr.white/* truncate white space */
		  then		/* and move the whole block */
		    do;
		      blkusd, block.hdr.used,
			 loclin (1).ptr -> txtlin.linespace = colnet;
		      ilin = 1;
		      line_area_ptr = loclin (ilin).laptr;
		      line_area_ndx = loclin (ilin).landx;
		      goto wont_fit;
		    end;

		  if block.hdr.count = 1 & block.hdr.ftn.ct = 1
		  then		/* cant split one-liners */
		    do;		/* back up one line */
		      txtlinptr = loclin (ilin - 1).ptr;

		      call comp_report_ (4, 0,
			 "An unbreakable block "
			 ||
			 "ending here cannot be split, file is aborted.",
			 addr (txtlin.info), txtlin.ptr -> txtstr);

		      signal comp_abort;
		    end;		/**/
				/* determine the last free line */
		  if blkusd > page.hdr.net
		  then		/* if block is too big */
		    do;		/* skip trailing WS */
		      do last_line = block.hdr.count to 1 by -1
			 while (loclin (last_line).ptr -> txtlin.ptr
			 -> txtstr = "");
		      end;

		      widct = 0;
		      do last_line = last_line to 1 by -1
			 while (widct < widsiz);
		        if loclin (last_line).ptr -> txtlin.linespace ^= 0
		        then widct = widct + 1;
		      end;
		    end;		/**/
				/* if last free line has no lead, back
				   up to previous lead with lead */
		  if loclin (last_line).ptr -> txtlin.linespace = 0
		  then
		    do;
		      do last_line = last_line to 1 by -1
			 while (loclin (last_line).ptr
			 -> txtlin.linespace = 0);
		      end;
		    end;		/**/
				/* find the page break point */
		  blkusd, blkftnct, blkftnusd = 0;
		  do ilin = 1 to last_line;
		    ftnusd = 0;	/* find the next line with lead */
		    do j = ilin to last_line
		         while (loclin (j).ptr -> txtlin.linespace = 0);
		      ftnusd = ftnusd + loclin (j).ptr -> txtlin.ftn.used;
		    end;		/**/
				/* if thats too much */
		    if j <= last_line
		    then if colusd + colftn.usd + ftnusd + col.depth_adj
			    + loclin (j).ptr -> txtlin.linespace
			    + loclin (j).ptr -> txtlin.ftn.used > colnet
		         then goto split_keep;
				/* take the line */
		    txtlinptr = loclin (ilin).ptr;

		    blkusd = blkusd + txtlin.linespace;
		    colusd = colusd + txtlin.linespace;

		    if bug_sw & dt_sw
		    then call ioa_ ("^9xlin=^d^[K^;W^]/^d d^f ld=^f"
			    || "^[ |^]^[ *^]^[ ftn=^d/^f^;^2s^]"
			    || " blk=^f^[/^f/^f ^;^2s^]"
			    || " col=^f^[/^f/^f^;^2s^]^[ white^]"
			    || "^[ null^]^[ (oversize keep ^d)^]", ilin,
			    txtlin.keep, txtlin.info.lineno,
			    show (txtlin.depth, 12000),
			    show (txtlin.linespace, 12000),
			    (txtlin.cbar.add | txtlin.cbar.mod),
			    txtlin.cbar.del, (txtlin.ftn.ct > 0),
			    txtlin.ftn.ct, show (txtlin.ftn.used, 12000),
			    show (blkusd, 12000), (blkftnct > 0),
			    show (blkftnusd, 12000),
			    show (blkusd + blkftnusd, 12000),
			    show (colusd, 12000), (colftn.ct > 0),
			    show (colftn.usd, 12000),
			    show (colusd + colftn.usd, 12000),
			    txtlin.white, (txtlin.ptr -> txtstr = ""),
			    (ilin = 1), last_line);
				/* any footnotes? */
		    if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0 & ^ftn_held
		    then
		      do;
		        call take_line_notes (ilin);

		        if blkftnct = 0
		        then goto split_keep;

		        if rebal_sw
		        then goto COL_LOOP;
		      end;	/**/
				/* truncate white space */
		    if txtlin.linespace > page.hdr.net
		    then
		      do;
		        call comp_report_ (2, 0,
			   "Embedded white space exceeds max "
			   || "page/column space. It will be truncated.",
			   addr (txtlin.info), ctl_line);
		        txtlin.linespace = colnet - (colusd + colftn.usd);
		      end;

		    tmpdepth = tmpdepth - txtlin.linespace;
		  end;

split_keep:
		  coldepth = loclin (ilin - 1).ptr -> txtlin.depth;
				/* if the page is extended */
		  if coldepth > maxcoldepth
		  then
		    do;
		      pagusd = max (pagusd, coldepth - head_used);
		      maxcoldepth = tmpdepth;
		    end;

		  blkusd = 0;	/* clean necessary for split_block */
		  goto split_block;
		end;

	        ilin = 1;		/* must move the whole block */
	        line_area_ptr = loclin (ilin).laptr;
	        line_area_ndx = loclin (ilin).landx;

wont_fit:
	        coldepth = tmpdepth;	/**/
				/* set page overflow */
	        if (icol = 0 |	/* if column 0 or last column */
		   icol = page.parms.cols.count)
				/* & colnet >= col.hdr.net*/
	        then pagoflo = "1"b;	/**/
				/* record new trailing WS */
	        if ilin = 1		/* pushing a whole block? */
		   & iblk > 1
	        then coldisc (icol) =
		        col.blkptr (iblk - 1) -> block.hdr.trl_ws;
	        else coldisc (icol) = 0;

	        if icol > 1 & bal_sw	/* check column balance */
	        then
		do;		/* unavoidable widow? */
		  if iblk = curbalblk & ilin = 1 & blkusd < 2 * widow
		  then
		    do;
		      widsiz = widsiz - 1;
		      widow = widow - 12000;
				/* reduce widow size */
		      if bug_sw & dt_sw
		      then call ioa_ ("^5x(Changing widow to ^f)",
			      show (widow, 12000));
		      goto COL_LOOP;/* and try again */
		    end;

		  if icol > 1
		  then
		    do;
		      mincolusd, maxcolusd, tmpnet =
			 colusd + colftn.usd + col.depth_adj
			 - coldisc (icol);
/****		      mincolusd, maxcolusd =
/****			 colusd + colftn.usd - coldisc (icol);*/

		      if bug_sw & dt_sw
		      then call ioa_$nnl ("^5x(colusd=^d/^f(^f)", icol,
			      show (tmpnet + coldisc (icol), 12000),
			      show (coldisc (icol), 12000));

		      do j = 1 to icol - 1;
		        locolptr = page.column_ptr (j);
		        tmpnet =
			   tmpnet + locol.hdr.used + locol.hdr.ftn.usd
			   + locol.depth_adj;
		        mincolusd =
			   min (mincolusd,
			   locol.hdr.used + locol.hdr.ftn.usd
			   + locol.depth_adj - coldisc (j));
		        maxcolusd =
			   max (maxcolusd,
			   locol.hdr.used + locol.hdr.ftn.usd
			   + locol.depth_adj - coldisc (j));

		        if bug_sw & dt_sw
		        then call ioa_$nnl (" ^d/^f(^f)", j,
			        show (locol.hdr.used
			        + locol.hdr.ftn.usd + locol.depth_adj,
			        12000), show (coldisc (j), 12000));
		      end;

		      if bug_sw & dt_sw
		      then call ioa_ (")");

		      pagenet = page.hdr.net - col0.hdr.used;
		      tmpnet =
			 min (pagenet,
			 12000
			 *
			 floor (
			 divide (tmpnet, page.parms.cols.count * 12000,
			 31, 10)));
				/* check balancing */
		      unbal = maxcolusd - mincolusd;
		      if unbal > 12000 & unbal ^= last_unbal
		      then
		        do;
			last_unbal = unbal;
			rebalnet = tmpnet;

			if bug_sw
			then call ioa_ ("   (Unbalance of ^f at"
				|| " column ^d rebal=^f)",
				show (unbal, 12000), icol,
				show (rebalnet, 12000));
			rebal_sw = "1"b;
			goto COL_LOOP;
		        end;

/****		      rebalnet = 0; /* erase it */
		    end;
		end;

	        call push_oflo;	/* remove column overflow */
				/* if last column and */
				/* page has overflowed, eject it */
	        if (icol = 0 | icol = page.parms.cols.count) & pagoflo
	        then
		do;
		  if ^ftn_held
		  then
		    do;
		      col.hdr.ftn = colftn;
				/* erase ftn header space */
		      if icol + colftn.ct = 0
		      then col.hdr.ftn.usd = 0;
		    end;

		  call flush_page;
		  if shared.end_output
		  then goto return_;

		  page.hdr.depth = head_used;
		  page.hdr.used, maxcoldepth = 0;

		  if icol = 0
		  then call pull_oflo (0, 0);

		  else
		    do;
		      call pull_oflo (icol, 1);
		      icol, page.hdr.col_index = 1;
		      shared.colptr = page.column_ptr (1);
		    end;		/**/
				/* extra space for footnote header */
		  if ^ftn_held & col.hdr.ftn.usd > 0
		  then col.hdr.ftn.usd =
			  col.hdr.ftn.usd + ftnhdr.hdr.used + 12000;
				/* if page still overflows */
		  if (page.hdr.used > page.hdr.net
		       & break_type ^= need_break
		       & icol = page.parms.cols.count)
		       | break_type = page_break
		  then
		    do;
		      if bug_sw
		      then call ioa_ ("^5x(continued page overflow)");
		      goto COL_LOOP;
		    end;
		  else pagoflo = "0"b;

/****		  if page.hdr.used > 0
/****		       & (bal_sw & break_type >= column_break
/****		       | page.hdr.col_count <= 1 & break_type = page_break)*/
		  if page.hdr.used > 0 & bal_sw & break_type = page_break
		  then goto COL_LOOP;
		  else goto page_exit;
		end;

	        else call pull_oflo (icol,
		        mod (icol, page.parms.cols.count) + 1);
				/* if an explicit balance break */
	        if break_type = column_break & icol = page.hdr.col_count
	        then
		do;
		  if bal_sw
		  then
		    do;
/****		      rebalnet = 0;*/
		      rebal_sw = "0"b;
		      if bug_sw
		      then call ioa_ ("^5x(explicit balance demanded)");
		      goto COL_LOOP;
		    end;		/**/
				/* not last column? */
		  else if icol < page.parms.cols.count
		  then call pull_oflo (icol,
			  mod (icol, page.parms.cols.count) + 1);

		  else goto page_exit;
		end;

	        if icol = 0 | (pagoflo & icol = page.parms.cols.count)
	        then goto page_exit;

	        else goto column_exit;/* continue with next column */
	      end;

/* keep/widow + footnotes fit, now for free lines */
free_lines:			/**/
				/* dont count trailing WS */
	    coldepth = coldepth - block.hdr.trl_ws;

/* any free lines? */
	    if ^blk_split (icol)
	    then
	      do;
	        if ilin - 1 < last_line - widsiz - block.hdr.cap_size
	        then
		do;
		  cap_count, widusd = 0;
		  do last_line = last_line to 1 by -1
		       while (widusd <= widow);
		    if cap_count < block.hdr.cap_size
		    then cap_count = cap_count + 1;
		    else widusd =
			    widusd
			    + loclin (last_line).ptr -> txtlin.linespace;
		  end;
		end;
	        else last_line = 0;
	      end;
	    else last_line = block.hdr.count - 1;

	    if spcl_line ^= ""	/* split header in the widow? */
	    then
	      do;
	        ctl_line = spcl_line;
	        call comp_ctls_ (text_added);
	        if text_added
	        then
		do;
		  call comp_util_$replace_text (blkptr, "1"b,
		       loclin (spcl_lndx).ptr, addr (ctl_line));
		  loclin (spcl_lndx).ptr -> txtlin.linespace =
		       spcl_linespace;
		end;
	      end;

FREE_LINES:
	    do ilin = ilin to last_line + 1;
	      txtlinptr = loclin (ilin).ptr;

	      if colusd + colftn.usd + txtlin.linespace
		 > colnet - col.depth_adj
	      then		/* if line wont fit, back */
	        do;		/* up to last line with lead */
		do ilin = ilin - 1 by -1 to 1
		     while (loclin (ilin).ptr -> txtlin.linespace = 0);
		end;

		ilin = ilin + 1;	/* push the next one */
		coldepth =	/* final column depth */
		     loclin (ilin).ptr -> txtlin.depth;
		goto split_block;
	        end;

	      if txtlin.blk_splt
	      then
	        do;
		if bug_sw & dt_sw
		then call ioa_ ("^9xlin=^dK/^d ^2-splt hdr", ilin,
			txtlin.info.lineno);

		ctl_line = txtlin.ptr -> txtstr;
		call comp_ctls_ (text_added);
		if text_added
		then call comp_util_$replace_text (blkptr, "1"b,
			loclin (k).ptr, addr (ctl_line));
		else txtlin.ptr -> txtstr = "";
	        end;

	      else
	        do;
		if txtlin.keep	/* is it an internal keep? */
		then
		  do;		/**/
				/* in case keep pushes */
		    tmpdepth = loclin (ilin - 1).ptr -> txtlin.depth;
		    keeping = "1"b; /* loop control flag */
		    keepsz = 0;	/**/
				/* in case it wont fit */
		    line_area_ptr = loclin (ilin - 1).laptr;
		    line_area_ndx = loclin (ilin - 1).landx;

		    do j = ilin to block.hdr.count while (keeping);
		      txtlinptr = loclin (j).ptr;
				/* count keep */
		      if txtlin.keep | txtlin.end_keep
		      then
		        do;
			keepsz = keepsz + txtlin.linespace;

			if bug_sw & dt_sw
			then call ioa_ ("^9xlin=^dK/^d d^f ld=^f"
				|| "^[ |^]^[ *^]^[ ftn=^d/^f^;^2s^]"
				|| " blk=^f^[/^f/^f^;^2s^]"
				|| " col=^f^[/^f/^f^;^2s^]"
				|| "^[ white^]^[ null^]^[ endkeep^]"
				|| "^[ (initial keep/widow)^]", j,
				txtlin.info.lineno,
				show (txtlin.depth, 12000),
				show (txtlin.linespace, 12000),
				(txtlin.cbar.add | txtlin.cbar.mod),
				txtlin.cbar.del, (txtlin.ftn.ct > 0),
				txtlin.ftn.ct,
				show (txtlin.ftn.used, 12000),
				show (blkusd + keepsz, 12000),
				(blkftnct > 0),
				show (blkftnusd, 12000),
				show (blkusd + blkftnusd, 12000),
				show (colusd + keepsz, 12000),
				(colftn.ct > 0),
				show (colftn.usd, 12000),
				show (colusd + colftn.usd, 12000),
				txtlin.white,
				(txtlin.linespace = 0
				& txtlin.ptr -> txtstr = ""),
				(txtlin.end_keep), (ilin = 1));
				/**/
				/* set loop control flag */
			if ^txtlin.end_keep
			then keeping = "1"b;
			else keeping = "0"b;
		        end;	/**/
				/* change bars */
		      blk_mod =
			 blk_mod | txtlin.cbar.mod | txtlin.cbar.add
			 | txtlin.cbar.del;
				/* footnotes for this line */
		      if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0
			 & ^ftn_held
		      then
		        do;
			call take_line_notes (j);

			if rebal_sw
			then goto COL_LOOP;
		        end;
		    end;		/**/
				/* if keep wont fit */
				/* split at current ilin */
		    if colusd + colftn.usd + keepsz + ftnusd > colnet
		    then goto wont_fit;

		    else
		      do;		/* keep going */
		        ilin = j;
		        txtlinptr = loclin (ilin).ptr;

		        blkusd = blkusd + keepsz;
		        colusd = colusd + keepsz;
		      end;
		  end;

		j = ilin;		/* preset table/title block index */

		if txtlin.title	/* a <title>? */
		then
		  do;		/* take all the parts */
		    do j = ilin to ilin + 2
		         while (loclin (j).ptr -> txtlin.linespace = 0);
		      txtlinptr = loclin (j).ptr;

		      blk_mod =
			 blk_mod | txtlin.cbar.mod | txtlin.cbar.add
			 | txtlin.cbar.del;

		      if bug_sw & dt_sw
		      then call ioa_ (
			      "^9xlin=^dTI/^d d^f ld=^f^[ |^]^[ *^]"
			      ||
			      "^[ ftn=^d/^f^;^2s^] blk=^f^[/^f/^f^;^2s^]"
			      || " col=^f^[/^f/^f^;^2s^]"
			      || " ^[ ftn=^d^;^s^]"
			      || "^[ white^]^[ null^]", j,
			      txtlin.info.lineno,
			      show (txtlin.depth, 12000),
			      show (txtlin.linespace, 12000),
			      (txtlin.cbar.add | txtlin.cbar.mod),
			      txtlin.cbar.del, (txtlin.ftn.ct > 0),
			      txtlin.ftn.ct,
			      show (txtlin.ftn.used, 12000),
			      show (blkusd + txtlin.linespace, 12000),
			      (blkftnct > 0), show (blkftnusd, 12000),
			      show (blkusd + blkftnusd, 12000),
			      show (colusd + txtlin.linespace, 12000),
			      (colftn.ct > 0), show (colftn.usd, 12000),
			      show (colusd + colftn.usd, 12000),
			      txtlin.white,
			      (txtlin.linespace = 0
			      & txtlin.ptr -> txtstr = ""));
				/* take footnotes */
		      if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0
			 & ^ftn_held
		      then
		        do;
			call take_line_notes (j);

			if rebal_sw
			then goto COL_LOOP;
		        end;
		    end;

		    txtlinptr = loclin (j).ptr;
		  end;		/**/
				/* a table block? */
/****		else if block.hdr.tblblk
/****		then
/****		  do;
/****		    do j = ilin to last_line
/****		         while (loclin (j).ptr -> txtlin.linespace = 0);
/****		      txtlinptr = loclin (j).ptr;
/****
/****		      if bug_sw & dt_sw
/****		      then call ioa_ ("^9xlin=^dTA^[K^]/^d d^f ld=^f"
/****			      || "^[ |^]^[ *^]^[ ftn=^d^;^s^]"
/****			      || " blk=^f^[/^f/^f^;^2s^]"
/****			      || " col=^f^[/^f/^f^;^2s^]"
/****			      || " ^[ ftn=^d^;^s^]"
/****			      || "^[ white^]^[ null^]", j, txtlin.keep,
/****			      txtlin.info.lineno,
/****			      show (txtlin.depth, 12000),
/****			      show (txtlin.linespace, 12000),
/****			      (txtlin.cbar.add | txtlin.cbar.mod),
/****			      txtlin.cbar.del, (txtlin.ftn.ct > 0),
/****			      txtlin.ftn.ct,
/****			      show (blkusd + txtlin.linespace, 12000),
/****			      (blkftnct > 0), show (blkftnusd, 12000),
/****			      show (blkusd + blkftnusd, 12000),
/****			      show (colusd + txtlin.linespace, 12000),
/****			      (colftn.ct > 0), show (colftn.usd, 12000),
/****			      show (colusd + colftn.usd, 12000),
/****			      txtlin.white,
/****			      (txtlin.linespace = 0
/****			      & txtlin.ptr -> txtstr = ""));
/****				/* take footnotes */
/****		      if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0
/****			 & ^ftn_held
/****		      then
/****		        do;
/****			call take_line_notes (j);
/****
/****			if rebal_sw
/****			then goto COL_LOOP;
/****		        end;
/****		    end;
/****
/****		    txtlinptr = loclin (j).ptr;
/****		  end;*/

		blkusd = blkusd + txtlin.linespace;
		colusd = colusd + txtlin.linespace;

		if bug_sw & dt_sw
		then call ioa_ ("^9xlin=^d/^d d^f ld=^f"
			|| "^[ |^]^[ *^]^[ ftn=^d^;^s^]"
			|| " blk=^f^[/^f/^f^;^2s^]"
			|| " col=^f^[/^f/^f^;^2s^]"
			|| "^[ white^]^[ null^]", max (ilin, j),
			txtlin.info.lineno, show (txtlin.depth, 12000),
			show (txtlin.linespace, 12000),
			(txtlin.cbar.add | txtlin.cbar.mod),
			txtlin.cbar.del, (txtlin.ftn.ct > 0),
			txtlin.ftn.ct, show (blkusd, 12000),
			(blkftnct > 0), show (blkftnusd, 12000),
			show (blkusd + blkftnusd, 12000),
			show (colusd, 12000), (colftn.ct > 0),
			show (colftn.usd, 12000),
			show (colusd + colftn.usd, 12000), txtlin.white,
			(txtlin.linespace = 0
			& txtlin.ptr -> txtstr = ""));
				/* any footnotes? */
		if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0 & ^ftn_held
		then
		  do;
		    call take_line_notes (j);

		    if blkftnct = 0
		    then
		      do;
		        coldepth = txtlin.depth;
		        goto split_block;
		      end;

		    if rebal_sw
		    then goto COL_LOOP;
		  end;

/* if line and footnotes wont fit */
		if colusd + colftn.usd > colnet
		then
		  do;		/* truncate white space */
		    if txtlin.linespace > page.hdr.net
		    then
		      do;
		        call comp_report_ (2, 0,
			   "Embedded white space "
			   ||
			   "exceeds max page/column space. It will be truncated.",
			   addr (txtlin.info), ctl_line);
		        txtlin.linespace = colnet - (colusd + colftn.usd);
		      end;
		    else
		      do;
		        coldepth = txtlin.depth;
		        goto split_block;
		      end;
		  end;

		blk_mod =
		     blk_mod | txtlin.cbar.mod | txtlin.cbar.add
		     | txtlin.cbar.del;
		ilin = max (ilin, j);
	        end;
	    end FREE_LINES;

/* down to the widow */
	    if icol > 0		/* multicolumn? */
				/* and last block in column? */
	         & iblk = col.hdr.blkct
	    then
	      do;			/* try extra space for the widow */
	        tmpnet =
		   min (colnet + widow, colusd + col.depth_adj,
		   page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd);
				/* if we got any */
	        if tmpnet - colnet > 0
	        then if tmpnet - mincolusd <= 12000
		        | break_type > block_break
		   then
		     do;
		       if bug_sw
		       then call ioa_ ("^3x(Extending col ^d by ^f for "
			       || "widow)", icol,
			       show (tmpnet - colnet, 12000));

		       colusd = col.hdr.balusd;
		       colftn = col.hdr.balftn;
		       rebalnet = tmpnet;
		       rebal_sw = "1"b;
		       goto rebal;
		     end;
/****	        rebalnet = 0;	/* erase so we dont screw up later */
	      end;		/**/
				/* take bottom widow & caption */
	    savblkusd = blkusd;	/* save current data in case */
	    savcolusd = colusd;	/* widow pushes */
	    savftnct = blkftnct;
	    savftnusd = blkftnusd;
	    savcolftn = colftn;
/****	tmpdepth = coldepth;	/**/
				/* trim trailing WS */
	    do last_line = block.hdr.count to ilin by -1
	         while (loclin (last_line).ptr -> txtlin.white
	         & ^loclin (last_line).ptr -> txtlin.no_trim);
	    end;			/* run through remaining lines, */
	    tmpusd = 0;		/* measuring space used */
	    do i = ilin to last_line;
	      txtlinptr = loclin (i).ptr;
	      tmpusd = tmpusd + txtlin.linespace;
	    end;			/**/
				/* if even the widow wont fit */
	    if colusd + colftn.usd + tmpusd + col.depth_adj > colnet
	    then
	      do;
	        if db_sw
	        then call ioa_ ("^-(push widow)");

	        goto push_widow;
	      end;

	    blkusd = blkusd + tmpusd; /* commit the widow */
	    colusd = colusd + tmpusd;

	    if bug_sw & dt_sw
	    then call ioa_ ("^2-Bottom widow committed: ^d/^f"
		    || " blk=^f^[/^f/^f^;^2s^] col=^f^[/^f/^f^;^2s^]",
		    last_line - ilin + 1, show (tmpusd, 12000),
		    show (blkusd, 12000), (blkftnct > 0),
		    show (blkftnusd, 12000),
		    show (blkusd + blkftnusd, 12000), show (colusd, 12000),
		    (colftn.ct > 0), show (colftn.usd, 12000),
		    show (colusd + colftn.usd, 12000));
				/* run thru again, taking the lines */
	    do j = ilin to last_line;
	      txtlinptr = loclin (j).ptr;

	      if bug_sw & dt_sw
	      then call ioa_ ("^9xlin=^d^[K^;W^]d d^f ld=^f"
		      || "^[ |^]^[ *^]^[ ftn=^d/^f^;^2s^]"
		      || " blk=^f^[/^f/^f^;^2s^]"
		      || " col=^f^[/^f/^f^;^2s^]" || "^[ white^]^[ null^]",
		      j, txtlin.keep, txtlin.info.lineno,
		      show (txtlin.depth, 12000),
		      show (txtlin.linespace, 12000),
		      (txtlin.cbar.add | txtlin.cbar.mod), txtlin.cbar.del,
		      (txtlin.ftn.ct > 0), txtlin.ftn.ct,
		      show (txtlin.ftn.used, 12000), show (blkusd, 12000),
		      (blkftnct > 0), show (blkftnusd, 12000),
		      show (blkusd + blkftnusd, 12000),
		      show (colusd, 12000), (colftn.ct > 0),
		      show (colftn.usd, 12000),
		      show (colusd + colftn.usd, 12000), txtlin.white,
		      (txtlin.linespace = 0 & txtlin.ptr -> txtstr = ""));

	      blk_mod = blk_mod |	/* change bars */
		 txtlin.cbar.mod | txtlin.cbar.add | txtlin.cbar.del;
				/* footnotes for this line */
	      if txtlin.ftn.ct > 0 & txtlin.ftn.used > 0
		 & (^ftn_held | ctl.default)
	      then
	        do;
		call take_line_notes (j);

		if blkftnct = 0
		then goto push_widow;

		if rebal_sw
		then goto COL_LOOP;
	        end;
	    end;			/**/
				/* does the widow fit? */
	    if colusd + colftn.usd <= colnet
	    then ilin = j;

	    else
	      do;
push_widow:
	        blkusd = savblkusd;
	        blkftnct = savftnct;
	        blkftnusd = savftnusd;
	        colusd = savcolusd;
	        colftn = savcolftn;
	        coldepth = loclin (ilin).ptr -> txtlin.depth;
	      end;

split_block:
	    block.line_area.cur, line_area_ptr = loclin (ilin - 1).laptr;
	    line_area_ndx = loclin (ilin - 1).landx;

	    if ilin <= block.hdr.count
	    then
	      do;
	        if loclin (line_area_ndx).ptr -> txtlin.white
		   & ^loclin (line_area_ndx).ptr -> txtlin.no_trim
		   & ^loclin (line_area_ndx).ptr -> txtlin.keep
	        then block.hdr.trl_ws, coldisc (icol) =
		        loclin (line_area_ndx).ptr -> txtlin.linespace;
	        else block.hdr.trl_ws, coldisc (icol) = 0;

	        if bug_sw
	        then call ioa_ (
		        "^- (split @ lin=^d/^d blk=^f(^f) col=^f(^f))",
		        ilin, txtlin.info.lineno,
		        show (blkusd - block.hdr.trl_ws, 12000),
		        show (block.hdr.trl_ws, 12000),
		        show (colusd - coldisc (icol), 12000),
		        show (coldisc (icol), 12000));
				/* if balancing is wanted, recompute */
				/* page space used based on current */
				/* break points */
	        if bal_sw & icol = page.hdr.col_count
	        then
		do;		/* accumulate total column space */
				/* of columns already processed */
		  tmpnet = colusd + colftn.usd - coldisc (icol);
		  mincolusd, maxcolusd =
		       colusd + colftn.usd + col.depth_adj
		       - coldisc (icol);

		  do j = 1 to icol - 1;
		    locolptr = page.column_ptr (j);
		    tmpnet =
		         tmpnet + locol.hdr.used + locol.hdr.ftn.usd
		         - coldisc (j);
		    mincolusd =
		         min (mincolusd,
		         locol.hdr.used + locol.hdr.ftn.usd
		         + locol.depth_adj - coldisc (j));
		    maxcolusd =
		         max (maxcolusd,
		         locol.hdr.used + locol.hdr.ftn.usd
		         + locol.depth_adj - coldisc (j));
		  end;

		  pagenet = page.hdr.net - col0.hdr.used;
		  tmpnet =
		       min (pagenet,
		       12000
		       *
		       floor (
		       divide (tmpnet, page.parms.cols.count * 12000, 31,
		       10)));	/**/
				/* check balancing */
		  unbal = maxcolusd - mincolusd;

		  if unbal > 12000 & unbal ^= last_unbal
		  then
		    do;
		      last_unbal = unbal;

		      if bug_sw
		      then call ioa_ (
			      "   (Unbalance of ^f at column ^d rebal=^f)",
			      show (unbal, 12000), icol,
			      show (tmpnet, 12000));

		      rebalnet = tmpnet;
		      rebal_sw = "1"b;
		      goto COL_LOOP;
		    end;

/****		  rebalnet = 0;	/* erase it */
		end;		/**/
				/* if last column on the page */
				/* be sure the flag is set */
	        if icol = page.parms.cols.count
	        then pagoflo = "1"b;

	        if iblk < col.hdr.blkct | ilin <= block.hdr.count
	        then call push_oflo;

	        page.hdr.modified = page.hdr.modified | blk_mod;
				/* eject if 1-up or last column */
	        if page.parms.cols.count <= 1
		   | icol = page.parms.cols.count | icol = 0
	        then
		do;		/* erase ftn header space */
		  if icol = 0 & colftn.ct = 0
		  then col.hdr.ftn.usd = 0;

		  call flush_page;
		  if shared.end_output
		  then goto return_;

		  if icol = 0
		  then call pull_oflo (0, 0);

		  else
		    do;
		      call pull_oflo (icol, 1);
		      icol, page.hdr.col_index = 1;
		      shared.colptr = page.column_ptr (icol);
		    end;		/**/
				/* extra space for footnote header */
		  if ^ftn_held & col.hdr.ftn.usd > 0
		  then col.hdr.ftn.usd =
			  col.hdr.ftn.usd + ftnhdr.hdr.used + 12000;
				/* if page still overflows */
		  if (page.hdr.used > page.hdr.net
		       & icol = page.parms.cols.count)
		       | break_type = page_break
		  then
		    do;
		      if bug_sw
		      then call ioa_ ("^5x(continued page overflow)");
		      force_bal = "1"b;
		      goto COL_LOOP;
		    end;
		  else pagoflo = "0"b;

		  shared.colptr = page.column_ptr (icol);
		  page.hdr.depth = col.hdr.depth;
				/* if an explicit balance break */
		  if (break_type = column_break & bal_sw
				/* or a page break */
		       | break_type = page_break
				/*				/* or a need break */
				/*		     | break_type = need_break*/
				/* or a 1-up page still overflows */
		       | page.parms.cols.count < 2 & pagusd > page.hdr.net)
		       & page.hdr.used > 0
				/* and theres something there */
		  then
		    do;
/****		      rebalnet = 0;*/
		      goto COL_LOOP;
		    end;
		  else goto page_exit;
		end;

	        else if icol > 0
	        then
		do;		/* move overflow to next column */
		  call pull_oflo (icol,
		       mod (icol, page.parms.cols.count) + 1);
				/* in case of footnotes */
		  colusd = col.hdr.used;
		  goto column_exit; /* go do it */
		end;

	        else goto column_exit;
	      end;
%page;
push_oflo:
  proc ();

    dcl (ii, jj)	   fixed bin;	/* working index */
    dcl oblkct	   fixed bin;	/* overflow block count */
    dcl olinptr	   ptr;		/* overflow line */
    dcl 1 olin	   aligned like text_entry based (olinptr);

    dcl max	   builtin;

    oblkct = col.hdr.blkct - iblk + 1;	/* block count for this overflow */
				/* check overflow block limit */
    if oflo.ct + oblkct > hbound (oflo.blkptr, 1)
    then
      do;
        call comp_report_$ctlstr (4, 0, addr (txtlin.info), ctl_line,
	   "Program limitation. More than ^d overflow blocks.",
	   hbound (oflo.blkptr, 1));
        signal comp_abort;
        return;
      end;

    if bug_sw
    then call ioa_ ("^5xpush_oflo: (col=^d b^d d^f u^f(^f)"
	    || "^[ ftn=^d/^f^;^2s^] blks=^d^[ lins^d/^d^]"
	    || "^[ dfrftn=^d/^f)^])", icol, iblk, show (coldepth, 12000),
	    show (colusd, 12000), show (coldisc (icol), 12000),
	    (colftn.ct > 0), colftn.ct, show (colftn.usd, 12000), oblkct,
	    (ilin > 1), ilin - 1, block.hdr.count - ilin + 1, dfrftn.ct > 0,
	    dfrftn.ct, show (dfrftn.usd, 12000));

    oflo.ct = oflo.ct + oblkct;	/* overflow block grand total */
    if oflo.ct > 0			/* push down any previous overflow */
    then
      do;
        do ii = oflo.ct to 1 by -1;
	oflo.blkptr (ii + oblkct + bin (ilin > 1)) = oflo.blkptr (ii);
	oflo.blkptr (ii) = null;
/**** PUSH NOTES TOO */
        end;
      end;

    if ilin > 1			/* if the overflow block splits */
    then
      do;				/* get a block */
        call comp_util_$getblk (-1, oflo.blkptr (1), "ot", addr (block.parms),
	   "0"b);
        ofloblkptr = oflo.blkptr (1);

        blk_split (icol) = "1"b;	/* set block split flag */
				/* reset table depths */
        if block.hdr.tblblk & shared.table_mode
        then
	do;
	  tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
	  do i = 0 to tblfmt.ncols;
	    tblfmt.colptr (i) -> tblcol.depth = 0;
	  end;
	  tblfmt.maxdepth = 0;
	end;			/**/
				/* move the overflow lines */
        do ii = ilin to block.hdr.count;
	olinptr = loclin (ii).ptr;

	call comp_util_$add_text (ofloblkptr, "0"b, "0"b, "0"b, "0"b,
	     olinptr);

	do jj = 1 to olin.ftn.ct;	/* move any footnotes */
	  ofloblk.hdr.ftn.ct = ofloblk.hdr.ftn.ct + 1;
	  oflo.ftn.ct = oflo.ftn.ct + 1;

	  if olin.ftn.blkndx (jj) > 0 /* is it a real note? */
	  then
	    do;
	      ftnblkptr = ftnblk_data.blkptr (olin.ftn.blkndx (jj));
				/* does it belong to this col? */
	      if icol = ftnblk.hdr.refer
	      then
	        do;
		ofloblk.hdr.ftn.blkndx (ofloblk.hdr.ftn.ct),
		     oflo.ftn.blkndx (oflo.ftn.ct) = olin.ftn.blkndx (jj);
		ofloblk.hdr.ftn.usd =
		     ofloblk.hdr.ftn.usd + 12000 + ftnblk.hdr.used;
		oflo.ftn.usd = oflo.ftn.usd + 12000 + ftnblk.hdr.used;
	        end;
	    end;
	end;
        end;			/**/
				/* accumuluate overflow space */
        oflo.used = oflo.used + ofloblk.hdr.used;

        block.hdr.count = ilin - 1;	/* adjust the block just split */
        block.hdr.used = blkusd;
        block.hdr.ftn.ct = blkftnct;
        block.hdr.ftn.usd = blkftnusd;
        block.line_area.cur = line_area_ptr;
        line_area.ndx = line_area_ndx;
      end;			/**/
				/* remove complete overflow blocks */
    do ii = 1 + bin (ilin > 1, 1) to oblkct;
      ofloblkptr, oflo.blkptr (ii) = col.blkptr (iblk + ii - 1);
      col.blkptr (iblk + ii - 1) = null ();
      oflo.used = oflo.used + ofloblk.hdr.used;

      if ofloblk.hdr.ftn.ct > 0
      then
        do;
	oflo.ftn.usd = oflo.ftn.usd + ofloblk.hdr.ftn.usd;
	do jj = 1 to ofloblk.hdr.ftn.ct;
	  oflo.ftn.ct = oflo.ftn.ct + 1;
	  oflo.ftn.blkndx (oflo.ftn.ct) = ofloblk.hdr.ftn.blkndx (jj);
	end;
        end;
    end;				/**/
				/* adjust rest of column data */
    col.hdr.blkct = col.hdr.blkct - oblkct + bin (ilin > 1, 1);
    col.hdr.used = colusd;
    col.hdr.depth = coldepth;
    maxcoldepth = max (maxcoldepth, col.hdr.depth);
    pagusd = max (pagusd, col.hdr.used);
    col.hdr.ftn = colftn;
    pgc_select = page.hdr.pgc_select;	/* save for next page */

    if bug_sw
    then call ioa_ ("^-(push_oflo: col=^d b^d d^f u^f(^f)^[ ftn=^d ^f^;^2s^]"
	    || " push=b^d u^f^[ ftn=^d ^f^;^2s^]^[ dfr=^d ^f^])", icol,
	    col.hdr.blkct, show (col.hdr.depth, 12000),
	    show (col.hdr.used, 12000), show (coldisc (icol), 12000),
	    (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	    show (col.hdr.ftn.usd, 12000), oflo.ct, show (oflo.used, 12000),
	    (oflo.ftn.ct > 0), oflo.ftn.ct, show (oflo.ftn.usd, 12000),
	    dfrftn.ct > 0, dfrftn.ct, show (dfrftn.usd, 12000));

  end push_oflo;
%page;
end_block:
	  end block_begin;
        end BLKLOOP;

column_exit:			/* hang orphan notes on page header */
      if icol = 0 & shared.ftnblk_data_ptr ^= null & orph_ftn
      then
        do;
	line_area_ptr = col0.blkptr (1) -> block.line_area.cur;
	txtlinptr = line_area.linptr (line_area.ndx);

	do i = 1 to ftnblk_data.highndx;
	  if ftnblk_data.blkptr (i) ^= null
	  then if ftnblk_data.blkptr (i) -> text.hdr.orphan
	       then
	         do;
		 orphftnct = orphftnct + 1;
		 if orphftnusd = 0
		 then orphftnusd = ftnhdr.hdr.used + 12000;
		 orphftnusd =
		      orphftnusd + 12000
		      + ftnblk_data.blkptr (i) -> text.hdr.used;
				/* change them to unreffed */
		 ftnblk_data.blkptr (i) -> text.hdr.unref = "1"b;
		 ftnblk_data.blkptr (i) -> text.hdr.orphan = "0"b;
		 ftnblk_data.blkptr (i) -> text.hdr.colno = -1;
		 orph_ftn = "1"b;
		 txtlin.ftn.ct = txtlin.ftn.ct + 1;
		 txtlin.ftn.blkndx (txtlin.ftn.ct) = 1;
	         end;
	end;
        end;

      if break_type <= page_break	/* if a text area break */
      then
        do;
	col.hdr.used = colusd;	/* record interesting stuff */
	col.hdr.depth = coldepth;
	col.hdr.ftn = colftn;
/****	col.hdr.balblk = iblk + 1;*/
        end;

      if icol = 1
      then mincolusd = colusd;
      else if icol > 1
      then mincolusd = min (mincolusd, colusd);

      if icol = 0
      then pagusd = max (pagusd, col.hdr.used);
      else pagusd = max (pagusd, col.hdr.used + col0.hdr.used);

      if bug_sw
      then call ioa_ ("^7x(col=^d b^d d^f u^f(^f)/^f(^f)^[ ftn=^d/^f^;^2s^]"
	      || " h^f)", icol, col.hdr.blkct, show (coldepth, 12000),
	      show (colusd, 12000), show (coldisc (icol), 12000),
	      show (colnet, 12000), show (col.depth_adj, 12000),
	      (colftn.ct > 0), colftn.ct, show (colftn.usd, 12000),
	      show (col.hdr.pspc, 12000));
				/* if balancing is wanted, recompute */
				/* page space used based on current */
				/* break points */
      if bal_sw & force_bal & page.parms.cols.count > 1
	 & icol = page.parms.cols.count
      then
        do;			/* accumulate total column space */
	locolptr = page.column_ptr (1);
	tmpnet = locol.hdr.used + locol.hdr.ftn.usd;
	mincolusd, maxcolusd =
	     locol.hdr.used + locol.hdr.ftn.usd + locol.depth_adj
	     - coldisc (1);

	do j = 2 to icol;
	  locolptr = page.column_ptr (j);
	  tmpnet = tmpnet + locol.hdr.used + locol.hdr.ftn.usd;
	  mincolusd =
	       min (mincolusd,
	       locol.hdr.used + locol.hdr.ftn.usd + locol.depth_adj
	       - coldisc (j));
	  maxcolusd =
	       max (maxcolusd,
	       locol.hdr.used + locol.hdr.ftn.usd + locol.depth_adj
	       - coldisc (j));
	end;

	pagenet = page.hdr.net - col0.hdr.used;
	tmpnet =
	     min (pagenet,
	     12000
	     *
	     floor (divide (tmpnet, page.parms.cols.count * 12000, 31, 10)));
				/* check balancing */
	unbal = maxcolusd - mincolusd;

	if unbal > 12000 & unbal ^= last_unbal & tmpnet > widow
	then
	  do;
	    last_unbal = unbal;

	    if bug_sw
	    then call ioa_ ("   (Unbalance of ^f at column ^d rebal=^f)",
		    show (unbal, 12000), icol, show (tmpnet, 12000));

	    rebalnet = tmpnet;
	    rebal_sw = "1"b;
	    goto COL_LOOP;
	  end;
        end;			/**/
    end coloop;

page_exit:
    if break_type = page_break	/* for a page break */
         | pagoflo			/* or page still overflows */
         | force_this_page		/* or page is to be forced */
				/* or we still need a page */
         | (break_type = need_break & need_page)
    then
      do;				/* flush any leftovers */
        if pagusd + col0.hdr.ftn.usd > 0
        then call flush_page;
        if shared.end_output
        then goto return_;		/**/
				/* reset flags */
        force_this_page, pagoflo, need_page = "0"b;

        if oflo.ct > 0 | dfrftn.ct > 0	/* any remaining overflow? */
        then
	do;
	  if page.parms.cols.count = 0
	  then call pull_oflo (0, 0);
	  else call pull_oflo ((page.parms.cols.count), 1);

	  if (bal_sw | page.hdr.used > 0 | shared.purge_ftns)
	       & break_type ^= need_break
	  then goto COL_LOOP;
	end;

        else
	do;
	  if page.parms.cols.count = 0
	  then page.hdr.col_index, page.hdr.col_count = 0;
	  else page.col_index, page.hdr.col_count = 1;
	  shared.colptr = page.column_ptr (page.hdr.col_index);
	end;

        if page.hdr.used > page.hdr.net
        then
	do;
	  pagoflo = "1"b;
	  goto COL_LOOP;
	end;
      end;

    maxcoldepth, maxcolusd = 0;
    do i = 1 to page.parms.cols.count;
      maxcoldepth = max (maxcoldepth, page.column_ptr (i) -> col.hdr.depth);
      maxcolusd = max (maxcolusd, page.column_ptr (i) -> col.hdr.used);
    end;

    page.hdr.depth = max (maxcoldepth, col0.hdr.depth);
    page.hdr.used, pagusd = col0.hdr.used + maxcolusd;

/* set new balance data */
    if break_type = column_break & (force_bal | bal_sw)
         | break_type = page_break
    then
      do;
        col0.hdr.balftn = col0.hdr.ftn;
        page.hdr.baldepth = page.hdr.depth;
        page.hdr.balusd = page.hdr.used;

        do page.hdr.col_index = 0 to page.parms.cols.count;
	shared.colptr = page.column_ptr (page.hdr.col_index);
	col.hdr.depth = page.hdr.depth;

	if page.hdr.col_index = 0	/* for column 0 */
	then
	  do;
	    col.hdr.net = page.hdr.net - maxcolusd - col.ftrusd;
	    col.hdr.balusd = col.hdr.used;
	  end;

	else
	  do;			/* for column > 0 */
	    col.hdr.net =
	         page.hdr.net - col0.hdr.used - col0.hdr.ftn.usd
	         - col.ftrusd;
	    col.hdr.used, col.hdr.balusd = maxcolusd;
	  end;			/**/
				/* next balance point */
	col.hdr.balftn = col.hdr.ftn;
	col.hdr.balblk = col.hdr.blkct + 1;
	col.hdr.baldepth = page.hdr.baldepth;

	if bug_sw
	then call ioa_ ("^-(col=^d b^d u^f/^f(^f) h^f"
		|| "^[ ftn=^d ^f^;^2s^] bal=^d d=^f)", page.hdr.col_index,
		col.hdr.blkct, show (col.hdr.used, 12000),
		show (col.hdr.net, 12000), show (col.depth_adj, 12000),
		show (col.hdr.pspc, 12000), (col.hdr.ftn.ct > 0),
		col.hdr.ftn.ct, show (col.hdr.ftn.usd, 12000),
		col.hdr.balblk, show (col.hdr.baldepth, 12000));
        end;

        if page.parms.cols.count > 0 & ^force_bal
        then page.hdr.col_index = 1;
        else page.hdr.col_index = 0;
        shared.colptr = page.column_ptr (page.hdr.col_index);

        if bug_sw
        then call ioa_ ("^-(pag=^8ad^f u^f/^f h^f^[ OFLO^])", page.hdr.pageno,
	        show (page.hdr.depth, 12000), show (pagusd, 12000),
	        show (page.hdr.net, 12000), show (page.hdr.hdspc, 12000),
	        pagoflo);
      end;

    if pagusd > page.hdr.net		/* does it still overflow? */
         & icol = page.parms.cols.count
    then
      do;				/* reset for balancing */
        do i = 0 to page.hdr.col_count;
	locolptr = page.column_ptr (i);
	locol.hdr.balblk = 1;
	locol.hdr.balusd, locol.hdr.balftn.usd, locol.hdr.balftn.ct = 0;
	locol.hdr.depth = head_used + locol.depth_adj;
        end;

        page.hdr.balusd = 0;
        page.hdr.depth = head_used;
        col0.hdr.balblk = 1;
        pagoflo = "1"b;		/* set overflow flag */
        goto COL_LOOP;
      end;

/*    if shared.table_mode		/* reset table depths */
/*    then
/*      do;
/*        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
/*        tblfmt.maxdepth = 0;
/*
/*        do i = 0 to tblfmt.ncols;
/*	tblfmt.colptr (i) -> tblcol.depth = 0;
/*        end;
/*      end;*/

return_:
    shared.colptr = page.column_ptr (page.hdr.col_index);
/****    if break_type = need_break
/****    then
/****      do;
/****        col.hdr.used = 0;
/****        do i = 1 + bin (icol = 0) to col.hdr.blkct - 1;
/****	col.hdr.used = col.hdr.used + col.blkptr (i) -> block.hdr.used;
/****        end;
/****      end;*/

    if bug_sw
    then
      do;
        call ioa_$nnl (
	   "^5x(make_page: ^[END)^;^a ^[front^;back^]^[ MOD ^a^;^s^]"
	   || " bal=d^f u^f)^]", shared.end_output, page.hdr.pageno,
	   page.hdr.frontpage, page.hdr.modified, page.hdr.pgc_select,
	   show (page.hdr.baldepth, 12000), show (page.hdr.balusd, 12000));

        call ioa_ ("^/^-(col=^d b^d bal=^d u^f/^f(^f)"
	   || "^[ ftn=^d ^f^;^2s^] h^f pag=^a c^d u^f/^f h^f^[ OFLO^])",
	   page.hdr.col_index, col.hdr.blkct, col.hdr.balblk,
	   show (col.hdr.used, 12000), show (col.hdr.net, 12000),
	   show (col.depth_adj, 12000), (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), show (col.hdr.pspc, 12000),
	   page.hdr.pageno, page.parms.cols.count,
	   show (page.hdr.used, 12000), show (page.hdr.net, 12000),
	   show (page.hdr.hdspc, 12000), pagoflo);
      end;

    return;
%page;
cleanup:
  entry;

    call clean_oflo;
    return;

clean_oflo:
  proc;

    do j = 1 to oflo.ct;
      k = oflo.ftn.blkndx (j);
      if k ^= 0
      then if ftnblk_data.blkptr (k) ^= null
	 then call comp_util_$relblk (-1, ftnblk_data.blkptr (k));
    end;

    if shared.ftnblk_data_ptr ^= null
    then
      do i = ftnblk_data.highndx to 1 by -1
	 while (ftnblk_data.blkptr (i) = null);



      end;

    unspec (oflo) = "0"b;
    oflo.blkptr = null;

  end clean_oflo;
%page;
flush_page:
  proc;

    dcl (ii, jj)	   fixed bin;	/* working index */
    dcl locblkptr	   ptr;
    dcl save_tmode	   bit (1);	/* to save table mode */

    if page.hdr.col_count > 0
    then page.hdr.depth = max (maxcoldepth, col0.hdr.depth);
    else page.hdr.depth, col0.hdr.depth = coldepth;
    page.hdr.used = pagusd;

    if bug_sw
    then call ioa_ ("^5xflush_page: (pag=^a d^f u^f/^f^[ M^])",
	    page.hdr.pageno, show (page.hdr.depth, 12000),
	    show (page.hdr.used, 12000), show (page.hdr.net, 12000),
	    page.hdr.modified);

    do ii = 0 to page.hdr.col_count;
      page.hdr.col_index = ii;
      locolptr, shared.colptr = page.column_ptr (ii);

      if ii = 0			/* trim leading WS */
      then blkno = 2;
      else blkno = locol.hdr.balblk;
      locblkptr = locol.blkptr (blkno);

      if locblkptr ^= null ()
      then if locblkptr -> block.hdr.white & ^locblkptr -> block.hdr.no_trim
	      & blkno = locol.hdr.balblk & locol.hdr.used = 0
	 then
	   do;
	     if bug_sw
	     then
	       do;
	         call ioa_ ("   (Discarding ^f leading WS in col ^d)",
		    show (locblkptr -> block.hdr.used, 12000), ii);
	       end;

	     locol.hdr.depth = locol.hdr.depth - locblkptr -> block.hdr.used;
	     locol.hdr.used = locol.hdr.used - locblkptr -> block.hdr.used;
/****	     locol.hdr.pspc = locol.hdr.pspc - locblkptr -> block.hdr.used;*/

	     call comp_util_$relblk (ii, locol.blkptr (blkno));
	     do jj = blkno + 1 to locol.hdr.blkct + 1;
	       locol.blkptr (jj - 1) = locol.blkptr (jj);
	     end;
	   end;

      if coldisc (ii) > 0		/* trim trailing WS */
	 & ii + locol.hdr.blkct > 1	/* but avoid page header */
      then
        do;
	locblkptr = locol.blkptr (locol.hdr.blkct);
	done = "0"b;

	do line_area_ptr = locblkptr -> block.line_area.cur
	     repeat (line_area.prev) while (line_area_ptr ^= null & ^done);
	  do jj = line_area.ndx to 1 by -1 while (^done);

	    if line_area.linptr (jj) -> txtlin.white
	         & ^line_area.linptr (jj) -> txtlin.no_trim
	    then locblkptr -> block.hdr.count =
		    locblkptr -> block.hdr.count - 1;
	    else
	      do;
	        done = "1"b;
	        line_area.ndx = jj;
	      end;
	  end;
	  locblkptr -> block.line_area.cur = line_area_ptr;
	end;

	if bug_sw
	then call ioa_ ("^8x(Trimming ^f trailing WS in col ^d)",
		show (coldisc (ii), 12000), ii);

	locblkptr -> block.hdr.used =
	     locblkptr -> block.hdr.used - coldisc (ii);
	if locol.hdr.used > locol.hdr.balusd
	then locol.hdr.used = locol.hdr.used - coldisc (ii);
	if ii = 0
	then
	  do;
	    page.hdr.used = page.hdr.used - coldisc (0);
	    page.hdr.depth = page.hdr.depth - coldisc (0);
	  end;
        end;			/**/
				/* insert footnotes */
      if (locol.hdr.ftn.ct > 0 | (ii = 0 & orph_ftn))
	 & (^ftn_held
	 | ftn_held & (ctl.default | col0.blkptr (1) -> text.hdr.ftn.ct > 0))
      then
        do;
	save_tmode = shared.table_mode;
	shared.table_mode = "0"b;
	col.hdr.depth = coldepth;
	call comp_insert_ctls_ (ift_ctl_index);
	shared.table_mode = save_tmode;
        end;

      if locol.ftrptr ^= null ()	/* is there a column footer? */
      then if locol.ftrusd ^= 0
	 then
	   do;
	     if locol.used
		< locol.hdr.net - locol.depth_adj
		- locol.ftrptr -> hfcblk.hdr.used
	     then locol.hdr.depth =
		     locol.hdr.depth + locol.hdr.net - locol.used
		     - locol.ftrptr -> hfcblk.hdr.used;

	     call comp_util_$getblk (ii, shared.blkptr, "cf",
		addr (locol.ftrptr -> hfcblk.parms), "0"b);
	     call comp_title_block_ (locol.ftrptr);
/****	     call comp_break_ (footer_break, 0);*/

	     do line_area_ptr = text.line_area.first
		repeat (line_area.next) while (line_area_ptr ^= null);
	       do ilin = 1 to line_area.ndx;
	         txtlinptr = line_area.linptr (ilin);
	         txtlin.depth = locol.hdr.depth;
	         locol.hdr.depth = locol.hdr.depth + txtlin.linespace;
	       end;
	     end;
	   end;
    end;

    maxcolusd = 0;
    do ii = 1 to page.hdr.col_count;
      locolptr = page.column_ptr (ii);
      maxcolusd = max (maxcolusd, locol.hdr.used);
    end;

    page.hdr.used = col0.hdr.used + maxcolusd;

    if bug_sw
    then call ioa_ ("^-(pag=^a d^f u^f/^f^[ M^])", page.hdr.pageno,
	    show (page.hdr.depth, 12000), show (page.hdr.used, 12000),
	    show (page.hdr.net, 12000), page.hdr.modified);

    save_tmode = shared.table_mode;	/* suspend table mode */
    shared.table_mode = "0"b;
    call comp_eject_page_;		/* eject without the overflow */
    shared.table_mode = save_tmode;	/* restore */

    if shared.end_output
    then
      do;				/**/
				/* any overflow, pictures, */
				/* or deferred footnotes? */
        if oflo.ct > 0 | shared.picture.count > 0 | dfrftn.ct > 0
        then
	do;
	  do shared.picture.count = shared.picture.count to 1 by -1;
	    call comp_util_$relblk (-1,
	         shared.picture.blk (shared.picture.count).ptr);
	  end;			/**/
				/* now, overflow blocks */
	  do oflo.ct = oflo.ct to 1 by -1;
	    call comp_util_$relblk (-1, oflo.blkptr (oflo.ct));
	  end;			/**/
				/* finally, deferred footnotes */
	  if shared.ftnblk_data_ptr ^= null
	  then
	    do ftnblk_data.highndx = ftnblk_data.highndx to 1 by -1
	         while (ftnblk_data.blkptr (ftnblk_data.highndx) = null);

	    end;
	end;
        goto flush_return;
      end;

    revert cleanup, comp_abort;
    need_page = "0"b;		/* reset local need flag */
    blk_split (*) = "0"b;		/* and the split flags */
    pagusd = 0;
    page.hdr.col_count = 0;		/**/
				/* any overflow, pictures, */
				/* or deferred footnotes? */
    if oflo.ct > 0 | shared.picture.count > 0
         | dfrftn.ct > 0 & ^shared.end_output
    then
      do;				/* head the new page */
        call comp_head_page_ (head_used);

        if page.parms.cols.count > 0	/* set balance depth */
        then
	do i = 1 to page.parms.cols.count;
	  page.column_ptr (i) -> col.hdr.baldepth = head_used;
	end;

        if shared.picture.count > 0	/* do pictures first */
        then call comp_util_$pictures (null);

        page.hdr.used = col.hdr.used;
        page.hdr.depth = col.hdr.depth;

        if shared.ftn_reset = "paged"	/* if paged footnotes */
        then shared.ftnrefct = 1;	/* reset the counter */
      end;

flush_return:
    if bug_sw
    then call ioa_ ("^-(flush_page^[ END^])", shared.end_output);
    return;

  end flush_page;
%page;
/* take all footnotes in the block */
take_block_notes:
  proc;

/* LOCAL STORAGE */

    dcl jj	   fixed bin;	/* working index */

    if bug_sw
    then call ioa_ ("^-^xtake_block_notes: (blk=^d/^f/^f col=^d/^f/^f)",
	    blkftnct, show (blkftnusd, 12000),
	    show (blkusd + blkftnusd, 12000), colftn.ct,
	    show (colftn.usd, 12000), show (colusd + colftn.usd, 12000));

    note_oflo = "0"b;		/* clear loop control */

    if ^ftn_held			/* note are not being held */
         | ftn_held &		/* or inserting held notes */
         (ctl.default | shared.purge_ftns)
    then
      do jj = 1 to block.hdr.ftn.ct while (^note_oflo);
        ftndx = block.hdr.ftn.blkndx (jj);

        if ftndx > 0
        then
	do;
	  ftnblkptr = ftnblk_data.blkptr (ftndx);

	  if ftnblkptr ^= null
	  then call take_a_note;
	end;
      end;

    if jj < block.hdr.ftn.ct
    then
      do jj = jj to block.hdr.ftn.ct;
        dfrftn.ct = dfrftn.ct + 1;
        dfrftn.blkndx (dfrftn.ct) = block.hdr.ftn.blkndx (jj);
        ftnblkptr = ftnblk_data.blkptr (block.hdr.ftn.blkndx (jj));
        dfrftn.usd = dfrftn.usd + ftnblk.hdr.used + 12000;
      end;

    if bug_sw
    then call ioa_ ("^-^x(take_block_notes: blk=^d/^f/^f "
	    || "col=^d/^f/^f^[ dfr=^d ^f^])", blkftnct,
	    show (blkftnusd, 12000), show (blkusd + blkftnusd, 12000),
	    colftn.ct, show (colftn.usd, 12000),
	    show (colusd + colftn.usd, 12000), (dfrftn.ct > 0), dfrftn.ct,
	    show (dfrftn.usd, 12000));

  end take_block_notes;
%page;
/* take all footnotes from line that fit */
take_line_notes:
  proc (jlin);

/* PARAMETERS */

    dcl jlin	   fixed bin;	/* (IN)  line index */

    linftnct, ftndx = 0;
    note_oflo = "0"b;

    if bug_sw
    then call ioa_ ("^- take_line_notes: (blk=^d/^f/^f col=^d/^f/^f)",
	    blkftnct, show (blkftnusd, 12000),
	    show (blkusd + blkftnusd, 12000), colftn.ct,
	    show (colftn.usd, 12000), show (colusd + colftn.usd, 12000));
				/* take all notes referenced in */
				/* this line that fit on the page */
    do linftnct = 1 to txtlin.ftn.ct while (^note_oflo);
      if ftn_held & ctl.default	/* held notes */
      then
        do;
	ftndx = ftndx + 1;
	ftnblkptr = ftnblk_data.blkptr (ftndx);
	if ftnblkptr ^= null
	then call take_a_note;
	if note_oflo
	then goto line_note_oflo;
        end;			/**/
				/* real notes */
      else if txtlin.ftn.blkndx (linftnct) > 0
      then
        do;
	ftndx = txtlin.ftn.blkndx (linftnct);
	ftnblkptr = ftnblk_data.blkptr (ftndx);
	call take_a_note;
	if note_oflo
	then goto line_note_oflo;
        end;

      else blkftnct = blkftnct + 1;	/* not real, .frf ref */
    end;
    goto line_note_return;

line_note_oflo:
    if linftnct = 1			/* does 1st one overflow? */
    then return;			/**/
				/* move rest to the deferred list */
    if linftnct < txtlin.ftn.ct
    then
      do k = linftnct to txtlin.ftn.ct;
        ftnblkptr = ftnblk_data.blkptr (txtlin.ftn.blkndx (k));
        ftnblk.hdr.unref = "1"b;	/* mark the note */
				/* record the reference */
        dfrftn.usd = dfrftn.usd + ftnblk.hdr.used + 12000;
        dfrftn.ct = dfrftn.ct + 1;
        dfrftn.blkndx (dfrftn.ct) = txtlin.ftn.blkndx (k);
      end;

    txtlin.ftn.ct = linftnct - 1;	/* correct line ftn count */

line_note_return:
    if bug_sw
    then call ioa_ ("^- (take_line_notes: blk=^d/^f/^f "
	    || "col=^d/^f/^f^[ dfr=^d ^f^])", blkftnct,
	    show (blkftnusd, 12000), show (blkusd + blkftnusd, 12000),
	    colftn.ct, show (colftn.usd, 12000),
	    show (colusd + colftn.usd, 12000), (dfrftn.ct > 0), dfrftn.ct,
	    show (dfrftn.usd, 12000));

/****    rebalnet = col.hdr.net - rebalnet;
/****    if rebalnet >= colnet
/****    then rebal_sw = "1"b;*/

  end take_line_notes;
%page;
take_a_note:
  proc;

/* LOCAL STORAGE */

    dcl jj	   fixed bin;
    dcl flin	   fixed bin;	/* footnote line index */
    dcl flin_moved	   fixed bin;
    dcl flin_oflo	   fixed bin;
    dcl flin_start	   fixed bin;
    dcl flin_top	   fixed bin;
    dcl ftnlinptr	   ptr;		/* a ftn line */
    dcl 1 ftnlin	   aligned like text_entry based (ftnlinptr);
    dcl ftnwidow	   fixed bin (31);	/* footnote widow space */
    dcl line_area_move ptr;
    dcl line_area_start
		   ptr;
    dcl locolusd	   fixed bin (31);
    dcl newftnptr	   ptr;		/* split ftn pointer */
    dcl widftnusd	   fixed bin (31);	/* size of deferred widow notes */

    dcl (max, min)	   builtin;	/**/
				/* widow size for this note */
    ftnwidow = shared.widow_foot * ftnblk.parms.linespace;
    locolusd =
         bin (block.blktype ^= "ph")
         * max (colusd, bin (block.hdr.used > widow) * widow);

    if bug_sw & dt_sw
    then call ioa_$nnl ("^-^3xftn=^d(^d)^[ unref^]^[ page^] siz=^d/^f", ftndx,
	    ftnblk.blkndx, ftnblk.hdr.unref, (ftnblk.hdr.refer ^= icol),
	    ftnblk.hdr.count, show (ftnblk.hdr.used, 12000));

    if block.blktype = "ph"		/* orphan notes */
    then
      do;
        if colftn.usd +		/* if it doesnt fit */
	   ftnblk.hdr.used > colnet
        then
	do;
	  if colftn.usd +		/* if no room for widow & separator */
	       min (ftnblk.hdr.used, ftnwidow) > colnet
	  then
	    do;
	      if bug_sw & dt_sw
	      then call ioa_ (" OFLO");
	      note_oflo, pagoflo = "1"b;
	      return;
	    end;

	  else goto split_note;
	end;

        goto take_orphan;
      end;

    else if ftnblk.hdr.refer = icol	/* does note go in this column? */
         | ftnblk.hdr.unref		/* or its an unreffed note */
    then
      do;				/**/
				/* if no room for widow & separator */
        if locolusd + max (colftn.usd, ftnhdr.hdr.used + 12000)
	   + min (ftnblk.hdr.used, ftnwidow) + 12000 > colnet
        then
	do;
	  if bug_sw & dt_sw
	  then call ioa_ (" OFLO");
	  note_oflo, pagoflo = "1"b;
	  return;
	end;			/**/
				/* if it fits, snarf it up */
        else if locolusd + max (colftn.usd, ftnhdr.hdr.used + 12000)
	   + ftnblk.hdr.used + 12000 <= colnet
        then
	do;			/* count this note for the block */
take_orphan:
	  if colftn.ct = 0		/* note header */
	  then colftn.usd = ftnhdr.hdr.used + 12000;

	  blkftnct = blkftnct + 1;
	  if ftnblk.hdr.refer = icol
	  then blkftnusd = blkftnusd + 12000 + ftnblk.hdr.used;

	  colftn.ct = colftn.ct + 1;
	  colftn.usd = colftn.usd + ftnblk.hdr.used + 12000;
	  colftn.blkndx (colftn.ct) = ftndx;

	  if bug_sw & dt_sw
	  then call ioa_ (" blk=^d/^f/^f col=^d/^f/^f", blkftnct,
		  show (blkftnusd, 12000),
		  show (blkusd + blkftnusd, 12000), colftn.ct,
		  show (colftn.usd, 12000),
		  show (colusd + colftn.usd, 12000));
	end;

        else			/* note doesnt fit */
	do;
split_note:			/* widow the overflowing */
				/* note if its big enough */
	  if ftnblk.hdr.count >= 2 * shared.widow_foot
	  then
	    do;
	      if bug_sw & dt_sw
	      then call ioa_ ("");

	      flin_top = 0;
	      widftnusd = 12000;	/* note separator */
				/* take the top widow */
	      do line_area_ptr = ftnblk.line_area.first
		 repeat (line_area.next) while (line_area_ptr ^= null);
	        do flin = 1 to line_area.ndx
		   while (widftnusd
		   + line_area.linptr (flin) -> ftnlin.linespace
		   <= ftnwidow + 12000);
		ftnlinptr = line_area.linptr (flin);
		widftnusd = widftnusd + ftnlin.linespace;
		line_area_start = line_area_ptr;
		flin_start = flin;
		flin_top = flin_top + 1;

		if bug_sw & dt_sw
		then call ioa_ ("^-^5xlin=^dW/^d ld^f u^f blk=^d/^f/^f"
			|| " col=^d/^f/^f", flin, ftnlin.info.lineno,
			show (ftnlin.linespace, 12000),
			show (widftnusd, 12000), blkftnct + 1,
			show (blkftnusd + widftnusd, 12000),
			show (blkusd + blkftnusd + widftnusd, 12000),
			colftn.ct + 1,
			show (colftn.usd + widftnusd, 12000),
			show (colusd + colftn.usd + widftnusd, 12000));
	        end;
	      end;		/**/
				/* if widow fits, take free lines */
	      if ^ftn_held | (ftn_held & ctl.default)
	      then if locolusd + colftn.usd + widftnusd <= colnet
		 then
		   do;
		     flin_start = flin_start + 1;
		     do line_area_ptr = line_area_start
			repeat (line_area.next)
			while (line_area_ptr ^= null);
		       do flin = flin_start to line_area.ndx
			  while (locolusd + colftn.usd + widftnusd
			  + line_area.linptr (flin) -> txtlin.linespace
			  <= colnet);
		         ftnlinptr = line_area.linptr (flin);
		         widftnusd = widftnusd + ftnlin.linespace;
		         line_area_start = line_area_ptr;
		         flin_oflo = flin;
		         flin_top = flin_top + 1;

		         if bug_sw & dt_sw
		         then call ioa_ (
			         "^-^5xlin=^d/^d ld^f u^f blk=^d/^f/^f"
			         || " col=^d/^f/^f", flin,
			         ftnlin.info.lineno,
			         show (ftnlin.linespace, 12000),
			         show (widftnusd, 12000), blkftnct + 1,
			         show (blkftnusd + widftnusd, 12000),
			         show (blkusd + blkftnusd + widftnusd,
			         12000), colftn.ct + 1,
			         show (colftn.usd + widftnusd, 12000),
			         show (colusd + colftn.usd + widftnusd,
			         12000));
		       end;
		       flin_start = 1;
		     end;
		   end;		/**/
				/* split the note? */
	      line_area_ptr = line_area_start;
	      if flin_oflo <= line_area.ndx
	      then
	        do;		/* record space used */
		blkftnct = blkftnct + 1;
		blkftnusd = blkftnusd + widftnusd;
		colftn.ct = colftn.ct + 1;
		colftn.usd = colftn.usd + widftnusd;
		colftn.blkndx (colftn.ct) = ftndx;

		if bug_sw
		then call ioa_ (
			"^5xnote_oflo: (col=^d ftn=^d/^d lin=^d/^d)",
			icol, colftn.ct, col.hdr.ftn.ct, flin_top,
			ftnblk.hdr.count - flin_top);
				/* create a new footnote */
		ftnblk_data.highndx = ftnblk_data.highndx + 1;
		call comp_util_$getblk (-1,
		     ftnblk_data.blkptr (ftnblk_data.highndx), "df",
		     addr (ftnblk.parms), "0"b);
		newftnptr = ftnblk_data.blkptr (ftnblk_data.highndx);

		line_area_move, ftnblk.line_area.cur = line_area_ptr;
		flin_start = flin_oflo + 1;
		flin_moved = 0;
		do line_area_ptr = line_area_ptr
		     repeat (line_area.next) while (line_area_ptr ^= null);
		  do jj = flin_start to line_area.ndx;
		    call comp_util_$add_text (newftnptr, "0"b, "0"b, "0"b,
		         "0"b, line_area.linptr (jj));
		    flin_moved = flin_moved + 1;
		  end;
		  flin_start = 1;
		end;

		line_area_move -> line_area.ndx = flin_oflo;
		ftnblk.hdr.count = ftnblk.hdr.count - flin_moved;
		ftnblk.hdr.used = widftnusd;
		newftnptr -> ftnblk.hdr.refer = ftnblk.hdr.refer;
		newftnptr -> ftnblk.hdr.unref = ftnblk.hdr.unref;
		newftnptr -> ftnblk.hdr.oflo_ftn,
		     newftnptr -> ftnblk.hdr.dfrftn = "1"b;
		dfrftn.ct = 1;	/* make this one 1st in deferred list */
		dfrftn.usd = newftnptr -> ftnblk.hdr.used + 12000;
		dfrftn.blkndx (1) = ftnblk_data.highndx;
	        end;
	      note_oflo, pagoflo = "1"b;
	    end;

	  else
	    do;
	      if bug_sw & dt_sw
	      then call ioa_ (" OFLO");
	      note_oflo, pagoflo = "1"b;
	    end;

	  if bug_sw
	  then call ioa_ ("^-(note_oflo: col=^d note=^d/^f oflo=^d ^d/^f)",
		  icol, ftnblk.hdr.count, show (ftnblk.hdr.used, 12000),
		  dfrftn.ct, flin_moved, show (dfrftn.usd, 12000));
	end;
      end;

    else
      do;
        blkftnct = blkftnct + 1;
        if bug_sw & dt_sw
        then call ioa_ ("");
      end;

  end take_a_note;
%page;
pull_oflo:
  proc (oldc, newc);

/* PARAMETERS */

    dcl oldc	   fixed bin;	/* overflowing column */
    dcl newc	   fixed bin;	/* receiving column */

/* LOCAL STORAGE */
/****				   footnote reference */
    dcl footref_array  (3) char (48) var static;
    dcl footrefstr	   char (256) var static;
    dcl ftnref	   bit (1);	/* inverse of footnote unref flag */
    dcl (ii, jj, jjj, kk)
		   fixed bin;	/* working index */
    dcl pull_blk	   fixed bin;	/* block at which pulling starts */
    dcl splthdr	   fixed bin;	/* 1= there is a split header */

    dcl comp_error_table_$program_error
		   fixed bin (35) ext static;
				/* set local column pointer */
    newcol_ptr = page.column_ptr (newc);

    if bug_sw
    then call ioa_ ("^5xpull_oflo: (oldc=^d b^d u^f^[ ftn=^d ^f^;^2s^]"
	    || "^[ dfr=^d/^f^;^2s^]"
	    || " newc=^d b^d d^f u^f^[ ftn=^d/^f^;^2s^])", oldc, oflo.ct,
	    show (oflo.used, 12000), (oflo.ftn.ct > 0), oflo.ftn.ct,
	    show (oflo.ftn.usd, 12000), (dfrftn.ct > 0), dfrftn.ct,
	    show (max (dfrftn.usd, 0), 12000), newc, newcol.hdr.blkct,
	    show (newcol.hdr.baldepth, 12000), show (newcol.hdr.used, 12000),
	    (newcol.hdr.ftn.ct > 0), newcol.hdr.ftn.ct,
	    show (newcol.hdr.ftn.usd, 12000));

/* anything there? */
    if oflo.ct > 0
    then
      do;				/* recover change level */
        page.hdr.pgc_select = pgc_select;
        pull_blk = newcol.hdr.balblk;	/**/
				/* need a column header? */
        if pull_blk = 1 & newcol.blkptr (1) ^= null
        then if newcol.blkptr (1) -> text.blktype = "ch"
	   then pull_blk = 2;	/* keep it first */

        splthdr = 0;		/* is there a split header? */
        if shared.spcl_blkptr ^= null	/* is first oflo block a split? */
        then if shared.spcl_blkptr -> hfcblk.hdr.count > 0
	        & oflo.blkptr (1) -> block.blktype = "ot"
	   then
	     do;			/* does new column already have one? */
	       if newcol.blkptr (pull_blk) ^= null
	       then if newcol.blkptr (pull_blk) -> block.blktype = "sh"
		  then pull_blk = pull_blk + 1;
		  else splthdr = 1; /* no, need one */
	       else splthdr = 1;	/* no, need one */
	     end;			/**/
				/* pulling to next column? */
				/* push down new column */
        if newc ^= oldc & newcol.hdr.blkct > 0
        then
	do;
	  do ii = newcol.hdr.blkct to pull_blk by -1;
	    newcol.blkptr (ii + splthdr + oflo.ct) = newcol.blkptr (ii);
	  end;
/**** PUSH newcol.hdr.ftn.blkndx */
	end;

        else if newcol.hdrptr ^= null	/* is there a column header? */
	   & newc > 0
        then
	do;
	  page.hdr.col_index = newc;
	  shared.colptr = newcol_ptr;
	  call comp_util_$getblk (newc, shared.blkptr, "tx",
	       addr (newcol.hdrptr -> hfcblk.parms), "0"b);
	  text.hdr.tblblk = "0"b;
	  call comp_title_block_ (newcol.hdrptr);
	  call comp_break_ (block_break, 0);
	  pull_blk = 2;
	  page.hdr.col_index = oldc;
	  shared.colptr = page.column_ptr (oldc);
	end;			/**/
				/* need a split header? */
        if shared.spcl_blkptr ^= null
        then if shared.spcl_blkptr -> hfcblk.hdr.count > 0 & splthdr = 1
	   then
	     do;
	       page.hdr.col_index = newc;
	       shared.colptr = newcol_ptr;
	       call comp_util_$getblk (-1, shared.blkptr, "sh",
		  addr (oflo.blkptr (1) -> text.parms), "0"b);
	       newcol.blkptr (1) = shared.blkptr;
	       call comp_title_block_ (shared.spcl_blkptr);
	       call comp_break_ (block_break, 0);
	       newcol.hdr.blkct = newcol.hdr.blkct + 1;
	       pull_blk = pull_blk + 1;
	     end;			/**/

        if oflo.ftn.ct > 0		/* any notes pushed? */
        then
	do;			/* push down notes already there */
	  do ii = newcol.hdr.ftn.ct to 1 by -1;
	    newcol.hdr.ftn.blkndx (ii + oflo.ftn.ct) =
	         newcol.hdr.ftn.blkndx (ii);
	  end;			/**/
				/* add pushed notes */
	  do ii = 1 to oflo.ftn.ct;
	    newcol.hdr.ftn.blkndx (ii) = oflo.ftn.blkndx (ii);
	  end;
	end;			/**/
				/* adjust page/column data */
        newcol.hdr.blkct = newcol.hdr.blkct + oflo.ct;
        newcol.hdr.ftn.ct = newcol.hdr.ftn.ct + oflo.ftn.ct;

        newcol.hdr.used = newcol.hdr.used + oflo.used;
        newcol.hdr.depth = newcol.hdr.depth + oflo.used;
        newcol.hdr.ftn.usd = newcol.hdr.ftn.usd + oflo.ftn.usd;

        page.hdr.used = max (pagusd, newcol.hdr.used);
        page.hdr.depth = newcol.hdr.depth;
        page.hdr.col_count = max (page.hdr.col_count, newc);

        do ii = 1 to oflo.ct;		/* insert the overflow */
	ofloblkptr = oflo.blkptr (ii);

	if newc ^= oldc
	then newcol.blkptr (ii + pull_blk - 1) = ofloblkptr;
	else newcol.blkptr (newcol.hdr.blkct - oflo.ct + ii) = ofloblkptr;
	ofloblk.blktype = "tx";	/* make it a text block */
	ofloblk.hdr.colno = newc;	/* in this column */

	if ii = oflo.ct		/* fix up column head space */
	then
	  do;
	    if ofloblk.hdr.white	/* white block adds to head space */
	    then newcol.hdr.pspc = newcol.hdr.pspc + ofloblk.hdr.used;

	    else
	      do;
	        newcol.hdr.pspc = 0;
	        do line_area_ptr = ofloblk.line_area.cur
		   repeat (line_area.prev) while (line_area_ptr ^= null);
		do jj = line_area.ndx to 1 by -1
		     while (line_area.linptr (jj) -> txtlin.ptr -> txtstr
		     = "");
		  newcol.hdr.pspc =
		       newcol.hdr.pspc
		       + line_area.linptr (jj) -> txtlin.linespace;
		end;
	        end;
	      end;
	  end;			/**/
				/* any footnotes? if paged and */
				/* pulling onto the next page */
				/* change references */
	if ofloblk.hdr.ftn.ct > 0 & shared.ftn_reset = "paged" & newc <= oldc
	then
	  do line_area_ptr = ofloblk.line_area.first
	       repeat (line_area.next) while (line_area_ptr ^= null);
	    do jj = 1 to line_area.ndx;
	      txtlinptr = line_area.linptr (jj);

	      if txtlin.ftn.ct > 0
	      then
	        do kk = 1 to txtlin.ftn.ct;
		ftndx = txtlin.ftn.blkndx (kk);

		if ftndx > 0	/* if not a .frf reference */
		then ftnref =
			^ftnblk_data.blkptr (ftndx) -> text.hdr.unref;
		else ftnref = "1"b; /* it is a .frf reference */

		if ftnref		/* if there a reference */
		     & ftndx > 0	/* and its not a .frf reference */
				/* and not deferred by widowing */
		     & ^ftnblk_data.blkptr (ftndx) -> text.hdr.dfrftn
		then
		  do;		/* build ref string */
		    footref_array (2) =
		         ltrim (char (txtlin.ftn.refno (kk)));
		    call comp_dvt
		         .footproc (footref_array, addr (comp_dvt));
		    footrefstr =
		         shared.footref_fcs || footref_array (1)
		         || footref_array (2);
				/* change ref in footnote */
		    ftnblkptr = ftnblk_data.blkptr (ftndx);
		    txtlinptr =
		         ftnblk.line_area.first -> line_area.linptr (1);
		    txtstrptr = txtlin.ptr;
		    jjj = index (txtstr, footrefstr);
		    jjj = jjj + 8 + length (footref_array (1));
		    substr (txtstr, jjj, 1) =
		         ltrim (char (shared.ftnrefct));
				/* change ref in text */
		    txtlinptr = line_area.linptr (jj);
		    txtstrptr = txtlin.ptr;
		    jjj = index (txtstr, footrefstr);
				/* if not found */
		    if jjj = 0
		    then call comp_report_ (4,
			    comp_error_table_$program_error,
			    "Cant find footnote reference in a line "
			    || "expected to contain one.",
			    addr (txtlin.info), txtstr);

		    else
		      do;		/* change it */
		        jjj = jjj + 8 + length (footref_array (1));
		        substr (txtstr, jjj, 1) =
			   ltrim (char (shared.ftnrefct));
		        txtlin.ftn.refno (kk) = shared.ftnrefct;
		      end;
		  end;		/**/
				/* count notes */
		shared.ftnrefct = shared.ftnrefct + 1;
	        end;
	    end;
	  end;
        end;

        if break_type = need_break	/* make overflow active for need */
        then shared.blkptr = ofloblkptr;
      end;

    if dfrftn.ct > 0		/* any deferred footnotes */
    then				/* become orphans */
      do;
        if col0.hdr.ftn.ct = 0
        then col0.hdr.ftn.usd = ftnhdr.hdr.used + 12000;

        col0.hdr.ftn.ct = col0.hdr.ftn.ct + dfrftn.ct;
        col0.hdr.ftn.usd = col0.hdr.ftn.usd + dfrftn.usd;
				/* tack them onto the page header */
        col0.blkptr (1) -> block.hdr.ftn.ct =
	   col0.blkptr (1) -> block.hdr.ftn.ct + dfrftn.ct;
        col0.blkptr (1) -> block.hdr.ftn.usd =
	   col0.blkptr (1) -> block.hdr.ftn.usd + dfrftn.usd;
        line_area_ptr = col0.blkptr (1) -> block.line_area.first;

        txtlinptr = line_area.linptr (1);
        txtlin.ftn.ct = txtlin.ftn.ct + dfrftn.ct;
        txtlin.ftn.used = txtlin.ftn.used + dfrftn.usd;
        txtlin.ftn.refno = 0;

        do ii = 1 to dfrftn.ct;	/* mark notes unreffed */
	ftnblkptr = ftnblk_data.blkptr (dfrftn.blkndx (ii));
	ftnblk.hdr.unref = "1"b;	/**/
				/* move the blkndx numbers */
	col0.hdr.ftn.blkndx (col0.hdr.ftn.ct - dfrftn.ct + ii) =
	     dfrftn.blkndx (ii);
	col0.blkptr (1)
	     -> block.hdr.ftn
	     .blkndx (col0.blkptr (1) -> block.hdr.ftn.ct - dfrftn.ct + ii) =
	     dfrftn.blkndx (ii);
	txtlin.ftn.blkndx (txtlin.ftn.ct - dfrftn.ct + ii) =
	     dfrftn.blkndx (ii);
        end;

        dfrftn.ct, dfrftn.usd, dfrftn.blkndx = 0;
      end;			/**/
				/* overflow recovered, clean up */
    oflo.ct, oflo.ftn.ct, oflo.ftn.usd = 0;
    oflo.ct, oflo.used, oflo.ftn.ct, oflo.ftn.usd = 0;

    if bug_sw
    then call ioa_ ("^-(pull_oflo: col=^d b^d d^f u^f^[ ftn=^d ^f^;^2s^])",
	    newc, newcol.hdr.blkct, show (newcol.hdr.baldepth, 12000),
	    show (newcol.hdr.used, 12000), (newcol.hdr.ftn.ct > 0),
	    newcol.hdr.ftn.ct, show (newcol.hdr.ftn.usd, 12000));

  end pull_oflo;

show:
  proc (value, scale) returns (fixed dec (11, 3));
    dcl value	   fixed bin (31);
    dcl scale	   fixed bin (31);
    return (dec (divide (value, scale, 31, 10), 11, 3));
  end show;

    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

    dcl db_sw	   bit (1) static init ("0"b);
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;

allf:
  entry;
    db_sw, dt_sw = "0"b;
    return;
%page;
/* DCLS THAT MUST BE NEAR INCLS DUE TO SYMBOL TABLE SIZE LIMIT */

    dcl locolptr	   ptr;		/* for local referencing */
    dcl 1 locol	   aligned like col based (locolptr);
    dcl 1 newcol	   aligned like col based (newcol_ptr);
				/* for local reffing */
    dcl newcol_ptr	   ptr;		/* pointer to receiving column */

%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_entries;
%include comp_fntstk;
%include comp_footnotes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include comp_dvt;
/* DISORDER DUE TO SYMBOL TABLE SIZE LIMIT */
%include comp_tree;
%include compstat;

  end comp_make_page_;




		    comp_measure_.pl1               04/23/85  1059.2rew 04/23/85  0910.3      259848



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

/* compose subroutine to measure string lengths in millipoints */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_measure_:
  proc (a_str, afnt_ptr, fill, art, quad, a_lmeas, meas1_ptr, meas2_ptr,
       info_ptr);

/* PARAMETERS */

    dcl a_str	   char (1020) var; /* string to be measured - IN */
    dcl afnt_ptr	   ptr;		/* font description - IN */
    dcl fill	   bit (1);	/* 0 = simple measuring - IN */
				/* 1 = measuring filled text */
    dcl art	   bit (1);	/* 1 = line may have art - IN */
    dcl quad	   bit (6);	/* line set control */
    dcl a_lmeas	   fixed bin (31);	/* measure of target line - IN */
				/* if a_lmeas is 0, then then entire */
				/* string is to be measured */
    dcl meas1_ptr	   ptr;		/* str that fits - IN */
    dcl meas2_ptr	   ptr;		/* overflow str - IN */
    dcl info_ptr	   ptr;		/* info structure for str - IN */

    dcl 1 afnt	   aligned like fntstk_entry based (afnt_ptr);
				/* string that fits */
    dcl 1 meas1	   aligned like text_entry.cur based (meas1_ptr);
				/* overflow string */
    dcl 1 meas2	   aligned like text_entry.cur based (meas2_ptr);

/* LOCAL STORAGE */

    dcl art_str_ptr	   ptr;		/* art symbol overlay */
    dcl art_str	   char (3) unal based (art_str_ptr);
				/* artwork strings */
    dcl 1 art_xcep	   static options (constant),
	2 str	   (50) char (6)
		   init ("/oo/", "/ss/", "/cc/", "/==/", "|--|", "|**|", "-~~-", "~**~",
		   "SvvS", "svvs", "s""""s", "S^^S", "s^^s", "S""""S", "HvvH", "hvvh",
		   "h""""h", "H^^H", "h^^h", "H""""H", "0^^0", "1^^1", "2^^2", "3^^3",
		   "4^^4", "5^^5", "6^^6", "7^^7", "8^^8", "9^^9", "0vv0", "1vv1", "2vv2",
		   "3vv3", "4vv5", "5vv5", "6vv6", "7vv7", "8vv8", "9vv9", "0^^0", "1^^1",
		   "2^^2", "3^^3", "4^^5", "5^^5", "6^^6", "7^^7", "8^^8", "9^^9"),
	2 code	   (50) char (1)
		   init ("o", "s", "c", "=", "`", " ", "f", " ",
		   (42) (1)"");
    dcl art_xcep_ndx   fixed bin;	/* index of art_str in xcep list */
    dcl avg1	   fixed bin (31);	/* accumulated average wordspace */
    dcl avgwsp	   fixed bin (31);	/* current average wordspace */
    dcl brkrw	   fixed bin (31);	/* width of word breaker */
    dcl chrct1	   fixed bin;
    dcl ctl_width	   fixed bin (31);	/* width of device ctl string */
    dcl debug_sw	   bit (1);	/* effective debug switch */
    dcl detail_sw	   bit (1);	/* effective detail debug switch */
    dcl ENwidth	   fixed bin (31);	/* width of EN */
    dcl gap_ahead	   fixed bin;
    dcl gap_found	   bit (1);
    dcl gaps1	   fixed bin;
    dcl hyphenated	   bit (1);
    dcl iscn	   fixed bin;	/* string scanning index */
    dcl (jj, k)	   fixed bin;	/* working index */
    dcl 1 lfnt	   aligned like fntstk_entry;
    dcl lmeas	   fixed bin (31);
    dcl max1	   fixed bin (31);	/* accumulated maximum wordspace */
    dcl maxwsp	   fixed bin (31);	/* current maximum wordspace */
    dcl min1	   fixed bin (31);	/* accumulated minimum wordspace */
    dcl minwsp	   fixed bin (31);	/* current minimum wordspace */
    dcl mptstrk	   fixed bin (31);	/* mpt -> strokes conversion */
    dcl oflo	   bit (1);	/* line overflow switch */
    dcl PSwidth	   fixed bin (31);	/* width of PS */
    dcl runits	   fixed bin;	/* rel_units in current font */
    dcl str	   char (1020) var; /* working string */
    dcl strlen	   fixed bin;
    dcl tchar	   char (1);	/* for debugging */
    dcl trnsw	   bit (1);	/* 1= translation is active */
    dcl true_size	   fixed bin (31);	/* true point size */
    dcl width1	   fixed bin (31);	/* string width accumulator */
    dcl word	   char (1020) var; /* measured word */
    dcl wordct	   fixed bin;	/* chars in word */
    dcl wrdstrt	   fixed bin;	/* start of word in string */
    dcl wordu	   fixed bin (31);	/* word size */
    dcl wrdbrkr	   char (1);

    dcl (addr, bin, dec, divide, index, length, ltrim, max, min, null, rank,
        reverse, round, rtrim, search, substr, unspec, verify)
		   builtin;

    strlen = length (a_str);		/* copy args */
    str = a_str;			/**/
				/* set debug switches */
    debug_sw = (shared.bug_mode & db_sw);
    detail_sw = (debug_sw & dt_sw);

    if debug_sw
    then call ioa_ ("measure: (^d/^d w^f g^d ^f^2(/^f^) m^f ^a ^f"
	    || "^[ F^; ^^F^]^[ A^; ^^A^])^/^5x""^a^vx""", meas1.chrct,
	    strlen, show (meas1.width, 12000), meas1.gaps,
	    show (meas1.width + meas1.min, 12000),
	    show (meas1.width + meas1.avg, 12000),
	    show (meas1.width + meas1.max, 12000), show (a_lmeas, 12000),
	    afnt.name, show (afnt.size, 1000), fill, art,
	    comp_util_$display (a_str, 0, "0"b),
	    strlen - length (rtrim (a_str)));

    lfnt, meas1.font = afnt;		/* starting font for string */
    fnttbl_ptr = fnttbldata.ptr (lfnt.devfnt);
    if fill
    then wrdbrkr = shared.wrd_brkr;
    else wrdbrkr = "";

    if siztbl.ct = 1		/* validate size */
    then true_size = siztbl.size (1);
    else true_size = afnt.size;

    runits = fnttbl.rel_units;	/* conversion values in current font */
    mptstrk = divide (true_size, runits, 31, 0);

    minwsp = fnttbl.min_wsp;		/* wordspace values */
    avgwsp = fnttbl.avg_wsp;
    maxwsp = fnttbl.max_wsp;		/**/
				/* other useful widths */
    ENwidth = fnttbl.units (rank (EN));
    PSwidth = fnttbl.units (rank (PS));

    wrdstrt, wordu, ctl_width, gap_ahead = 0;

    word = "";			/* initialize local values */
    unspec (meas2), gap_found, hyphenated, oflo = "0"b;
    meas2.font = afnt;
    trnsw = (length (shared.trans.in) > 0);

    lmeas = a_lmeas;
    if lmeas ^= 0
    then lmeas = divide (lmeas, mptstrk, 31, 0);
    width1 = meas1.width;

    chrct1 = meas1.chrct;
    gaps1 = meas1.gaps;
    if width1 ^= 0
    then width1 = divide (width1, mptstrk, 31, 0);
    min1 = meas1.min;
    if min1 ^= 0
    then min1 = divide (min1, mptstrk, 31, 0);
    avg1 = meas1.avg;
    if avg1 ^= 0
    then avg1 = divide (avg1, mptstrk, 31, 0);
    max1 = meas1.max;
    if max1 ^= 0
    then max1 = divide (max1, mptstrk, 31, 0);

scan_loop:			/* scan the given string */
    do iscn = chrct1 + 1 by 0 while (iscn <= strlen);

font_char:
      do;
        word = "";
        wordct, wordu = 0;
        wrdstrt = iscn;

        if iscn <= strlen
        then
font_char_loop:
	do iscn = iscn to strlen;	/* take all font chars */

(nostrg):
next_tchar:
	  tchar = substr (str, iscn, 1);
	  if tchar = DC1		/* device control string? */
	  then
ctl_char:
	    do;			/**/
	      if wordu > 0		/* any text pending? */
	      then
	        do;
		if detail_sw
		then call ioa_ ("^[^-^6x^]^4d,^2d ""^a"" ^f "
			|| "(g^d ^f = ^f/^f/^f)", ^gap_found, wrdstrt,
			wordct, comp_util_$display (word, 0, "0"b),
			show (wordu * mptstrk, 12000), gaps1,
			show ((width1 + wordu) * mptstrk, 12000),
			show ((width1 + wordu + min1) * mptstrk, 12000),
			show ((width1 + wordu + avg1) * mptstrk, 12000),
			show ((width1 + wordu + max1) * mptstrk, 12000));

/*		width1 = width1 + wordu;
/*		wordu = 0;*/
		gap_found = "0"b;
	        end;		/**/
				/* set control pointer */
	      DCxx_p = addr (substr (str, iscn, 1));
				/* nothing more for waits */
	      if dcfs.type = type_wait
	      then ;

	      if dcfs.type = type_font/* is it a font change? */
	      then
	        do;		/* really changing? */
		if lfnt.devfnt ^= dcfs.f
		then
		  do;
		    lfnt.devfnt = dcfs.f;
		    fnttbl_ptr = fnttbldata.ptr (lfnt.devfnt);
		    lfnt.name = fnttbl.name;
				/* new rel units? */
		    if runits ^= fnttbl.rel_units
		    then
		      do;
		        runits = fnttbl.rel_units;
		        mptstrk = divide (true_size, runits, 31, 0);
		        minwsp = divide (fnttbl.min_wsp, mptstrk, 31, 0);
		        avgwsp = divide (fnttbl.avg_wsp, mptstrk, 31, 0);
		        maxwsp = divide (fnttbl.max_wsp, mptstrk, 31, 0);
		        ENwidth = fnttbl.units (rank (EN));
		        PSwidth = fnttbl.units (rank (PS));
		      end;
		  end;		/**/
				/* changing size? */
		if lfnt.size ^= dcfs.p
		then
		  do;
		    lfnt.size = dcfs.p;
				/* revalidate size */
		    if siztbl.ct = 1
		    then true_size = siztbl.size (1);
		    else true_size = lfnt.size;
		  end;
	        end;

	      else
	        do;		/* must be shift or plot */
		if dcxx.Xctl = "01"b/* if an X value, account for it */
		then ctl_width = divide (dcshort_val.v1, mptstrk, 31, 0);
		else if dcxx.Xctl = "10"b
		then ctl_width = divide (dclong_val.v1, mptstrk, 31, 0);
		else ctl_width = 0; /* clear control width */
	        end;

	      if lmeas > 0		/* dont do more than we have to */
	      then if width1 + ctl_width > lmeas
		 then goto return_;

	      wordu = wordu + ctl_width;
	      wordct = wordct + dcxx.leng + 3;
	      word = word || substr (str, iscn, dcxx.leng + 3);

	      if detail_sw
	      then call ioa_ ("^[^-^6x^]^4d,^2d ""^a"" ^f "
		      || "(g^d ^f = ^f/^f/^f)", ^gap_found, wrdstrt,
		      wordct, comp_util_$display (word, 0, "0"b),
		      show (wordu * mptstrk, 12000), gaps1,
		      show ((width1 + wordu) * mptstrk, 12000),
		      show ((width1 + wordu + min1) * mptstrk, 12000),
		      show ((width1 + wordu + avg1) * mptstrk, 12000),
		      show ((width1 + wordu + max1) * mptstrk, 12000));

	      gap_found = "0"b;	/* skip over control string */
	      iscn = iscn + dcxx.leng + 3;

	      if iscn <= strlen
	      then goto next_tchar;
	      else goto EOL_check;
	    end ctl_char;

	  if art			/* check for line art symbols */
	  then
art_:
	    do;
	      art_str_ptr = addr (substr (str, iscn));

	      if iscn < strlen - 1	/* dont check EOL garbage */
	      then if substr (art_str, 2, 1) = BSP
		 then
		   do;
		     art_xcep_ndx = index (string (art_xcep.str), art_str);
				/* find it? */
		     if art_xcep_ndx > 0
		     then
		       do;
		         art_xcep_ndx =
			    divide (art_xcep_ndx + 5, 6, 17, 0);

		         wordu = wordu
			    + fnttbl
			    .units (rank (art_xcep.code (art_xcep_ndx)));
		         word = word || substr (str, iscn, 3);
		         wordct = wordct + 3;
				/* step over it */
		         iscn = iscn + 3;

		         if iscn > strlen
		         then
			 do;
			   if detail_sw
			   then call ioa_ ("^[^-^6x^]^4d,^2d ""^a"" ^f "
				   || "(g^d ^f = ^f/^f/^f)",
				   ^gap_found,
				   wrdstrt - bin (word = ""), wordct,
				   comp_util_$display (word, 0, "0"b),
				   show (wordu * mptstrk, 12000),
				   gaps1,
				   show ((width1 + wordu) * mptstrk,
				   12000),
				   show ((width1 + wordu + min1)
				   * mptstrk, 12000),
				   show ((width1 + wordu + avg1)
				   * mptstrk, 12000),
				   show ((width1 + wordu + max1)
				   * mptstrk, 12000));

			   width1 = width1 + wordu;
			   chrct1 = chrct1 + wordct + gap_ahead;
			   meas1.font = lfnt;
			   gap_found = "0"b;
			   gap_ahead, wordu = 0;

			   goto return_;
			 end;

		         else goto next_tchar;
		       end;
		   end;
	    end art_;

	  if trnsw
	  then
	    do;
	      k = index (shared.trans.in, tchar);
	      if k > 0
	      then tchar = substr (shared.trans.out, k, 1);
	    end;			/**/
				/* if a word break */
	  if tchar = " " | tchar = wrdbrkr & wrdbrkr ^= ""
	  then
	    do;
EOL_check:
	      if detail_sw
	      then call ioa_ ("^[^-^6x^]^4d,^2d ""^a"" ^f "
		      || "(g^d ^f = ^f/^f/^f)", ^gap_found,
		      wrdstrt - bin (word = ""), wordct,
		      comp_util_$display (word, 0, "0"b),
		      show (wordu * mptstrk, 12000), gaps1,
		      show ((width1 + wordu) * mptstrk, 12000),
		      show ((width1 + wordu + min1) * mptstrk, 12000),
		      show ((width1 + wordu + avg1) * mptstrk, 12000),
		      show ((width1 + wordu + max1) * mptstrk, 12000));
				/* if word does not overset */
				/* or no measure was given */
	      if width1 + wordu + avg1 <= lmeas | quad = just
/****		 & (width1 + wordu + avg1 > lmeas*/
		 & width1 + wordu + min1 <= lmeas | lmeas <= 0
	      then
	        do;		/* stay up to date */
		width1 = width1 + wordu;
		chrct1 = chrct1 + wordct + gap_ahead;
		meas1.font = lfnt;
		gap_found = "0"b;
		gap_ahead, wordu, wordct = 0;
	        end;

	      else		/* this word oversets */
	        do;
		if shared.hyph_mode & ^hyphenated
		     & (quad = just & width1 + max1 - maxwsp <= lmeas
		     | quad ^= just & width1 + avg1 - avgwsp <= lmeas)
		then if try_hyph ()
		     then
		       do;
		         hyphenated = "1"b;
		         iscn = wrdstrt;
		         goto font_char;
		       end;

		wrdbrkr = shared.wrd_brkr;

		if chrct1 > 0 & gap_ahead > 0
		then
		  do;
		    gaps1 = gaps1 - 1;
		    min1 = min1 - minwsp;
		    avg1 = avg1 - avgwsp;
		    max1 = max1 - maxwsp;
		  end;

		if detail_sw
		then call ioa_$nnl ("^5xOFLO");

		oflo = "1"b;
		goto return_;
	        end;

	      if iscn < strlen	/* if not EOL */
				/* or measuring all */
		 | (iscn = strlen & lmeas = 0)
	      then
word_break:
	        do;
		if tchar ^= " "	/* if a word breaker */
		then
breaker:
		  do;
		    word = word || tchar;
		    wordct = wordct + 1;
		    brkrw = fnttbl.units (rank (tchar));

		    if detail_sw
		    then call ioa_ ("^[^-^6x^]^4d,^2d ""^a"" ^f "
			    || "(g^d ^f = ^f/^f/^f)", ^gap_found,
			    wrdstrt - bin (word = ""), wordct,
			    comp_util_$display (word, 0, "0"b),
			    show ((wordu + brkrw) * mptstrk, 12000),
			    gaps1,
			    show ((width1 + brkrw) * mptstrk, 12000),
			    show ((width1 + brkrw + min1) * mptstrk,
			    12000),
			    show ((width1 + brkrw + avg1) * mptstrk,
			    12000),
			    show ((width1 + brkrw + max1) * mptstrk,
			    12000));

		    iscn = iscn + 1;/* and count the breaker */
				/* does it all still fit? */
		    if width1 + max (min1, 0) + brkrw <= lmeas
		    then
		      do;		/* update first return data */
		        width1 = width1 + brkrw;
		        chrct1 = iscn - 1;
		        meas1.font = lfnt;
		        gap_ahead = 0;
		        goto font_char;
		      end;

		    else		/* this is the overset "word" */
		      do;
		        if shared.hyph_mode & ^hyphenated & lmeas > 0
			   & (quad = just
			   & width1 + max1 - maxwsp <= lmeas
			   | quad ^= just
			   & width1 + avg1 - avgwsp <= lmeas)
		        then if try_hyph ()
			   then
			     do;
			       hyphenated = "1"b;
			       iscn = wrdstrt;
			       goto font_char;
			     end;

		        wrdbrkr = shared.wrd_brkr;
		        oflo = "1"b;
		        goto return_;
		      end;	/**/
				/* does it all still fit? */
		    if width1 + avg1 + avgwsp + wordu <= lmeas
		         | quad = just & width1 + wordu + min1 <= lmeas
		    then
		      do;		/* update first return data */
		        width1 = width1 + wordu;
		        chrct1 = iscn - 1;
		        meas1.font = lfnt;
		        goto font_char;
		      end;

		    else		/* this is the overset word */
		      do;
		        if shared.hyph_mode & ^hyphenated
			   & (quad = just
			   & width1 + max1 - maxwsp <= lmeas
			   | quad ^= just
			   & width1 + avg1 - avgwsp <= lmeas)
		        then if try_hyph ()
			   then
			     do;
			       hyphenated = "1"b;
			       iscn = wrdstrt;
			       goto font_char;
			     end;

		        wrdbrkr = shared.wrd_brkr;
		        oflo = "1"b;
		        goto return_;
		      end;
		  end breaker;

		else		/* its a wordspace */
wrdspc:
		  do;
		    if fill	/* preserve punctuation space */
		         & search (reverse (word), ".:!?") = 1
		         | search (reverse (word), """)") = 1
		         & search (reverse (word), ".!?") = 2
		    then if width1 + avg1 + PSwidth <= lmeas
			    | quad = just
			    & width1 + min1 + PSwidth <= lmeas
		         then
punct:
			 do;	/* add PS to the measured string */
(nostrg):
			   str = substr (str, 1, iscn - 1) || PS
			        || substr (str, iscn);
			   strlen = strlen + 1;
				/* take some width */
			   width1 = width1 + PSwidth;
			   chrct1 = chrct1 + 1;

			   if detail_sw
			   then call ioa_ ("^-^6x^4d, 1 ""^a"" ^f "
				   || "(g^d ^f = ^f/^f/^f)", iscn,
				   comp_util_$display ((PS), 0, "0"b),
				   show (PSwidth * mptstrk, 12000),
				   gaps1,
				   show (width1 * mptstrk, 12000),
				   show ((width1 + min1) * mptstrk,
				   12000),
				   show ((width1 + avg1) * mptstrk,
				   12000),
				   show ((width1 + max1) * mptstrk,
				   12000));
				/* step over it */
			   iscn = iscn + 1;
			 end punct;

(nostrg):
		    jj = verify (substr (str, iscn), " ") - 1;
		    if jj < 0
		    then jj = strlen - iscn + 1;

		    if fill
		    then
		      do;
		        gap_found = "1"b;
		        gap_ahead = 1;

		        if jj > 1	/* cast out all multiple blanks */
		        then
			do;
(nostrg, nostrz):
			  str = substr (str, 1, iscn - 1) || " "
			       || ltrim (substr (str, iscn));
			  strlen = length (str);
			end;	/**/
				/* this isnt EOL */
		        if iscn <= strlen
		        then
			do;
			  gaps1 = gaps1 + 1;
			  min1 = min1 + minwsp;
			  avg1 = avg1 + avgwsp;
			  max1 = max1 + maxwsp;
				/* end of undent field? */
			  if width1 >= lmeas & lmeas > 0 & ^fill
			  then goto return_;
			end;

		        if detail_sw & gaps1 > 0
		        then call ioa_$nnl ("^4d gap ^2d ^f", iscn, gaps1,
			        show (avgwsp * mptstrk, 12000));

		        iscn = iscn + 1;
		      end;

		    else if art
		    then
		      do;
		        str = substr (str, 1, iscn - 1) || copy (EN, jj)
			   || ltrim (substr (str, iscn));

		        width1 = width1 + jj * ENwidth;
		        chrct1 = chrct1 + jj;

		        if detail_sw
		        then call ioa_$nnl ("^4d ^2d EN^[s^;^x^] ^f", iscn,
			        jj, (jj > 1), show (jj * ENwidth, 12000))
			        ;
		        iscn = iscn + jj;
		        gap_found = "1"b;
		      end;

		    else
		      do;
		        width1 = width1 + jj * ENwidth;
		        chrct1 = chrct1 + jj;

		        if detail_sw
		        then call ioa_$nnl ("^4d ^2d SP^[s^;^x^] ^f", iscn,
			        jj, (jj > 1),
			        show (jj * ENwidth * mptstrk, 12000));
		        iscn = iscn + jj;
		        gap_found = "1"b;
		      end;

		    goto font_char;
		  end wrdspc;
	        end word_break;
	      else goto return_;
	    end;

	  else
	    do;
	      if tchar = PS		/* punctuation space? */
	      then
	        do;		/* does the word fit? */
		if width1 + wordu + avg1 <= lmeas
		     | quad = just & width1 + wordu + min1 <= lmeas
		then
		  do;		/* if PS does not overset */
				/* take the units for PS */
		    if width1 + avg1 + PSwidth < lmeas
		         | quad = just & width1 + PSwidth + min1 <= lmeas
		    then
		      do;
		        wordu = wordu + fnttbl.units (rank (tchar));
		        word = word || PS;
		        wordct = wordct + 1;
		      end;

		    else
		      do;		/* throw the PS away */
		        substr (str, iscn) = substr (str, iscn + 1);
		        strlen = strlen - 1;
				/* discard 1 char for loop control */
		        iscn = iscn - 1;
		      end;
		  end;

		else if fill	/* this is the overset word */
		then
		  do;		/* set return data */
		    if shared.hyph_mode & ^hyphenated
		         & (quad = just & width1 + max1 - maxwsp <= lmeas
		         | quad ^= just & width1 + avg1 - avgwsp <= lmeas)
		    then if try_hyph ()
		         then
			 do;
			   hyphenated = "1"b;
			   iscn = wrdstrt;
			   goto font_char;
			 end;

		    wrdbrkr = shared.wrd_brkr;
		    oflo = "1"b;
		    goto return_;
		  end;
	        end;		/**/
				/* NOT punctuation space */
	      else if tchar ^= DC1
	      then
	        do;
		wordu = wordu + fnttbl.units (rank (tchar));
		word = word || tchar;
		wordct = wordct + 1;
	        end;
	    end;
	end font_char_loop;
      end font_char;
end_scan_loop:
    end scan_loop;			/**/
				/* fell out, must be EOL */
    if wordu > 0			/* any leftovers? */
    then goto EOL_check;

return_:
    if chrct1 > 0			/* strip trailing PS */
    then if substr (str, chrct1, 1) = PS
         then
	 do;
	   if chrct1 = strlen
	   then str = substr (str, 1, chrct1 - 1);
	   else
(nostrg):
	     str = substr (str, 1, chrct1 - 1) || substr (str, chrct1 + 1);
	   width1 = width1 - PSwidth;
	   chrct1 = chrct1 - 1;
	   meas2.chrct = meas2.chrct - 1;
	   strlen = strlen - 1;
	 end;

    meas1.chrct = min (chrct1, strlen);
    meas1.gaps = max (gaps1, 0);
    meas1.avg = max (avg1 * mptstrk, 0);
    meas1.min = max (min1 * mptstrk, 0);
    meas1.max = max (max1 * mptstrk, 0);
    meas1.width = max (width1 * mptstrk, 0);

    if ^oflo
    then meas2.font = meas1.font;

    else
      do;
        meas2.font = lfnt;
        meas2.chrct = min (iscn - bin (iscn < strlen), strlen);
        meas2.gaps = gaps1 + gap_ahead;
        meas2.width = (width1 + wordu) * mptstrk;
        meas2.min = (min1 + minwsp) * mptstrk;
        meas2.avg = (avg1 + avgwsp) * mptstrk;
        meas2.max = (max1 + maxwsp) * mptstrk;
      end;

    a_str = str;			/* store back possibly modified str */

    if debug_sw
    then
      do;
        if detail_sw & (^fill & chrct1 = strlen)
	   | (fill & chrct1 = length (rtrim (a_str)))
        then call ioa_$nnl ("^5xEOL");

        iscn = chrct1 - length (rtrim (substr (str, 1, chrct1)));
        call ioa_ ("^/^5x(measure: [1=^d/^d^2( ^f^)^2(/^f^)] "
	   || "[2=^d/^d^2( ^f^)^2(/^f^)] ^a ^f)^[^/^-""^a^vx""^]",
	   meas1.chrct, meas1.gaps, show (meas1.width, 12000),
	   show (meas1.width + meas1.min, 12000),
	   show (meas1.width + meas1.avg, 12000),
	   show (meas1.width + meas1.max, 12000), meas2.chrct, meas2.gaps,
	   show (meas2.width, 12000), show (meas2.width + meas2.min, 12000),
	   show (meas2.width + meas2.avg, 12000),
	   show (meas2.width + meas2.max, 12000), meas2.font.name,
	   show (meas2.font.size, 1000), (meas1.chrct > 0),
	   comp_util_$display (substr (str, 1, meas1.chrct), 0, "0"b), iscn);

        if meas2.chrct > 0
        then
	do;
	  call ioa_ ("^-""^a""",
	       comp_util_$display (
	       substr (str, meas1.chrct + 1, meas2.chrct - meas1.chrct), 0,
	       "0"b));
	end;
      end;

    return;
%page;
hyph_wrd:
  proc (hword, hspace, hpoint, ercd);

    dcl hword	   char (*);
    dcl hspace	   fixed bin;
    dcl hpoint	   fixed bin;
    dcl ercd	   fixed bin (35);

    dcl (i, j)	   fixed bin;
    dcl space	   fixed bin;

    dcl hyphenate_word_
		   entry (char (*), fixed bin, fixed bin, fixed bin (35));

    ercd = 0;			/* preset output values */
    hpoint = 0;			/**/
				/* check impossible cases */
    if hspace < 2 | hspace > length (hword)
    then return;
    else space = hspace;

    if shared.hwrd_data_ptr ^= null	/* is hword in the hwrd list */
    then
      do;
        do j = 1 to hwrd_data.count while (hwrd_data.word (j) ^= hword);
        end;

        if j <= hwrd_data.count	/* yes */
        then
	do;			/* try hyphenation first */
	  i = index (reverse (substr (hwrd_data.hpts (j), 1, space - 1)),
	       "1"b);
	  if i ^= 0
	  then i = space - i;
	  if i < length (hword)
	  then if substr (hword, i + 1, 1) = "-"
	       then i = i + 1;

	  if i = 0		/* no hyphenation point */
	  then
	    do;
	      i = index (reverse (hwrd_data.brkpts (j)), "1"b);
	    end;

	  hpoint = i;
	end;

        else call hyphenate_word_ (hword, space, hpoint, ercd);

      end;

    else call hyphenate_word_ (hword, space, hpoint, ercd);

  end hyph_wrd;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);
    dcl retval	   fixed dec (11, 3);

    retval = round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3);
    return (retval);
  end show;
%page;
try_hyph:
  proc returns (bit (1));

    dcl ercd	   fixed bin (35);
    dcl hp_space	   fixed bin (31);	/* width of hyph punct */
    dcl hpoint	   fixed bin;
    dcl hscndx	   fixed bin;	/* word scan index */
    dcl hspace	   fixed bin;	/* line chars left for hyphenation */
    dcl hword	   char (strlen - chrct1 + 2) var;
    dcl hwrdl	   fixed bin static;/* length of trial hyphenation word */
    dcl i		   fixed bin;

    hscndx = wrdstrt;
    hwrdl = iscn - wrdstrt;

trim_trailing:			/* any trailing punctuation? */
    if search (reverse (substr (str, hscndx, hwrdl)), ".,;:!?""" || wrdbrkr)
         = 1
    then
      do;
        hwrdl = hwrdl - 1;
        goto trim_trailing;
      end;			/**/
				/* line space left (in chars) */
    if quad = just
    then hspace =
	    divide ((lmeas - width1 - min1) * mptstrk, shared.EN_width, 17,
	    0);
    else hspace =
	    divide ((lmeas - width1 - avg1) * mptstrk, shared.EN_width, 17,
	    0);

    hp_space = 0;			/* check leading punctuation */
trim_leading:
    if index ("/([{""" || PAD || wrdbrkr, substr (str, hscndx, 1)) ^= 0
    then
      do;
        hp_space = hp_space +		/* calculate its width */
	   fnttbl.units (rank (substr (str, hscndx, 1)));
        hscndx = hscndx + 1;		/* step over it */
        hspace = hspace - 1;		/* 1 fewer hyph chars */
        hwrdl = hwrdl - 1;
        goto trim_leading;
      end;

    i = -1			/* anything embedded? */
         +
         verify (reverse (substr (str, hscndx, hwrdl)),
         "/.;:!?,()[]{}""" || PAD || PS);
    if i > 0
    then
      do;
        hwrdl = hwrdl - i;		/* to force hyphenation */
        hspace = min (hspace, hwrdl - 1);
      end;

    if hspace > shared.hyph_size	/* enough space? */
    then
      do;
        hpoint = 0;			/* clear hyph point index */
        hword = substr (str, hscndx, hwrdl);

        if shared.bug_mode
        then call ioa_$nnl ("^5x(hyph: ^d ^d ""^a""", hspace, hwrdl, hword);

        call hyph_wrd (substr (str, hscndx, hwrdl), hspace, hpoint, ercd);
        if ercd ^= 0
        then goto hyph_err;

        if hpoint = 0		/* try simple plurals */
        then
	do;
	  if index (substr (hword, hwrdl), "s") = 1
	  then
	    do;
	      call hyph_wrd (substr (hword, 1, hwrdl - 1), hspace, hpoint,
		 ercd);
	      if ercd ^= 0
	      then goto hyph_err;
	    end;

	  if hpoint = 0
	  then
	    do;
	      if index (substr (hword, hwrdl), "es") = 1
	      then
	        do;
		call hyph_wrd (substr (hword, 2, hwrdl - 2), hspace,
		     hpoint, ercd);
		if ercd ^= 0
		then goto hyph_err;
	        end;

	      if hpoint = 0
	      then
	        do;
		if index (substr (hword, hwrdl), "ies") = 1
		then
		  do;
		    call hyph_wrd (substr (hword, 3, hwrdl - 3) || "y",
		         hspace, hpoint, ercd);
		    if ercd ^= 0
		    then
hyph_err:
		      call comp_report_$ctlstr (2, ercd, text.input.info,
			 str,
			 "Error returned by hyphenate_word_ subroutine.")
			 ;
		    return ("0"b);
		  end;
	        end;
	    end;
	end;

        if shared.bug_mode
        then call ioa_ (" @ ^d)", hpoint);

hyph_it:
        if hpoint >= shared.hyph_size
        then
	do;
	  hpoint = hscndx + hpoint - 1;

	  if substr (str, hpoint, 1) ^= "-"
	  then
	    do;			/* insert the "-" */
	      str = substr (str, 1, hpoint) || "-"
		 || substr (str, hpoint + 1);
	      strlen = strlen + length ("-");
	      hpoint = hpoint + length ("-");
				/* adjust modified text */
	      if strlen <= text.input.mod_start
	      then text.input.mod_start =
		      text.input.mod_start + length ("-");
	      else if strlen <= text.input.mod_start + text.input.mod_len - 1
	      then text.input.mod_len = text.input.mod_len + length ("-");
	    end;

	  wrdbrkr = "-";		/* set hyphen as word breaker */
	  gap_found = "0"b;
	  return ("1"b);
	end;

        if hpoint = 0
        then
	do;			/**/
				/* unbreakable word? */
	  if width1 = 0 & wordu > divide (text.parms.measure, mptstrk, 31, 0)
	  then
	    do;
	      call comp_report_$ctlstr (2, 0, info_ptr, ctl_line,
		 "Text too long for output line.");

/*	      meas1 = meas2;
/*	      strlen = meas2.chrct;
/*	      text.input.quad = quadl;*/

/*	      call put_line;
/*	      text.input.quad = just;*/

/*	      goto fill_loop;*/
	      return ("0"b);
	    end;
	end;

      end;

    return ("0"b);

  end try_hyph;
%page;
alln:
  entry;
    db_sw, dt_sw = "1"b;
    return;
allf:
  entry;
    db_sw, dt_sw = "0"b;
    return;
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    dt_sw = "0"b;
    return;
    dcl db_sw	   bit (1) static init ("0"b);

dtn:
  entry;
    db_sw = "1"b;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;
    dcl dt_sw	   bit (1) static init ("0"b);
%page;
%include comp_DCdata;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_hwrd_data;
%include comp_metacodes;
%include comp_shared;
%include comp_text;
%include comp_tree;
%include compstat;

  end comp_measure_;




		    comp_read_.pl1                  04/23/85  1059.2rew 04/23/85  0910.3      156564



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

/* compose subroutine to read stuff from input files */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_read_:
  proc;
    return;			/* no entry here */

/* GLOBAL PARAMETERS
				   a string - (IN) or (OUT) depending
				   on entry used */
    dcl buffer	   char (*) var parameter;
    dcl a_info_ptr	   ptr parameter;	/* (IN) -> to error info structure */
				/* (OUT) next char index of string */
    dcl next	   fixed bin (21) parameter;
				/* (IN) char index of string */
    dcl start	   fixed bin (21) parameter;

/* LOCAL STORAGE */

    dcl ascii_width	   fixed bin;	/* width of ctl line in chars */
    dcl blank_count	   fixed bin;	/* count of blanks inserted */
    dcl bufct	   fixed bin;	/* chars returned in buffer */
    dcl char_index_ptr ptr;		/* for width measurement */
    dcl char_index	   (1020) fixed bin (9) unsigned unaligned
		   based (char_index_ptr);
    dcl ercd	   fixed bin (35);	/* error code */
				/* the MSF control block */
    dcl 1 fcb	   based (fcbp) aligned,
	2 version	   fixed bin,	/* version of this structure  */
	2 type	   fixed bin,	/* form of msf */
	2 max_components		/* maximum number of components */
		   fixed bin,
	2 max_len	   fixed bin (19),	/* max words in each component. */
	2 pad	   (1) fixed bin,
	2 pathnames,		/* dirname, ename, and path */
	  3 dname	   char (168),
	  3 ename	   char (32),
	  3 path	   char (200),
	2 initiated_components,	/* info about initiated components */
	  3 number   fixed bin,	/* how many are initiated */
	  3 highest_value		/* highest of those inited */
		   fixed bin,
	  3 listp	   ptr,		/* ptr to head of inited segs list */
				/* save ring bracks */
	2 rbs	   (3) fixed bin (3),
				/* if comps are multiclass segs */
	2 upgrade_sw bit (1) aligned,
	2 access_class		/* AIM class if upgrade_sw ON */
		   bit (72) aligned;

    dcl fcbp	   ptr;		/* local copy of fcb pointer */
				/* input file data */
    dcl 1 file	   like insert.file based (filptr);
    dcl i		   fixed bin;	/* working index */
    dcl info_ptr	   ptr;
    dcl 1 info	   like text_entry.info based (info_ptr);
    dcl input_file	   char (const.max_seg_chars) based (file.pointer);
    dcl linct	   fixed bin;	/* chars in input line */

    dcl (addr, after, before, bin, char, copy, divide, index, length, ltrim,
        min, null, rtrim, search, substr, verify)
		   builtin;

/* read an input line */

line:
  entry (filptr, buffer, skip);

/* PARAMETERS */

    dcl filptr	   ptr;		/* input file data pointer */
    dcl skip	   bit (1);	/* 1 = skipping lines, dont print */

/* LOCAL STORAGE */

    dcl (ii, j, k)	   fixed bin;	/* working index */
    dcl input_bitcount fixed bin (35);	/* bit count of MSF components */
    dcl junk	   char (80);	/* junk chars for pause option */
    dcl rest	   fixed bin (21);	/* rest of input file */

    dcl (dec, mod)	   builtin;
    dcl comp_abort	   condition;

    dcl comp_error_table_$program_error
		   fixed bin (35) ext static;
    dcl error_table_$zero_length_seg
		   fixed bin (35) ext static;

    dcl iox_$get_line  entry (ptr, ptr, fixed bin (35), fixed bin (35),
		   fixed bin (35));
    dcl msf_manager_$get_ptr
		   entry (ptr, fixed bin, bit (1), ptr, fixed bin (35),
		   fixed bin (35));

    blank_count = 0;
    fcbp = file.fcb_ptr;		/* copy fcb pointer */
    info_ptr = addr (file.info);	/* set info ptr */
    buffer = "";			/* erase the buffer */

get_line:				/* if not at EOF */
    rest = file.charcount - file.posn + 1;
    if file.posn <= file.charcount	/* set input line length */
    then linct = index (substr (input_file, file.posn, rest), NL) - 1;
    else linct = -1;		/* set as a no NL signal */

    if linct < 0			/* if no NL */
    then
      do;				/* if not EOF */
        if file.posn < file.charcount
        then
	do;			/* take rest of file */
	  if length (buffer) + rest > maxlength (buffer)
	  then
	    do;
length_error:
	      ercd = comp_error_table_$program_error;
	      call comp_report_$ctlstr (4, ercd, info_ptr, ctl_line,
		 "Input line is longer than max allowable length of "
		 || "^d characters.", maxlength (buffer));
	      signal comp_abort;
	      return;
	    end;

	  buffer = buffer || substr (input_file, file.posn, rest);
	end;

next_component:			/* if this is an MSF and there are */
        if fcb.type = 2		/* more components */
	   & file.comp_no < fcb.max_components - 1
        then			/* get next component */
	do;			/* step component number */
	  file.comp_no = file.comp_no + 1;

	  call msf_manager_$get_ptr (fcbp, file.comp_no, "0"b, file.pointer,
	       input_bitcount, ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_$ctlstr (4, ercd, info_ptr, ctl_line,
		 "Accessing component ^d of input file ^a", file.comp_no,
		 file.path);
	      signal comp_abort;
	      return;
	    end;

	  if input_bitcount = 0	/* if the component is null */
	  then
	    do;
	      call comp_report_$ctlstr (2, error_table_$zero_length_seg,
		 info_ptr, ctl_line,
		 "Component ^d of input file ^a is empty.", file.comp_no,
		 file.path);
	      goto next_component;
	    end;

	  else
	    do;
	      file.posn = 1;
	      file.charcount = divide (input_bitcount, 9, 35, 0);
	      goto get_line;
	    end;
	end;

        if file.posn > file.charcount
        then
	do;
	  if shared.bug_mode
	  then call ioa_ ("***^/read$line: (end_input: ^a)",
		  shared.input_filename);
	  shared.end_input = "1"b;
	  return;
	end;			/**/
				/* so we dont read any more */
        file.posn = file.charcount + 1;
      end;

    else
      do;
        call_box_ptr = call_stack (call_stack.index).ptr;
				/* step input line count */
        info.lineno = info.lineno + 1;
        if call_stack.index = 0
        then info.lineno0 = info.lineno;

/* ignore comment lines */
        if substr (input_file, file.posn, 2) = ".*" & ^shared.literal_mode
        then
	do;
	  buffer = "";
	  file.posn = file.posn + linct + 1;
	  goto get_line;
	end;

        bufct = linct;		/* set chars to return */

        if ^shared.literal_mode	/* check for multiple controls */
	   | shared.literal_mode & shared.lit_count = 0
        then
	do;
	  i = index (substr (input_file, file.posn, linct), ";.");
	  if i = 1		/* and ; isnt escaped */
	       | i > 1 & substr (input_file, file.posn + i - 2, 3) ^= "*;."
	  then if substr (input_file, file.posn + i - 1, 3) = ";.*"
	       then bufct = i - 1;
	       else linct, bufct = i - 1;
	end;

        if file.posn > 1		/* fool line counter */
        then if substr (input_file, file.posn - 1, 1) ^= NL
	   then info.lineno = info.lineno - 1;
        if call_stack.index = 0
        then info.lineno0 = info.lineno;/**/
				/* take the line */
        if length (buffer) + bufct > maxlength (buffer)
        then goto length_error;

        buffer = buffer || substr (input_file, file.posn, bufct);

        if index (			/* check for continuation */
	   ltrim (
	   substr (input_file, file.posn + linct + 1,
	   min (file.charcount - file.posn - linct, 50)), "	 "),
	   ".+") = 1 & ^shared.literal_mode
        then
	do;
	  if length (buffer) + bufct > maxlength (buffer)
	  then goto length_error;

	  file.posn =		/* step over the partial line */
	       file.posn + linct
	       + index (substr (input_file, file.posn + linct + 1), ".+")
	       + 2;		/**/
				/* count continuation lines */
	  info.lineno = info.lineno + 1;
	  if call_stack.index = 0
	  then info.lineno0 = info.lineno;

	  goto get_line;		/* and go back for more */
	end;
      end;

    file.posn = file.posn + linct + 1;

    info.fileno = call_box.info.fileno; /* assure file reference is correct */

    if call_stack.index = 0		/* if this is a command line file */
    then
      do;
        if option.galley_opt		/* check line range in galley mode */
        then if info.lineno > option.line_2 & shared.pass_counter <= 1
	   then
	     do;
	       if shared.bug_mode
	       then call ioa_ ("***^/read$line: (end_input: ^a)",
		       shared.input_filename);
				/* in case there are footnotes */
	       call_box.lineno0, info.lineno, info.lineno0 = option.line_2;
	       shared.end_input = "1"b;
	       return;
	     end;
      end;

    if option.debug_opt		/* check line range if debugging */
    then
      do;
        if option.db_all_opt		/* if debugging all */
        then
	do;
	  if (option.db_file = "ALLFILES"
	       | shared.input_filename = option.db_file)
	  then
	    do;
	      if call_box.lineno0 >= option.db_file_after
		 & info.lineno >= option.db_after_line
		 & info.lineno <= option.db_before_line
	      then shared.bug_mode = "1"b;
	      else shared.bug_mode = "0"b;
	    end;
	end;

        else
	do;
	  if option.db_line_strt <= info.lineno
	       & info.lineno <= option.db_line_end
	       & (option.db_file = "ALLFILES"
	       | shared.input_filename = option.db_file)
	  then shared.bug_mode = "1"b;
	  else shared.bug_mode = "0"b;
	end;
      end;
    else shared.bug_mode = "0"b;	/**/
				/* trim trailing SPs and HTs */
    buffer = rtrim (buffer, " 	");

    if index (buffer, "	") ^= 0	/* if any HTs in the line */
    then
      do;				/* set overlay ptr */
        char_index_ptr = addr (substr (buffer, 1));
        ascii_width = 0;		/* set up loop counters */
        i, j = 1;			/* and control indices */
        do while (j > 0);		/* as long as HTs are found */
				/* look for an HT */
	j = index (substr (buffer, i), "	");

	if j > 0			/* if one was found */
	then
	  do;
	    if j > 1		/* measure preceding text */
	    then
	      do;
	        do k = i to i + j - 2;
		if char_index (k) >= 32 & char_index (k) <= 126
		then ascii_width = ascii_width + 1;
		else if char_index (k) = 8
		then ascii_width = ascii_width - 1;
	        end;
	        ii = i + j - 1;	/* position of HT in line */
	      end;
	    else ii = i;		/* HT is the next character */

	    blank_count =		/* blanks to next Multics tab */
	         10 - mod (ascii_width, 10);
				/* insert them */
	    buffer =
	         substr (buffer, 1, ii - 1) || copy (" ", blank_count)
	         || substr (buffer, ii + 1);
				/* adjust counters */
	    i = ii + blank_count;
	    ascii_width = ascii_width + blank_count;
	  end;
        end;
      end;

    if ^skip
    then
      do;
        if shared.bug_mode
        then
	do;
	  call ioa_ ("***^/read$line: (^a|^d) ^[<<BLANK>>^;""^a""^]",
	       file.refname, info.lineno, (buffer = ""),
	       comp_util_$display (buffer, 0, "0"b));

	  if option.db_pause_opt	/* if pausing for debug */
	  then
	    do;
	      call ioa_ ("-->");
	      call iox_$get_line (iox_$user_input, addr (junk), 80, 0, ercd);
	      if ercd ^= 0
	      then call comp_report_ (2, ercd, "Attempting -pause option.",
		      info_ptr, "");
	    end;
	end;
      end;

    ctl.info = info;

    return;			/* end of read_$line */
%page;
/* extract name strings from input lines */

name:
  entry (buffer, start, next, a_info_ptr) returns (char (*) var);

/* LOCAL STORAGE */

    dcl name	   char (32) var;	/* name holder */
    dcl name_chars	   char (63) static options (constant)
		   init (
		   "abcdefghijklmnopqrstuvwxyzABCDEFGHJIKLMNOPQRSTUVWXYZ"
		   || "_0123456789");

    if shared.bug_mode & dt_sw
    then call ioa_ ("read$name: (^d,""^a"")", start, substr (buffer, start));

    if substr (buffer, start) = ""	/* nothing to read */
    then return ("");		/**/
				/* skip leading white space */
    start = start - 1 + verify (substr (buffer, start), " ");
				/* it must start with alpha */
    if index (substr (name_chars, 1, 54), substr (buffer, start, 1)) = 0
    then goto bad_name;		/**/
				/* find end of name */
    i = verify (substr (buffer, start), name_chars) - 1;
    if i < 0			/* if nothing follows */
    then i = length (buffer) - start + 1;

    if i = 0			/* no legal name chars */
    then
      do;
        next = length (buffer) + 1;
        return ("");
      end;			/**/
				/* bad terminator? */
    else if start + i < length (buffer)
    then if index ("/ ", substr (buffer, start + i, 1)) = 0
         then
	 do;
bad_name:
	   call comp_report_ (2, 0, "Invalid name.", a_info_ptr, ctl_line);
	   i = index (substr (buffer, start), " ");
	   if i = 0
	   then next = length (buffer) + 1;
	   else next = start + i + 1;
	   return ("");
	 end;

    name = (substr (buffer, start, i));
    next = start + i;		/* skip over field */

    if next <= length (buffer) &	/* skip trailing white space */
         substr (buffer, next, 1) = " "
    then
      do;
        i = verify (substr (buffer, next), " ");
        if i > 1
        then next = next + i - 1;
        else next = length (buffer) + 1;
      end;

    return (name);
%page;
number:				/* read numbers of the form "(+|-)n" */
  entry (buffer, scale, start, next, a_info_ptr, code)
       returns (fixed bin (31));

/* PARAMETERS */
    dcl scale			/* IN scale factor(s) for return value */
		   (*) fixed bin (31);
    dcl code	   fixed bin (35);	/* (OUT) error code */

/* LOCAL STORAGE */

    dcl diglen	   fixed bin;	/* length of digit string */
    dcl digits	   char (1020) var; /* field to be converted */
    dcl field	   char (1020) var;
    dcl scales	   char (21) static options (constant)
		   init ("p1 p1 in mm pc pt pp ");
    dcl scalndx	   fixed bin;	/* index into scale array */
    dcl sign	   fixed bin (1);	/* sign of value */
				/* return value */
    dcl value	   fixed bin (31);

    dcl comp_error_table_$not_numeric
		   ext fixed bin (35);

    code, value = 0;		/* clear in case theres an error */
    scalndx = 1;			/* set the default */

    if shared.bug_mode & dt_sw
    then call ioa_ ("read$number: (""^a"")",
	    comp_util_$display (substr (buffer, start), 0, "0"b));
				/* step over leading blanks */
    start = start + verify (substr (buffer, start), " ") - 1;
				/* if signed */
    if index ("+-", substr (buffer, start, 1)) ^= 0
    then
      do;
        if index (substr (buffer, start), "-") = 1
        then sign = -1;
        else sign = 1;
        start = start + 1;
      end;
    else sign = 1;			/**/
				/* copy field to be read */
    diglen = search (substr (buffer, start), ",})/\+-""=<>^ ") - 1;
    if diglen < 0
    then diglen = length (buffer) - start + 1;
    field = substr (buffer, start, diglen);
    field = ltrim (field);		/* trim leading blanks */
				/* it must start with a numeric */
    if search (field, "0123456789.") ^= 1
    then
      do;
        code = comp_error_table_$not_numeric;
        call comp_report_$ctlstr (2, code, a_info_ptr, buffer, "");
				/* step over field */
        next = start + length (field);
        goto number_return;
      end;			/**/
				/* measure the string of numerics */
    diglen = verify (field, "0123456789.") - 1;
    if diglen < 0			/* if all chars are numerics */
    then diglen = length (field);	/**/
				/* copy digit string */
    digits = substr (field, 1, diglen);
    field = after (field, digits);	/* trim it from the field */

    if search (field, "pim") = 1	/* is there a scale? */
    then
      do;
        scalndx = index (scales, substr (field, 1, 2));
        if scalndx = 0
        then
	do;
	  call comp_report_$ctlstr (2, 0, a_info_ptr, buffer,
	       "Invalid scale keyword ""^a"".", field);
				/* step over field */
	  next = start + length (field);
	  code = -1;
	  goto number_return;
	end;

        if scalndx = 1
        then if substr (field, 1, 3) = "p12"
	   then
	     do;
	       scalndx = scalndx + 3;
	       diglen = diglen + 1;
	     end;

        scalndx = divide (scalndx + 2, 3, 17, 0);
        diglen = diglen + 2;
      end;

/*    else if field ^= "" & search (field, " ,") ^= 1
/*				/* if not a delimiter */
/*    then
/*      do;
/*        next = start + length (field);
/*        code = -1;
/*        goto number_return;
/*      end;*/

    if index (digits, ".") = 0	/* integer? */
    then value = sign * scale (scalndx) * bin (digits);

    else value =			/* mixed number */
	    sign
	    * (scale (scalndx) * bin (before (digits, "."), 31, 0)
	    +
	    divide (scale (scalndx)
	    * bin (substr (after (digits, ".") || "000", 1, 3), 31, 3), 1000,
	    31, 0));		/**/
				/* step over value */
    next = start + diglen;

/*      if start < length (buffer)	/* skip trailing white space */
/*      then start = start + verify (substr (buffer, start), " ") - 1;*/

number_return:
    if shared.bug_mode & dt_sw
    then call ioa_ ("^5x(read$number ^f/^f=^f)", value, scale (scalndx),
	    dec (divide (value, scale (scalndx), 31, 10), 11, 3));

    return (value);			/* end of read$number */
%page;
    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

%include comp_entries;
%include comp_fntstk;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_shared;
%include comp_text;
%include comp_tree;
%include compstat;

  end comp_read_;




		    comp_report_.pl1                04/23/85  1059.2rew 04/23/85  0910.4       72774



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

/* compose subroutine to record input errors */

/* format: style2,ind3,ll80,dclind4,idind16,comcol41,linecom */

comp_report_:
   proc (a_sev, a_code, a_message, a_info_ptr, a_line);

/* PARAMETERS */

      dcl a_sev	      fixed bin;	/* error a_severity */
      dcl a_code	      fixed bin (35);
				/* system errcode; if any */
      dcl a_message	      char (*);	/* error message */
      dcl a_info_ptr      ptr;	/* line info structure */
      dcl a_line	      char (*) varying;
				/* text from offending line */

      dcl 1 line_info     like text_entry.info based (info_ptr);

/* LOCAL STORAGE */

      dcl call_nest	      char (4096) var init ("");
      dcl code	      fixed bin (35);
				/* error code */
      dcl ctl_str	      bit (1);	/* 1= ctlstr was called */
      dcl ercd	      fixed bin (35);
				/* local error code */
      dcl errlen	      fixed bin (35);
				/* length of error message */
      dcl errlong	      char (100) aligned;
				/* expanded error line for message */
      dcl errlong_len     fixed bin (35);
				/* length of errlong */
      dcl error_char      (const.max_seg_chars - 400) unal char (1)
		      based (addr (error.text));
      dcl errshort	      char (8) aligned;
				/* short error string for
				   convert_status_code_ */
      dcl icall	      fixed bin;	/* working index */
      dcl info_ptr	      ptr;	/* pointer to info structure */
      dcl line	      char (1020) var;
				/* offending line */
      dcl me	      char (32) var;/* entry used */
      dcl message	      char (512) var;
				/* error message */
      dcl next_err	      char (10000) based (next_err_ptr);
				/* string overlay for
				   next error message */
      dcl next_err_ptr    ptr;
      dcl NL	      char (1) static options (constant) init ("
");
      dcl sev	      fixed bin;	/* error severity */

      dcl (addr, max, null, size)
		      builtin;

      dcl comp_abort      condition;

      dcl com_err_	      entry options (variable);
      dcl convert_status_code_
		      entry (fixed (35), char (8) aligned,
		      char (100) aligned);
      dcl get_temp_segment_
		      entry (char (*), ptr, fixed bin (35));
      dcl ioa_$rsnp	      entry options (variable);
      dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*),
		      fixed bin (21), bit (1) aligned, bit (1) aligned);

      ctl_str = "0"b;		/* not control string entry */
      me = "comp_report_:";
      sev = a_sev;
      code = a_code;
      message = a_message;
      line = a_line;
      info_ptr = a_info_ptr;
      goto JOIN;

ctlstr:
   entry;
/**** (a_sev, a_code, a_info_ptr, a_line, ctl_str, args... */

      dcl arglist	      (0:nargs) ptr based (arglist_ptr);
				/* argument ptr list */
      dcl arglist_ptr     ptr;	/* pointer to argument list */
      dcl fb	      fixed bin (35) based;
      dcl 1 msg	      based (msg_ptr),
	  2 len	      fixed bin (21),
	  2 chars	      char (512);
      dcl msg_ptr	      ptr;
      dcl nargs	      fixed bin;	/* argument count */
      dcl ptr	      ptr based;	/* to hold info ptr */

      dcl cu_$arg_count   entry (fixed bin);
      dcl cu_$arg_list_ptr
		      entry (ptr);

      ctl_str = "1"b;		/* control string entry */
      arglist_ptr = null;
      msg_ptr = addr (message);
      me = "comp_report_$ctlstr:";
      call cu_$arg_count (nargs);	/* number of args */
      call cu_$arg_list_ptr (arglist_ptr);
				/* pointer to arg list */
      sev = arglist (1) -> fb;
      code = arglist (2) -> fb;
      info_ptr = arglist (3) -> ptr;
      line = addrel (arglist (4), -1) -> txtstr;

      call ioa_$general_rs (arglist_ptr, 5, 6, msg.chars, msg.len, "0"b, "0"b);

JOIN:
      if shared.pass_counter > 1	/* if not the output pass */
      then return;			/* forget it */

      if shared.bug_mode
      then call ioa_ ("^a ^o ^a", me, code, message);

      if const.errblk_ptr = null ()
      then call error_init;

      if code ^= 0			/* convert code if given */
      then
         do;
	  call convert_status_code_ (code, errshort, errlong);
	  errlong_len = 101 - verify (reverse (errlong), " ");
         end;

      else
         do;
	  errlong = "";
	  errlong_len = 0;
         end;

      compose_severity_ = max (compose_severity_, sev);

      call build_call_nest;		/* build the call nest */

      if option.output_file_opt | option.check_opt
				/* direct reporting */
      then
         do;
	  if error.next = 0
	  then call ioa_ ("^/compose error list: (Vers. ^a)",
		  const.comp_version);
	  call ioa_ ("^a", call_nest);
	  call ioa_ ("^5x^[^a ^;^s^]^a^[^/^5x^a^]", (errlong_len > 0),
	       substr (errlong, 1, errlong_len), message, (line ^= ""),
	       comp_util_$display (translate (line, " ", ""), 0, "0"b));
	  error.next = 1;
         end;

      else
         do;			/* deferred reporting */
	  next_err_ptr = addr (error_char (error.next + 1));
	  call ioa_$rsnp ("^a", next_err, errlen, call_nest);
	  error.next = error.next + errlen;
	  next_err_ptr = addr (error_char (error.next + 1));
	  call ioa_$rsnp ("^5x^[^a ^;^s^]^a^[^/^5x^a^]", next_err, errlen,
	       (errlong_len > 0), substr (errlong, 1, errlong_len), message,
	       (line ^= ""),
	       comp_util_$display (translate (line, " ", ""), 0, "0"b));
	  error.next = error.next + errlen;
	  error.count = error.count + 1;
         end;

      return;

exact:
   entry (a_message, a_info_ptr);

      message = a_message;
      info_ptr = a_info_ptr;

      if shared.bug_mode
      then call ioa_ ("comp_report_$exact: ^a", message);

      if shared.pass_counter > 1	/* if not the output pass */
      then return;			/* forget it */

      if const.errblk_ptr = null ()
      then call error_init;

      call build_call_nest;		/* build the call nest */

      if option.output_file_opt | option.check_opt
				/* direct reporting to the user */
      then
         do;
	  if error.next = 0
	  then call ioa_ ("^/compose error list: (Vers. ^a)",
		  const.comp_version);
	  call ioa_ ("^a", call_nest);
	  call ioa_ ("^5x^a", a_message);
	  error.next = 1;
         end;

      else
         do;			/* deferred reporting */
	  next_err_ptr = addr (error_char (error.next + 1));
	  call ioa_$rsnp ("^a", next_err, errlen, call_nest);
	  error.next = error.next + errlen;
	  next_err_ptr = addr (error_char (error.next + 1));
	  call ioa_$rsnp ("^5x^a", next_err, errlen, a_message);
	  error.next = error.next + errlen;
	  error.count = error.count + 1;
         end;

error_init:
   proc;
      call get_temp_segment_ ("compose", const.errblk_ptr, ercd);
      if ercd ^= 0
      then
         do;
	  call com_err_ (ercd, "compose",
	       "Getting a temp segment for the error list.");
	  signal comp_abort;
	  return;
         end;
      error.count, error.next = 0;	/* initialize list */
   end error_init;

build_call_nest:
   proc;

      dcl i	      fixed bin;	/* working index */
      dcl (hbound, min)   builtin;

      do i = 0 to min (call_stack.index, hbound (call_stack.ptr, 1));
         call_box_ptr = call_stack.ptr (i);
         call_nest = call_nest || call_box.refname;
         call_nest = call_nest || "; ";
         if i < call_stack.index
         then call_nest = call_nest || ltrim (char (call_box.exit_lineno));
         else call_nest = call_nest || ltrim (char (line_info.lineno));
         call_nest = call_nest || ": ";
      end;

   end build_call_nest;
%page;
%include comp_entries;
%include comp_error;
%include comp_fntstk;
%include comp_insert;
%include comp_option;
%include comp_shared;
%include comp_text;
%include compstat;

   end comp_report_;




		    comp_space_.pl1                 04/23/85  1059.2rew 04/23/85  0910.4       95796



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

/* compose subroutine to add white space to the output */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_space_:
  proc (a_space, block_ptr, txtflg, notrimflg, cbarflg, filspcflg);

/* PARAMETERS */

    dcl a_space	   fixed bin (31);	/* white space to be added */
    dcl block_ptr	   ptr;		/* ptr to block to which to the space.
				   If this pointer is null, then a
				   white space block is to added to the
				   current text column */
    dcl txtflg	   bit (1);	/* 1 = text area, 0 = page hdr/ftr */
    dcl notrimflg	   bit (1);	/* 1 = WS is to be untrimable */
    dcl cbarflg	   bit (1);	/* 1 = add cbars if active */
    dcl filspcflg	   bit (1);	/* 1 = table/art fill space */

/* LOCAL STORAGE */

    dcl artsz	   fixed init (0);	/* size of artwork for debug */
    dcl blkptr	   ptr;		/* local block pointer */
    dcl 1 block	   aligned like text based (blkptr);
				/* block to which WS is to be added */
    dcl ercd	   fixed (35);	/* system error code */
    dcl (i, j)	   fixed;		/* working index */
    dcl new_block	   bit (1);	/* 1 = new block being added */
    dcl space	   fixed bin (31);	/* local space value, adjusted for
				   device resolution */
				/* the white space entry */
    dcl 1 space_line   aligned like text_entry;
    dcl space_text	   char (4) varying /* null text for the entry */
		   static options (constant) init ("");
    dcl th_space	   bit (1);	/* space adds to header */
    dcl tspace	   fixed bin (31);	/* working value */

    dcl (addr, copy, fixed, index, length, max, null, size, substr)
		   builtin;

    dcl com_err_	   entry options (variable);
    dcl iox_$put_chars entry (ptr, ptr, fixed (35), fixed (35));

    new_block, th_space = "0"b;

    space = comp_dvt.min_lead		/* adjust space to match the device */
         * round (divide (a_space, comp_dvt.min_lead, 31, 1), 0);

    blkptr = block_ptr;		/* copy the given block pointer */

    if shared.table_mode		/* set table info */
    then
      do;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        tblcolptr = tblfmt.colptr (tblfmt.ccol);
      end;

    if shared.bug_mode		/* debugging stuff */
    then
      do;
        call ioa_$nnl ("space: (spc=^f ^f^[ text^]^[ notrim^]",
	   show (a_space, 12000), show (space, 12000), txtflg, notrimflg);

        if blkptr ^= null ()
        then
	do;
	  call ioa_$nnl ("^[^[ |^]^[ *^]^;^2s^] ^a=^d e^d u^f(^f)", cbarflg,
	       block.parms.cbar.add, block.parms.cbar.del, block.blktype,
	       block.blkndx, block.hdr.count, show (block.hdr.used, 12000),
	       show (block.hdr.trl_ws, 12000));

	  if shared.table_mode	/* & block.hdr.tblblk*/
	  then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblfmt.ccol, tbldata.ndx,
		  show (tblcol.depth, 12000),
		  show (tblfmt.maxdepth, 12000));

	  call ioa_$nnl ("^[ ftn=^d/^f^;^2s^]^[ A^]^[ MOD^])",
	       (block.hdr.ftn.ct > 0), block.hdr.ftn.ct,
	       show (block.hdr.ftn.usd, 12000), block.hdr.art,
	       block.hdr.modified);
	end;

        else
	do;
	  if shared.table_mode	/* & block.hdr.tblblk*/
	  then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblfmt.ccol, tbldata.ndx,
		  show (tblcol.depth, 12000),
		  show (tblfmt.maxdepth, 12000));
	  call ioa_$nnl ("^[ |^]^[ *^])", current_parms.cbar.add,
	       current_parms.cbar.del);
	end;

        call ioa_$nnl ("^/^5x(col=^d b^d u^f(^f)/^f(^f)^[ ftn=^d/^f^]",
	   page.hdr.col_index, col.hdr.blkct, show (col.hdr.used, 12000),
	   show (col.hdr.pspc, 12000), show (col.hdr.net, 12000),
	   show (col.depth_adj, 12000), (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000));

        call ioa_$nnl (" pag=^a c^d u^f(^f)/^f", page.hdr.pageno,
	   page.hdr.col_count, show (page.hdr.used, 12000),
	   show (page.hdr.hdspc, 12000), show (page.hdr.net, 12000));

        if col0.hdr.ftn.ct > 0
        then call ioa_$nnl (" ftn=^d/^f", col0.hdr.ftn.ct,
	        show (col0.hdr.ftn.usd, 12000));
        call ioa_ ("^[ pi=^d ^f^])", (shared.picture.count > 0),
	   shared.picture.count, show (shared.picture.space, 12000));
      end;			/**/
				/* if adding to the current block */
    if blkptr = shared.blkptr & shared.blkptr ^= null
    then
      do;				/**/
				/* add space to a pending header? */
        if txtflg & ^shared.inserting_hfc & text.parms.hdrptr ^= null ()
/****        then if text.parms.hdrptr -> hfcblk.hdr.count > 0*/
        then
	do;
	  blkptr = text.parms.hdrptr;
	  th_space = "1"b;
	end;
/****	   else ;*/

        else if text.input_line ^= ""
        then call comp_break_ (format_break, 0);
      end;

    if space = 0			/* no lines wanted */
    then goto return_;

/* set up the space line */
real_space:
    space_line = text_entry;
    space_line.info = ctl.info;	/* copy input line info */
    space_line.title = "0"b;		/* reset the title flag */
    space_line.white = "1"b;		/* set the WS flag */
    space_line.no_trim = notrimflg;	/* set trim flag */
    space_line.ptr = addr (space_text); /* some null text */
    space_line.width = 0;		/* having no width */
    space_line.lmarg = 0;
    space_line.rmarg = col.margin.right;/* typographic stuff */
    space_line.cur.font, space_line.font =
         current_parms.fntstk.entry (current_parms.fntstk.index);
    space_line.quad = quadl;

/* if a white block is wanted */
    if blkptr = null ()
    then
      do;				/* head page if necessary */
        if ^(option.galley_opt | page.hdr.headed)
        then call comp_head_page_ (0);	/**/
				/* get a block */
        call comp_util_$getblk (page.hdr.col_index, blkptr, "ws",
	   addr (current_parms), "0"b);
        block_ptr, shared.blkptr = blkptr;

        text.hdr.white = "1"b;	/* make ws block current block */
        new_block = "1"b;		/* set the new block flag */
				/* insert pending text title */
        if text.parms.hdrptr ^= null & ^shared.inserting_hfc
        then
	do;
	  text.hdr.white = text.parms.hdrptr -> hfcblk.hdr.white;
	  if ^text.hdr.white
	  then text.blktype = "tx";
	  call comp_title_block_ (text.parms.hdrptr);
	end;			/**/
				/* set trim flag */
        text.hdr.no_trim = notrimflg;	/* so artwork space gets counted */
        space_line.art = text.parms.art;

        if cbarflg
        then
	do;
	  space_line.cbar.add = current_parms.cbar.add;
	  space_line.cbar.del = current_parms.cbar.del;
	  if current_parms.cbar.del
	  then shared.cbar_type = "";
	  current_parms.cbar.del = "0"b;
	  text.hdr.modified =
	       (text.hdr.modified | space_line.cbar.add
	       | space_line.cbar.del);
	end;
      end;

/* adding space to current block */
    else
      do;
        space_line.art = block.parms.art;
        space_line.keep = block.parms.keep;

        if cbarflg			/* set cbar flags */
        then
	do;
	  space_line.cbar.add = block.parms.cbar.add;
	  space_line.cbar.del = block.parms.cbar.del;
	  if block.parms.cbar.del
	  then shared.cbar_type = "";
	  block.parms.cbar.del = "0"b;
	  block.hdr.modified =
	       (block.hdr.modified | space_line.cbar.add
	       | space_line.cbar.del);
	end;
      end;			/**/
				/* make individual entries */
				/* for artwork or change bars */
    if (space_line.cbar.add | space_line.art
				/* and for table blocks if the */
				/* format isnt in context mode */
         | shared.table_mode & block.hdr.tblblk & ^tblfmt.context)
    then
      do;
        tspace = space;		/* set local value */

        if tspace >= 12000
        then
	do;
	  space_line.linespace = 12000;
	  do i = 1 to divide (tspace, 12000, 17, 0);
	    call comp_util_$add_text (blkptr, "0"b, "0"b, "0"b,
	         block.input.oflo, addr (space_line));
	    if th_space
	    then text.parms.hdrptr = blkptr;
	    tspace = tspace - 12000;
	  end;
	end;

        if tspace > 0
        then
	do;
	  space_line.linespace = tspace;
	  call comp_util_$add_text (blkptr, "0"b, "0"b, "0"b,
	       block.input.oflo, addr (space_line));
	  if th_space
	  then text.parms.hdrptr = blkptr;
	end;
      end;

    else				/* make one entry */
      do;
        space_line.linespace = space;
        call comp_util_$add_text (blkptr, "0"b, "0"b, "0"b, block.input.oflo,
	   addr (space_line));
        if th_space
        then text.parms.hdrptr = blkptr;
      end;

/****    if (block.hdr.colno >= 0		/* if block belongs to a column */
/****         & ^filspcflg)		/* & isnt table filler */
/****         & block.blktype ^= "ph"	/* and isnt the page header */
/****    then col.hdr.pspc = col.hdr.pspc + space;*/

return_:
    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("^5x(space: ^a=^d e^d u^f(^f)", block.blktype,
	   block.blkndx, block.hdr.count, show (block.hdr.used, 12000),
	   show (block.hdr.trl_ws, 12000));

        if shared.table_mode		/* & block.hdr.tblblk*/
        then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblfmt.ccol, tbldata.ndx,
	        show (tblcol.depth, 12000), show (tblfmt.maxdepth, 12000));

        call ioa_$nnl ("^[ ftn^d ^f^;^2s^]^[ A^]^[ MOD^])",
	   (block.hdr.ftn.ct > 0), block.hdr.ftn.ct,
	   show (block.hdr.ftn.usd, 12000), block.hdr.art,
	   block.hdr.modified);

        call ioa_$nnl ("^/^-(col=^d b^d u^f(^f)/^f(^f)^[ ftn=^d/^f^;^2s^] "
	   || "pag=^a c^d u^f(^f)/^f", page.hdr.col_index, col.hdr.blkct,
	   show (col.hdr.used, 12000), show (col.hdr.pspc, 12000),
	   show (col.hdr.net, 12000), show (col.depth_adj, 12000),
	   (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), page.hdr.pageno,
	   page.hdr.col_count, show (page.hdr.used, 12000),
	   show (page.hdr.hdspc, 12000), show (page.hdr.net, 12000));

        call ioa_ ("^[ pi=^d ^f^])", (shared.picture.count > 0),
	   shared.picture.count, show (shared.picture.space, 12000));
      end;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;

  end comp_space_;




		    comp_tbl_ctls_.pl1              04/23/85  1059.2rew 04/23/85  0910.4      277884



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

/* compose subroutine to process table controls */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_tbl_ctls_:
  proc (ctl_index);

/* PARAMETERS */

    dcl ctl_index	   fixed bin;	/* control selector */

/* LOCAL STORAGE */

    dcl blkptr	   ptr;		/* for local reference */
    dcl blktype	   char (2) init ("");
				/* for debugging */
    dcl 1 block	   aligned like text based (blkptr);
				/* for local reference */
    dcl ctl_info_ptr   ptr;
    dcl exit_str	   char (256) var;	/* exit info for debug */
				/* table column spec field */
    dcl field	   char (1020) var;
    dcl fnxt	   fixed bin (21);	/* for tabcol spec parsing */
    dcl hscales	   (7) fixed bin (31) static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl (i, j, k)	   fixed bin;	/* working index */
				/* empty table format entry */
    dcl 1 init_tblfmt  aligned static options (constant),
				/* start in context mode */
	2 context	   bit (1) init ("1"b),
				/* current column */
	2 icol	   fixed bin init (0),
				/* current maximum page depth */
	2 maxdepth   fixed bin (31) init (0),
				/* number of columns in this format */
	2 ncols	   fixed bin init (0),
				/* column pointers */
	2 colptr	   (0:20) ptr init ((21) null ());
				/* used in reordering table formats */
    dcl 1 move_tblfmt  like tbldata.fmt;
    dcl repct	   fixed bin;	/* tab col spec repeat count */
    dcl space	   fixed bin (31);	/* for vert table positioning */
    dcl tab_autoadj_gtr		/* autoadjust table gutter */
		   fixed bin;
    dcl tab_autoadj_posn
		   fixed bin;	/* autoadjust table position */
    dcl tab_autoadj_width
		   fixed bin;	/* autoadjust table width */
				/* empty tblcol structure */
    dcl 1 init_tblcol  aligned static options (constant),
	2 align,			/* column alignment mode */
	  3 posn	   fixed bin (31) init (0),
	  3 str	   char (32) var init (""),
				/* current table depth for column */
	2 depth	   fixed bin (31) init (0),
	2 gutter	   fixed bin (31) init (0),
				/* leadering string */
	2 leader	   char (16) var init (""),
	2 margin,
	  3 left	   fixed bin (31) init (0),
	  3 right	   fixed bin (31) init (0),
				/* vertical alignment flags */
	2 valign	   bit (4) unal init ("0000"b),
	2 MBZ	   bit (29) unal init ((29)"0"b),
	2 parms	   aligned like default_parms;
				/* name of table format */
    dcl tblfmt_name	   char (32) init ((32)" ");
    dcl 1 tblfont	   aligned like fntstk_entry;
				/* for local reference */
    dcl tcol_gutter	   fixed bin (31);	/* table column gutter */
    dcl tcol_posn	   fixed bin (31);	/* table column position */
    dcl tcol_width	   fixed bin (31);	/* table column width */
    dcl unscaled	   (1) fixed bin (31) static options (constant) init (1);

    dcl (addr, bin, char, dec, divide, hbound, index, length, ltrim, max, min,
        null, round, size, substr, verify)
		   builtin;

    dcl ioa_$rsnnl	   entry options (variable);

    if shared.bug_mode
    then call ioa_ ("tbl_ctls: (^d) ""^a""", ctl_index,
	    comp_util_$display (ctl_line, 0, "0"b));

    ctl_info_ptr = addr (ctl.info);
    exit_str = "";
    goto ctl_ (ctl_index);

ctl_ (144):			/* ".tab" = table-definition */
    if shared.table_mode		/* if in table mode */
    then
      do;
        call comp_report_ (2, 0,
	   "Redefinition of table formats not allowed" || " in table mode.",
	   ctl_info_ptr, ctl_line);
        goto return_;
      end;

    if ctl.index > length (ctl_line)	/* if nothing, cancel all formats */
    then
      do;
        if shared.tbldata_ptr ^= null ()
        then tbldata.ct, tbldata.ndx = 0;
        goto return_;
      end;

    if shared.tbldata_ptr = null ()	/* allocate data structure */
    then
      do;
        shared.tbldata_ptr = allocate (const.local_area_ptr, size (tbldata));
        tbldata.ct, tbldata.ndx = 0;
        tbldata.fmt (*).ptr = null ();
        tbldata.fmt (*).name = "";
      end;

    tblfmt_name =			/* read the table name */
         comp_read_$name (ctl_line, ctl.index, ctl.index, ctl_info_ptr);

    if tbldata.ct > 0		/* look for given name */
    then
      do i = 1 to tbldata.ct while (tblfmt_name ^= tbldata.fmt (i).name);
      end;
    else i = 1;

    if ctl.index > length (ctl_line)	/* if format is to be cancelled */
    then
      do;
        if tbldata.ct = 0		/* aint none to cancel */
        then
	do;
tab_err_1:
	  call comp_report_ (2, 0, "No defined table formats.", ctl_info_ptr,
	       ctl_line);
	  goto return_;
	end;

        if i > tbldata.ct		/* if name not found */
        then
	do;
tab_err_2:
	  call comp_report_ (2, 0, "Table format not defined.", ctl_info_ptr,
	       ctl_line);
	  goto return_;
	end;

        if tbldata.ct > 1		/* close up the table data array */
        then
	do;			/* move this format to the end */
	  move_tblfmt = tbldata.fmt (i);
				/* close ranks */
	  do i = i to tbldata.ct - 1;
	    tbldata.fmt (i) = tbldata.fmt (i + 1);
	  end;
	  tbldata.fmt (i) = move_tblfmt;
	end;

        tbldata.ct = tbldata.ct - 1;	/* reduce format count */
        goto return_;
      end;

    if i > hbound (tbldata.fmt, 1)	/* if not there and the inn is full */
    then
      do;
        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
	   "Only ^d table formats allowed.", hbound (tbldata.fmt, 1));
        goto return_;
      end;

    if tbldata.fmt (i).ptr = null ()	/* need an entry? */
    then tbldata.fmt (i).ptr = allocate (const.local_area_ptr, size (tblfmt));
				/* record format name */
    tbldata.fmt (i).name = tblfmt_name;
    tblfmtndx = i;			/* point to the new format */
    tblfmtptr = tbldata.fmt (i).ptr;
    tblfmt = init_tblfmt;		/* clear the entry */

    do j = 0 to 20			/* record column data */
         while (ctl.index <= length (ctl_line));

      if tblfmt.colptr (j) = null ()	/* need the column? */
      then tblfmt.colptr (j) = allocate (const.local_area_ptr, size (tblcol));

      if j > 1			/* set previous column pointer */
      then prvtblcolptr = tblcolptr;

      tblcolptr = tblfmt.colptr (j);	/* point to the column */
      tblcol = init_tblcol;		/* initialize structure */
      tblcol.parms = current_parms;

      if j = 0
      then tab_autoadj_posn,		/* no auto adjust for col 0 */
	      tab_autoadj_width, tab_autoadj_gtr = 0;

      else			/* for all the rest */
        do;
	tblcol.parms = tblcol0.parms; /* preset parms */
	tblcol.parms.left.indent,	/* except for indent */
	     tblcol.parms.right.indent = 0;
	tblcol.parms.measure,	/* preset for auto adjust */
	     tblcol.margin.left, tblcol.gutter = -1;

	fnxt =			/* is there a repeat group? */
	     verify (substr (ctl_line, ctl.index), "0123456789") - 1;

	if index (substr (ctl_line, ctl.index + fnxt), "[") = 1
	then
	  do;
	    if search (substr (ctl_line, ctl.index), "]:") = 0
	    then
	      do;
	        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
		   "Unclosed repeat group starting at " || "column ^d", j);
	        goto return_;
	      end;

	    field = before (substr (ctl_line, ctl.index), "]:");
				/* and step over it */
	    ctl.index = ctl.index + length (field) + 2;
	    field = ltrim (field);

	    if fnxt > 0
	    then repct =
		    comp_read_$number (field, unscaled, 1, 0, ctl_info_ptr,
		    0);
	  end;

	else			/* extract column spec */
	  do;
	    field = before (substr (ctl_line, ctl.index), ":");
				/* and step over it */
	    ctl.index = ctl.index + length (field) + 1;
	    field = ltrim (field);
	  end;			/**/
				/* position value must be first */
	if length (field) = 0	/* nothing given? */
	     | index (field, ",") = 1
	then
	  do;
	    call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
	         "No position value for table column ^d.", j);
	    goto tab_loop;
	  end;

	if index (field, "*") = 1	/* auto adjust position */
	then
	  do;
	    tab_autoadj_posn = tab_autoadj_posn + 1;
	    tcol_posn = -1;
	    field = ltrim (after (field, "*"));
	  end;

	else			/* read position */
	  do;
	    tcol_posn =
	         comp_read_$number (field, hscales, 1, fnxt, ctl_info_ptr, 0)
	         - shared.EN_width;

	    if tcol_posn < 0	/* position value NG */
	    then
	      do;
	        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
		   "Invalid position value for table column ^d.", j);
	        goto tab_loop;
	      end;
	    else tblcol.margin.left = tcol_posn;

	    field = ltrim (substr (field, fnxt));
	  end;

	tblcol.valign = vtop;	/* set defaults */
	tblcol.parms.fill_mode = "1"b;
	tblcol.parms.quad = just;
	tblcol.margin.left = tcol_posn;
				/* the comma is required */
	if field ^= "" & index (field, ",") ^= 1
	then
	  do;
	    call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
	         "Missing comma for table column ^d", j);
	    goto tab_loop;
	  end;

	field = ltrim (after (field, ","));
				/* auto adjust width */
	if field = "" | search (field, "*:g[nf") = 1
	then
	  do;
	    if tab_autoadj_gtr > 0
	    then
	      do;
autoadj_err:
	        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
		   "Adjustable widths and gutters may "
		   || "not be given in the same table format "
		   || "definition.");
	        goto return_;
	      end;

	    tab_autoadj_width = tab_autoadj_width + 1;
	    if index (field, "*") = 1
	    then field = ltrim (after (field, "*"));
	  end;

	else if field ^= ""		/* read column measure */
	then
	  do;
	    tblcol.parms.measure =
	         comp_read_$number (field, hscales, 1, fnxt, ctl_info_ptr, 0)
	         ;
	    field = ltrim (substr (field, fnxt));
				/* bad measure value */
	    if tblcol.parms.measure <= 0
	    then
	      do;
	        call comp_report_ (2, 0,
		   "Invalid width value for table column "
		   || ltrim (char (j)) || ".", ctl_info_ptr, ctl_line);
	        goto tab_loop;
	      end;
	  end;			/**/
				/* is there a gutter? */
	if index (field, "g") = 1
	then
	  do;
	    field = ltrim (substr (field, 2));
				/* auto adjust gutter */
	    if index (field, "*") = 1
	    then
	      do;
	        if tab_autoadj_width > 0
	        then goto autoadj_err;

	        tab_autoadj_gtr = tab_autoadj_gtr + 1;
	        field = ltrim (after (field, "*"));
	      end;

	    else			/* read column gutter */
	      do;
	        tblcol.gutter =
		   comp_read_$number (field, hscales, 1, fnxt,
		   ctl_info_ptr, 0);
	        field = ltrim (substr (field, fnxt));
				/* bad gutter value */
	        if tblcol.gutter <= 0
	        then
		do;
		  call comp_report_ (2, 0,
		       "Invalid gutter value for table column "
		       || ltrim (char (j)) || ".", ctl_info_ptr, ctl_line);
		  goto tab_loop;
		end;
	      end;		/**/
	  end;			/**/
				/* is there an alignment string? */
	if index (field, "[") = 1
	then
	  do;
	    if index (field, "]") = 0
	    then
	      do;
	        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
		   "No alignment string closing delimiter for table column ^d.",
		   j);
	        goto tab_loop;
	      end;

	    tblcol.parms.fill_mode = "0"b;
	    tblcol.parms.quad = quadl;
	    tblcol.align.str = before (after (field, "["), "]");
	    if tblcol.align.str ^= ""
	    then tblcol.align.posn = tcol_posn;
	    field = ltrim (after (field, "]"));

	    if field ^= ""
	    then
	      do;
	        if search (field, "lcr") = 1
	        then
		do;
		  tblcol.parms.quad = "000000"b;
		  k = index ("lcr", substr (field, 1, 1));
		  substr (tblcol.parms.quad, k + 2, 1) = "1"b;
		  field = ltrim (substr (field, 2));
		end;

	        else
		do;
		  call comp_report_ (2, 0,
		       "Invalid align mode character for table column "
		       || ltrim (char (j)) || ".", ctl_info_ptr, ctl_line);
		  goto tab_loop;
		end;
	      end;		/**/
				/* extract valign, if any */
	    if search (field, "tcbj") = 1
	    then
	      do;
	        if substr (field, 1, 1) = "t"
	        then tblcol.valign = vtop;
	        else if substr (field, 1, 1) = "c"
	        then tblcol.valign = vcen;
	        else if substr (field, 1, 1) = "b"
	        then tblcol.valign = vbot;
	        else if substr (field, 1, 1) = "j"
	        then tblcol.valign = vjust;

	        field = ltrim (substr (field, 2));
	      end;
	  end;

	else
	  do;
	    if field ^= ""
	    then
	      do;			/* if nofill */
	        if index (field, "n") = 1
	        then
		do;		/* reset flag and change alignment */
		  tblcol.parms.fill_mode = "0"b;
		  tblcol.parms.quad = quadl;
		end;

	        else if index (field, "f") ^= 1
	        then
		do;
		  call comp_report_ (2, 0,
		       "Invalid fill mode character "
		       || "for table column " || ltrim (char (j)) || ".",
		       ctl_info_ptr, ctl_line);
		  goto tab_loop;
		end;		/**/
				/* step over fill mode char */
	        field = ltrim (substr (field, 2));
	      end;

	    if field ^= ""
	    then
	      do;
	        if search (field, "iolcrb") = 1
	        then
		do;
		  k = index ("iolcrb", substr (field, 1, 1));
		  tblcol.parms.quad = "000000"b;
		  substr (tblcol.parms.quad, k, 1) = "1"b;
		  field = ltrim (substr (field, 2));
		end;

	        else
		do;
		  call comp_report_ (2, 0,
		       "Invalid align mode character for table column "
		       || ltrim (char (j)) || ".", ctl_info_ptr, ctl_line);
		  goto tab_loop;
		end;
	      end;
	  end;			/**/
				/* extract valign, if any */
	if search (field, "tcbj") = 1
	then
	  do;
	    if substr (field, 1, 1) = "t"
	    then tblcol.valign = vtop;
	    else if substr (field, 1, 1) = "c"
	    then tblcol.valign = vcen;
	    else if substr (field, 1, 1) = "b"
	    then tblcol.valign = vbot;
	    else if substr (field, 1, 1) = "j"
	    then tblcol.valign = vjust;

	    field = ltrim (substr (field, 2));
	  end;			/**/
				/* extract leader, if any */
	if index (field, """") = 1
	then
	  do;
	    tblcol.leader =
	         comp_extr_str_ ("1"b, field, 1, fnxt, 0, ctl_info_ptr);
	    field = ltrim (substr (field, fnxt));
	  end;

	else tblcol.leader = field;
        end;			/**/
				/* calculate right margin value */
      tblcol.margin.right = tblcol.margin.left + tblcol.parms.measure;
tab_loop:
      if shared.bug_mode & j = 0
      then
        do;
	tblfont = tblcol.parms.fntstk.entry (tblcol.parms.fntstk.index);
	call ioa_ ("^5x(tbl=0/^d mrg^f/^f/^f ^[F ^]"
	     || "^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]"
	     || "^[^4s^; ^[T^]^[C^]^[B^]^[J^]^]" || " fnt=^a ^f)", i,
	     show (tblcol.margin.left, 12000),
	     show (tblcol.margin.right, 12000),
	     show (tblcol.parms.measure, 12000), tblcol.parms.fill_mode,
	     (tblcol.parms.quad = quadi), (tblcol.parms.quad = quado),
	     (tblcol.parms.quad = quadl), (tblcol.parms.quad = quadc),
	     (tblcol.parms.quad = quadr), (tblcol.parms.quad = just),
	     (j = 0), (tblcol.valign = vtop), (tblcol.valign = vcen),
	     (tblcol.valign = vbot), (tblcol.valign = vjust), tblfont.name,
	     show (tblfont.size, 1000));
        end;
    end;

    if j > hbound (tblfmt.colptr, 1)
    then
      do;
        call comp_report_$ctlstr (2, 0, ctl_info_ptr, ctl_line,
	   "More than ^d columns specified, all extra ignored.",
	   hbound (tblfmt.colptr, 1));
        goto return_;
      end;

    tblfmt.ncols = j - 1;		/* record number of columns */

    if tab_autoadj_gtr > 0
    then
      do;
        tcol_gutter = 0;
      end;

    if tab_autoadj_width > 0
    then
      do;
        tcol_width = 0;		/* extra space accumulator */
        do j = 1 to tblfmt.ncols;
	tblcolptr = tblfmt.colptr (j);

	if tblcol.gutter < 0	/* if still <0 after autoadj_gtrs */
	then if j < tblfmt.ncols
	     then tblcol.gutter = 7200;
	     else tblcol.gutter = 0;	/* if width is adjustable and */
				/* surrounding positions are given */
	if tblcol.parms.measure < 0 & j < tblfmt.ncols
	then if tblcol.margin.left > 0
		& tblfmt.colptr (j + 1) -> tblcol.margin.left > 0
	     then
	       do;
	         tblcol.parms.measure =
		    tblfmt.colptr (j + 1) -> tblcol.margin.left
		    - tblcol.margin.left - tblcol.gutter - 7200;
	         tab_autoadj_width = tab_autoadj_width - 1;
	       end;		/**/
				/* is width of last col adjustable? */
	if tblcol.parms.measure < 0 & j = tblfmt.ncols
	then if tblcol.margin.left > 0
	     then
	       do;
	         tblcol.parms.measure =
		    current_parms.measure - tblcol.margin.left;
	         tab_autoadj_width = tab_autoadj_width - 1;
	       end;

	tcol_width =		/* accumulate space used */
	     tcol_width + max (tblcol.parms.measure, 0) + tblcol.gutter;
        end;

        if tab_autoadj_width > 0	/* any left? */
        then
	do;
	  tcol_width =
	       divide (current_parms.measure - tcol_width
	       - max (tblfmt.colptr (1) -> tblcol.margin.left, 0),
	       tab_autoadj_width, 31, 10);

	  do j = 1 to tblfmt.ncols;
	    tblcolptr = tblfmt.colptr (j);
	    if tblcol.parms.measure < 0
	    then tblcol.parms.measure = tcol_width;
	  end;
	end;
      end;

    if tab_autoadj_posn > 0
    then
      do;
        tcol_posn = 0;

        do j = 1 to tblfmt.ncols;
	tblcolptr = tblfmt.colptr (j);

	if tblcol.margin.left < 0
	then tblcol.margin.left = tcol_posn;

	tcol_posn =
	     tblcol.margin.left + tblcol.parms.measure + tblcol.gutter;
        end;
      end;

    do j = 1 to tblfmt.ncols;
      tblcolptr = tblfmt.colptr (j);
      tblfont = tblcol.parms.fntstk.entry (tblcol.parms.fntstk.index);
      tblcol.margin.right = tblcol.margin.left + tblcol.parms.measure;

      if shared.bug_mode
      then call ioa_ ("^5x(tbl=^d/^d mrg^f/^f/^f gtr^f ^[F^]"
	      || "^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]"
	      || "^[^4s^; ^[T^]^[C^]^[B^]^[J^]^]"
	      || "^[ aln=""^a""(^f)^;^2s^]^[ ldr=""^a""^;^s^] "
	      || "fnt=^a ^f)", j, i, show (tblcol.margin.left, 12000),
	      show (tblcol.margin.right, 12000),
	      show (tblcol.parms.measure, 12000),
	      show (tblcol.gutter, 12000), tblcol.parms.fill_mode,
	      (tblcol.parms.quad = quadi), (tblcol.parms.quad = quado),
	      (tblcol.parms.quad = quadl), (tblcol.parms.quad = quadc),
	      (tblcol.parms.quad = quadr), (tblcol.parms.quad = just),
	      (j = 0), (tblcol.valign = vtop), (tblcol.valign = vcen),
	      (tblcol.valign = vbot), (tblcol.valign = vjust),
	      (tblcol.align.str ^= ""), tblcol.align.str,
	      show (tblcol.align.posn, 12000), (tblcol.leader ^= ""),
	      comp_util_$display (tblcol.leader, 0, "0"b), tblfont.name,
	      show (tblfont.size, 1000));
    end;

    if i > tbldata.ct		/* if this is a new format */
    then tbldata.ct = i;
    goto return_;

ctl_ (145):			/* ".tac" = table column INDEX */
    if ^shared.table_mode		/* if not in table mode */
    then
      do;
        call comp_report_ (2, 0, "Not in table mode.", ctl_info_ptr, ctl_line);
        goto return_;
      end;

    tblfmtndx = tbldata.ndx;		/* record current format data */
    tblfmtptr = tbldata.fmt (tblfmtndx).ptr;
    tblcolptr = tblfmt.colptr (tblfmt.ccol);

    if ctl.index = 2		/* called from comp_? */
    then
      do;				/* next char is col # */
        i = bin (substr (ctl_line, 2, 1));
        if i = 0			/* .0 means column 10 */
        then i = 10;
      end;			/**/
				/* fetch column number */
    else if ctl.index <= length (ctl_line)
    then i = comp_read_$number (ctl_line, unscaled, ctl.index, ctl.index,
	    ctl_info_ptr, 0);
    else i = -1;			/* if not given, context mode */

    if i > tblfmt.ncols		/* is column undefined? */
    then
      do;
        call comp_report_ (2, 0, "Column undefined for this format.",
	   ctl_info_ptr, ctl_line);
        goto return_;
      end;

    if shared.blkptr ^= null
    then
      do;				/* title pending? */
        if text.parms.hdrptr ^= null & ^shared.inserting_hfc
        then if text.parms.hdrptr -> hfcblk.hdr.count > 0
	   then call comp_title_block_ (text.parms.hdrptr);

        if text.input_line ^= ""	/* clean up */
        then call comp_break_ (format_break, 0);
        tblcol.parms = text.parms;	/* save parms for next time */
      end;

    else tblcol.parms = current_parms;	/* save parms for next time */

    if i <= 0			/* if tblcol0, go to context mode */
    then
      do;
        if shared.blkptr ^= null
        then if text.hdr.count > 0
	   then
	     do i = 1 to tblfmt.ncols;/* do vertical alignment */
	       tblfmt.ccol = i;
	       tblcolptr = tblfmt.colptr (tblfmt.ccol);
				/* not top aligned? */
	       if tblcol.valign ^= vtop
	       then
	         do;		/**/
				/* centered? */
		 if tblcol.valign = vcen
		 then space = comp_dvt.min_lead
			 *
			 round (
			 divide (tblfmt.maxdepth - tblcol.depth,
			 2 * comp_dvt.min_lead, 31, 1), 0);
				/* bottom aligned */
		 else if tblcol.valign = vbot
		 then space = tblfmt.maxdepth - tblcol.depth;
				/* adjust depth of lines */
		 do line_area_ptr = text.line_area.first
		      repeat (line_area.next)
		      while (line_area_ptr ^= null);
		   do j = 1 to line_area.ndx;
		     txtlinptr = line_area.linptr (j);
		     if txtlin.tblcol = tblfmt.ccol
		     then txtlin.depth = txtlin.depth + space;
		   end;
		 end;
	         end;
	     end;

        tblfmt.ccol = 0;		/* go to column 0 */
        tblcolptr = tblfmt.colptr (tblfmt.ccol);
        current_parms = tblcol.parms;

        if shared.blkptr ^= null	/* active block? */
        then
	do;
	  current_parms.cbar = text.parms.cbar;
	  text.parms = current_parms;

	  text.input.lmarg = col0.margin.left;
	  text.input.rmarg = col0.margin.right;
	  text.input.net = text.input.rmarg - text.input.lmarg;
				/* finish the table entry */
	  if ^(text.parms.art | text.parms.keep | text.blktype = "pi")
	  then call comp_break_ (block_break, 0);
	end;

        tblfmt.context = "1"b;	/* set context mode */

        do i = 0 to tblfmt.ncols;	/* set table depths */
	tblfmt.colptr (i) -> tblcol.depth = tblfmt.maxdepth;
        end;
      end;

    else				/* changing to a given column */
      do;				/**/
				/* if leaving column 0 */
        if tblfmt.ccol = 0		/* advance all column depths */
        then
	do j = 1 to tblfmt.ncols;
	  tblfmt.colptr (j) -> tblcol.depth =
	       max (tblfmt.colptr (j) -> tblcol.depth, tblcol.depth);
	end;

        tblfmt.ccol = i;		/* set new column number */
        tblcolptr = tblfmt.colptr (i);
        tblfmt.context = "0"b;	/* reset context mode */
        current_parms = tblcol.parms;

        if shared.blkptr ^= null	/* active parms */
        then
	do;
	  current_parms.cbar = text.parms.cbar;
	  text.parms = current_parms;
	  text.input.lmarg = tblcol.margin.left;
	  text.input.rmarg = tblcol.margin.right;
	  text.input.net = text.input.rmarg - text.input.lmarg;
	  text.input.font, text.input.cur.font =
	       text.parms.fntstk.entry (text.parms.fntstk.index);
	end;
      end;

    ctl.lmarg = tblcol.margin.left;
    ctl.rmarg = tblcol.margin.right;
    ctl.font, ctl.cur.font =
         current_parms.fntstk.entry (current_parms.fntstk.index);

    if shared.bug_mode & shared.table_mode
    then
      do;
        tblfont = tblcol.parms.fntstk.entry (tblcol.parms.fntstk.index);

        if shared.blkptr ^= null
        then
	do;
	  j = text.blkndx;
	  blktype = text.blktype;
	end;

        call ioa_$rsnnl ("tbl=^d/^d d^f/^f mrg=^f/^f/^f ^[F^; ^]"
	   || "^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]^[^4s^; ^[T^]^[C^]^[B^]^[J^]^]"
	   || "^[ aln=""^a""(^f)^;^2s^] fnt=^a ^f", exit_str, 0, tblfmt.ccol,
	   tblfmtndx, show (tblcol.depth, 12000),
	   show (tblfmt.maxdepth, 12000),
	   show (tblcol.margin.left + tblcol.parms.left.indent, 12000),
	   show (tblcol.margin.right - tblcol.parms.right.indent, 12000),
	   show (tblcol.parms.measure, 12000), tblcol.parms.fill_mode,
	   (tblcol.parms.quad = quadi), (tblcol.parms.quad = quado),
	   (tblcol.parms.quad = quadl), (tblcol.parms.quad = quadc),
	   (tblcol.parms.quad = quadr), (tblcol.parms.quad = just), (j = 0),
	   (tblcol.valign = vtop), (tblcol.valign = vcen),
	   (tblcol.valign = vbot), (tblcol.valign = vjust),
	   (tblcol.align.str ^= ""), tblcol.align.str,
	   show (tblcol.align.posn, 12000), tblfont.name,
	   show (tblfont.size, 1000));
      end;

    goto return_;

ctl_ (146):			/* ".taf" = table off */
    if ^shared.table_mode		/* if not in table mode */
    then goto return_;		/* ignore it */

    ctl_line = ".tac";
    ctl.index = length (ctl_line) + 1;	/**/
				/* finish table entry */
    call comp_tbl_ctls_ (tac_ctl_index);

    tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
    tblcolptr = tblfmt.colptr (0);

    tbldata.ndx = 0;		/* no active format */
    shared.table_mode = "0"b;		/* leave table mode */

    if shared.blkptr ^= null
    then
      do;
        if text.parms.keep		/* clean up */
        then call comp_break_ (format_break, 0);
        else call comp_break_ (block_break, 0);
      end;

    goto return_;

ctl_ (147):			/* ".tan" = table-on */
    if shared.tbldata_ptr = null ()	/* no defined formats */
    then goto tab_err_1;

    if tbldata.ct = 0		/* also no defined formats */
    then goto tab_err_1;

    tblfmt_name =			/* fetch table format name */
         comp_read_$name (ctl_line, ctl.index, ctl.index, ctl_info_ptr);

    if tblfmt_name = ""		/* if not given */
    then
      do;
        call comp_report_ (2, 0, "Table format name must be given.",
	   ctl_info_ptr, ctl_line);
        goto return_;
      end;

    do i = 1 to tbldata.ct		/* search for given name */
         while (tblfmt_name ^= tbldata.fmt (i).name);
    end;

    if i > tbldata.ct		/* if not found */
    then goto tab_err_2;

/* if switching formats */
    if tbldata.ndx > 0
    then
      do;
        tblfmtndx = tbldata.ndx;	/* point to active format */
        tblfmtptr = tbldata.fmt (tblfmtndx).ptr;

        ctl_line = ".tac";		/* clean up */
        ctl.index = length (ctl_line) + 1;
        call comp_tbl_ctls_ (tac_ctl_index);
				/* propagate art, keep, depth */
        tbldata.fmt (i).ptr -> tblfmt.maxdepth = tblfmt.maxdepth;
        do j = 0 to min (tblfmt.ncols, tbldata.fmt (i).ptr -> tblfmt.ncols);
	tbldata.fmt (i).ptr -> tblfmt.colptr (j) -> tblcol.parms.art =
	     tblfmt.colptr (j) -> tblcol.parms.art;
	tbldata.fmt (i).ptr -> tblfmt.colptr (j) -> tblcol.parms.keep =
	     tblfmt.colptr (j) -> tblcol.parms.keep;
        end;			/**/
				/* propagate fill, cbars */
        tbldata.fmt (i).ptr -> tblfmt.colptr (0) -> tblcol.parms.fill_mode =
	   tblcol0.parms.fill_mode;
        tbldata.fmt (i).ptr -> tblfmt.colptr (0) -> tblcol.parms.cbar =
	   tblcol0.parms.cbar;
      end;

/* entering table mode */
    else
      do;
        if shared.blkptr ^= null	/* clean up current block */
        then
	do;			/**/
				/* block parms --> tabcol0 parms */
	  tbldata.fmt (i).ptr -> tblfmt.colptr (0) -> tblcol.parms =
	       text.parms;

	  if ^text.parms.keep	/* finish it if its not a keep */
	       & text.blktype ^= "pi" /* or a picture */
	       & (text.hdr.count > 0 | text.input_line ^= "")
	  then call comp_break_ (block_break, 0);

	  else
	    do;			/* otherwise, clean up */
	      if text.input_line ^= ""
	      then call comp_break_ (format_break, 0);
	      text.hdr.tblblk = "1"b; /* and make it  a table block */
	    end;
	end;

        else
	do;			/* head page if needed */
	  if ^option.galley_opt & ^page.hdr.headed & page.hdr.col_index >= 0
	  then call comp_head_page_ (0);
				/* current parms --> tabcol0 parms */
	  tbldata.fmt (i).ptr -> tblfmt.colptr (0) -> tblcol.parms =
	       current_parms;
	end;

        do j = 1 to tbldata.ct;	/* reset all formats to 0 depth */
	tbldata.fmt (j).ptr -> tblfmt.maxdepth = 0;
        end;

        shared.table_mode = "1"b;	/* enter table mode */
      end;

    tblfmtndx, tbldata.ndx = i;	/* point to the new format */
    tblfmtptr = tbldata.fmt (tblfmtndx).ptr;

    do j = 0 to tblfmt.ncols;
      tblcolptr = tblfmt.colptr (j);
      tblcol.parms.art = tblcol0.parms.art;
      tblcol.parms.keep = tblcol0.parms.keep;
      tblcol.parms.cbar = tblcol0.parms.cbar;
    end;

    tblfmt.ccol = 0;		/* go to column 0 */
    tblcolptr = tblfmt.colptr (0);
    const.current_parms_ptr = const.text_parms_ptr;
				/* intialize depth */
    do j = 0 to tbldata.fmt (i).ptr -> tblfmt.ncols;
      tbldata.fmt (i).ptr -> tblfmt.colptr (j) -> tblcol.depth =
	 tblfmt.maxdepth;
    end;

    if shared.blkptr ^= null		/* any pending text title? */
    then if text.parms.hdrptr ^= null () & ^shared.inserting_hfc
         then call comp_title_block_ (text.parms.hdrptr);

    if shared.bug_mode
    then
      do;
        if shared.blkptr ^= null
        then blktype = text.blktype;

        do j = 0 to tblfmt.ncols;
	tblcolptr = tblfmt.colptr (j);
	tblfont = tblcol.parms.fntstk.entry (tblcol.parms.fntstk.index);
	call ioa_ ("^5x(tbl=^d/^d d^f/^f mrg^f/^f/^f ^[F^; ^]"
	     || "^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]"
	     || "^[^4s^; ^[T^]^[C^]^[B^]^[J^]^]^[ aln=""^a""(^f)^;^2s^]"
	     || " fnt=^a ^f)", j, i, show (tblcol.depth, 12000),
	     show (tblfmt.maxdepth, 12000), show (tblcol.margin.left, 12000),
	     show (tblcol.margin.right, 12000),
	     show (tblcol.parms.measure, 12000), tblcol.parms.fill_mode,
	     (tblcol.parms.quad = quadi), (tblcol.parms.quad = quado),
	     (tblcol.parms.quad = quadl), (tblcol.parms.quad = quadc),
	     (tblcol.parms.quad = quadr), (tblcol.parms.quad = just),
	     (j = 0), (tblcol.valign = vtop), (tblcol.valign = vcen),
	     (tblcol.valign = vbot), (tblcol.valign = vjust),
	     (tblcol.align.str ^= ""), tblcol.align.str,
	     show (tblcol.align.posn, 12000), tblfont.name,
	     show (tblfont.size, 1000));

	if j = 0
	then call ioa_$rsnnl (
		"col=^d^[ ^a=^d^;^2s^] tbl=^d/^d d^f/^f fnt=^a ^f"
		|| "^[ A^]^[ K^]", exit_str, 0, page.hdr.col_index,
		(shared.blkptr ^= null), blktype, text.blkndx, tblfmt.ccol,
		i, show (tblcol.depth, 12000),
		show (tblfmt.maxdepth, 12000), tblfont.name,
		show (tblfont.size, 1000), current_parms.art,
		tblcol.parms.keep);
        end;
      end;

return_:
    if shared.bug_mode
    then call ioa_ ("^5x(tbl_ctls:^[ ^a^])", (exit_str ^= ""), exit_str);

    return;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_ctl_index;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include compstat;
%include translator_temp_alloc;

  end comp_tbl_ctls_;




		    comp_title_block_.pl1           04/23/85  1059.2rew 04/23/85  0910.5       88974



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

/* compose subroutine to insert header, footer, and text title blocks */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_title_block_:
  proc (blkptr);

/* PARAMETERS */

    dcl blkptr	   ptr;		/* pointer to title block */

/* LOCAL STORAGE */

    dcl (i, j)	   fixed;		/* working index */
    dcl meas	   bit (1);	/* controls line processing */
    dcl page_flag	   bit (1);
    dcl 1 ttlblk	   aligned like text based (blkptr);
    dcl txtrmarg	   fixed bin (31);	/* right margin for current block */

    dcl (index, length, size)
		   builtin;

    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("title_block: (^a=^d e^d u^f(^f) ^[NDX^;FMT^]^[ A^]",
	   ttlblk.blktype, ttlblk.blkndx, ttlblk.hdr.count,
	   show (ttlblk.hdr.used, 12000), show (ttlblk.hdr.trl_ws, 12000),
	   (ttlblk.hdr.mx_ttl_ndx > 0), ttlblk.hdr.art);

        if shared.blkptr ^= null ()
        then call ioa_ (" ^a=^d e^d u^f(^f))", text.blktype, text.blkndx,
	        text.hdr.count, show (text.hdr.used, 12000),
	        show (text.hdr.trl_ws, 12000));
        else call ioa_ (")");

        call ioa_ ("^5x(col=^d b^d u^f(^f)/n^f(^f)^[ ftn=^d ^f^;^2s^] "
	   || "pag=^a u^f(^f)/n^f^[ ftn=^d ^f^;^2s^])", page.hdr.col_index,
	   col.blkct, show (col.hdr.used, 12000), show (col.hdr.pspc, 12000),
	   show (col.hdr.net, 12000), show (col.depth_adj, 12000),
	   (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), page.hdr.pageno,
	   show (page.hdr.used, 12000), show (page.hdr.hdspc, 12000),
	   show (page.hdr.net, 12000), (col0.hdr.ftn.ct > 0),
	   col0.hdr.ftn.ct, show (col0.hdr.ftn.usd, 12000));
      end;

    shared.inserting_hfc = "1"b;
    page_flag = "0"b;

/* empty blocks */
    if ttlblk.hdr.count = 0
    then goto return_;

/* footers and captions */
    else if index (text.blktype, "f") = 2
    then
      do;
        if text.blktype = "pf"
        then
	do;
	  page_flag = "1"b;		/* set page flag */
	  txtrmarg = col0.margin.right;
	end;
        else txtrmarg = col.margin.right;

        if ttlblk.hdr.mx_ttl_ndx > 0	/* if an indexed block */
        then
	do;			/* use reverse order */
	  do i = ttlblk.hdr.mx_ttl_ndx to 1 by -1;
	    do line_area_ptr = ttlblk.line_area.first
	         repeat (line_area.next) while (line_area_ptr ^= null);
	      do j = 1 to line_area.ndx;
	        txtlinptr = line_area.linptr (j);

	        if txtlin.title_index = i
	        then
		do;
		  if /*text.blktype = "ph" | */ text.blktype = "pf"
		  then txtlin.rmarg, txtlin.net = page.parms.measure;
		  else
		    do;
		      txtlin.rmarg = txtrmarg;
		      txtlin.net = txtlin.rmarg - txtlin.lmarg;
		    end;

		  txtstrptr = txtlin.ptr;
		  meas =		/* set measure flag */
		       ^(txtlin.art | txtlin.quad = just
		       | txtlin.quad = quadl)
		       & index (txtstr, shared.sym_delim) = 0;

		  call comp_util_$add_text (shared.blkptr, meas, "0"b,
		       "1"b, "0"b, txtlinptr);
		end;
	      end;
	    end;
	  end;

	  goto return_;
	end;
      end;

/* headers and titles */
    else if index (text.blktype, "h") = 2
    then
      do;
        if ttlblk.hdr.mx_ttl_ndx > 0	/* if an indexed block */
        then
	do;
	  do i = 1 to ttlblk.hdr.mx_ttl_ndx;
	    do line_area_ptr = ttlblk.line_area.first
	         repeat (line_area.next) while (line_area_ptr ^= null);
	      do j = 1 to line_area.ndx;
	        txtlinptr = line_area.linptr (j);

	        if txtlin.title_index = i
	        then
		do;
		  txtlin.rmarg, txtlin.net = page.parms.measure;

		  txtstrptr = txtlin.ptr;
		  meas =		/* set measure flag */
		       ^(txtlin.art | txtlin.quad = just
		       | txtlin.quad = quadl)
		       & index (txtstr, shared.sym_delim) = 0;

		  call comp_util_$add_text (shared.blkptr, meas, "0"b,
		       "1"b, "0"b, txtlinptr);
		end;
	      end;
	    end;
	  end;

	  goto return_;
	end;
      end;

/* column headers and footers */
/****    else if text.blktype = "ch" | text.blktype = "cf"
/****    then text.hdr.tblblk = ttlblk.hdr.tblblk;*/

/* process the block */
    text.hdr.art = ttlblk.hdr.art | text.hdr.art;

    do line_area_ptr = ttlblk.line_area.first repeat (line_area.next)
         while (line_area_ptr ^= null);
      do i = 1 to line_area.ndx;
        txtlinptr = line_area.linptr (i);
        txtstrptr = txtlin.ptr;	/**/
				/* if line is not null */
        if txtstr ^= "" | txtlin.linespace > 0
        then
	do;			/* copy line to block input */
	  ttlblk.input = txtlin;
	  ttlblk.input.ptr = addr (ttlblk.input_line);

	  if index (txtstr, PAD) = 1	/* discard leading PADs */
	  then ttlblk.input_line = ltrim (txtstr, PAD);
	  else ttlblk.input_line = txtstr;

	  if text.parms.page	/* force right margin & net line */
	  then ttlblk.input.rmarg, ttlblk.input.net = page.parms.measure;
				/* pick up art flag */
	  ttlblk.input.art = text.hdr.art | ttlblk.input.art;

	  if index (ttlblk.input_line, shared.sym_delim) ^= 0
	       & text.blktype ^= "ph"
	  then call comp_use_ref_ (ttlblk.input_line, ttlblk.input.art, "1"b,
		  addr (ttlblk.input.info));
				/* set measure flag */
	  meas = index (ttlblk.input_line, shared.sym_delim) = 0
	       & ttlblk.input.width = 0
	       & ^(ttlblk.input.quad = just | ttlblk.input.quad = quadl);
				/* process escapes */
	  if index (ttlblk.input_line, "*") ^= 0 & ^ttlblk.input.art
	  then call comp_util_$escape (ttlblk.input_line,
		  addr (ttlblk.input.info));

	  call comp_util_$add_text (shared.blkptr, meas, "1"b, "0"b, "0"b,
	       addr (ttlblk.input));

	  if ttlblk.blktype = "th"	/* if this is a text header */
	  then
	    do;
/****	      text.hdr.first_text =	/* advance first text line */
/****		 text.hdr.first_text + 1;*/
				/* if an added title with added */
/****	      if text.parms.cbar.add	/* lead, add real lines */
/****		 & line_area.linptr (i) -> txtlin.linespace > 12000
/****	      then
/****	        do;		/* reset linespace to 1 */
/****		text.line_area.cur -> line_area.linptr (text.hdr.count)
/****		     -> txtlin.linespace = 12000;
/****
/****		call comp_space_ (line_area.linptr (i) -> txtlin.linespace
/****		     - 12000, shared.blkptr, "1"b, "1"b, "1"b, "0"b);
/****	        end;*/
	    end;

	  if ttlblk.blktype = "tf"	/* if this is a text caption */
	  then
	    do;			/* adjust column head space */
/****	      if txtstr = ""
/****	      then col.hdr.pspc = col.hdr.pspc + txtlin.linespace;
/****	      else col.hdr.pspc = 0;*/

/****	      if text.parms.cbar.add	/* if an added title with added lead */
/****		 & line_area.linptr (i) -> txtlin.linespace > 12000
/****	      then
/****	        do;		/* add real lines */
/****				/* reset linespace to 1 */
/****		text.line_area.cur -> line_area.linptr (text.hdr.count)
/****		     -> txtlin.linespace = 12000;
/****		call comp_space_ (line_area.linptr (i) -> txtlin.linespace
/****		     - 12000, shared.blkptr, "1"b, "1"b, "1"b, "0"b);
/****	        end;*/
	    end;
	end;
      end;
    end;

    if blkptr = text.parms.hdrptr
    then
      do;
        text.hdr.head_used = text.hdr.head_used + ttlblk.hdr.used;
        text.hdr.head_size = text.hdr.head_size + ttlblk.hdr.count;
      end;			/**/
				/* give back text title blocks */
    if blkptr = text.parms.hdrptr | blkptr = text.parms.ftrptr
    then call comp_util_$relblk (-1, blkptr);

return_:
/****    if text.blktype = "ph"		/* adjust page head space */
/****    then page.hdr.hdspc = col.hdr.pspc;*/
    if text.blktype = "ch"
    then call comp_break_ (block_break, 0);
    else if text.input_line ^= ""
    then call comp_break_ (format_break, 0);
/****    else if index (text.blktype, "f") ^= 0
/****    then call comp_break_ (footer_break, 0);*/

    if shared.bug_mode
    then
      do;
        call ioa_$nnl ("^5x(title_block:");

        if shared.blkptr ^= null
        then call ioa_ (" ^a=^d e^d u^f(^f)^[ ftn^d ^f^;^2s^]"
	        || "^[ hu=^f^;^s^]^[ A^]^[ K^])", text.blktype, text.blkndx,
	        text.hdr.count, show (text.hdr.used, 12000),
	        show (text.hdr.trl_ws, 12000), (text.hdr.ftn.ct > 0),
	        text.hdr.ftn.ct, show (text.hdr.ftn.usd, 12000),
	        (blkptr = text.parms.hdrptr),
	        show (text.hdr.head_used, 12000), text.hdr.art,
	        text.parms.keep);
        else call ioa_ (")");

        call ioa_ ("^-(col=^d b^d u^f(^f)/n^f(^f)^[ ftn=^d ^f^;^2s^] "
	   || "pag=^a u^f(^f)/n^f^[ ftn=^d ^f^;^2s^])", page.hdr.col_index,
	   col.blkct, show (col.hdr.used, 12000), show (col.hdr.pspc, 12000),
	   show (col.hdr.net, 12000), show (col.depth_adj, 12000),
	   (col.hdr.ftn.ct > 0), col.hdr.ftn.ct,
	   show (col.hdr.ftn.usd, 12000), page.hdr.pageno,
	   show (page.hdr.used, 12000), show (page.hdr.hdspc, 12000),
	   show (page.hdr.net, 12000), (col0.hdr.ftn.ct > 0),
	   col0.hdr.ftn.ct, show (col0.hdr.ftn.usd, 12000));
      end;

    shared.inserting_hfc = "0"b;

    return;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;
%page;
%include comp_brktypes;
%include comp_column;
%include comp_entries;
%include comp_fntstk;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_table;
%include comp_text;
%include comp_tree;
%include compstat;
/*%include translator_temp_alloc;*/

  end comp_title_block_;




		    comp_update_symbol_.pl1         04/23/85  1059.2rew 04/23/85  0910.5       69282



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

/* compose subroutine to assign values to tree symbols */

/* format: style2,ind3,ll80,dclind4,idind15,comcol41,linecom */

comp_update_symbol_:
   proc (priv, stack, defsw, symbol, buffer);

/* PARAMETERS */

      dcl priv	     bit (1);	/* (IN) 1= OK to set internal vars */
      dcl stack	     bit (1);	/* (IN) 1= stack variable */
      dcl defsw	     bit (1);	/* (IN) 1= define only, no value */
      dcl symbol	     char (32);	/* (IN) symbol to be updated */
      dcl buffer	     char (*) var;	/* (IN) symbol value string */

/* LOCAL STORAGE */

      dcl bufndx	     fixed bin (21);/* buffer scan index */
      dcl code	     fixed bin (35);/* error code */
      dcl CREATE	     bit (1) static options (constant) init ("1"b);
      dcl exptyp	     fixed bin;	/* type of <expr> */
      dcl LOG	     fixed bin static options (constant) init (1);
      dcl logval	     bit (1);	/* <expr> value from control line */
      dcl needtyp	     fixed bin;	/* <expr> type needed */
      dcl NUM	     fixed bin static options (constant) init (2);
      dcl numval	     fixed bin (31);/* <expr> value from control line */
      dcl STR	     fixed bin static options (constant) init (3);
      dcl val_attr	     bit (9);	/* attributes of <expr> */
      dcl val_key	     char (5) var;	/* value keyword for debug */
      dcl val_scale	     fixed bin (31);/* value scale for debug */
      dcl val_len	     fixed bin init (0);
				/* length of string */
      dcl value	     char (1020) var;
				/* <expr> value from buffer */

      dcl (after, addr, before, dec, divide, index, length, null, round, substr)
		     builtin;

      needtyp = 0;

      if shared.bug_mode | dt_sw
      then call ioa_ ("update_symbol: (^a^[ P^]^[ S^] ""^a"")", symbol, priv,
	      stack, comp_util_$display (buffer, 0, "0"b));
				/* search tree for this symbol */
      call comp_util_$search_tree (symbol, CREATE);
				/* a builtin? */
      if tree.areandx = 1 & tree.entryndx <= const.builtin_count
      then
         do;
	  if ^(priv | symbol = "DotAddLetter" | symbol = "PageBlock")
	  then
	     do;
	        call comp_report_ (2, 0,
		   "Invalid attempt to set a builtin variable "
		   || "with a set-reference control.", addr (ctl.info),
		   ctl_line);
	        return;
	     end;
	  if symbol = "DotAddLetter"
	  then needtyp = STR;
	  if symbol = "PageBlock"
	  then needtyp = LOG;
         end;

      if stack
      then call comp_util_$push (symbol);

      if defsw
      then
         do;
	  if shared.bug_mode | dt_sw
	  then call ioa_ ("^5x(update_symbol: ^d|^d ^a DEFINED)",
		  tree.areandx, tree.entryndx, symbol);
	  return;
         end;

      tree_var_ptr = tree.var_ptr (tree.areandx);

      if index (ctl_line, ".src") = 1	/* if its a counter set */
      then
         do;			/* make it a counting variable */
	  tree_var.flags (tree.entryndx) = counter_attr | numeric_attr;
				/* delta given? */
	  if index (buffer, "by") ^= 0
	  then
	     do;
	        call comp_expr_eval_ (before (buffer, "by"), 1,
		   addr (ctl.info), NUM, 0, "0"b,
		   tree_var.num_loc (tree.entryndx) -> num_value, "",
		   val_attr, 0);
	        call comp_expr_eval_ (after (buffer, "by"), 1,
		   addr (ctl.info), NUM, 0, "0"b,
		   tree_var.incr_loc (tree.entryndx) -> num_value, "", ""b,
		   0);
	     end;

	  else call comp_expr_eval_ (buffer, 1, addr (ctl.info), NUM, 0, "0"b,
		  tree_var.num_loc (tree.entryndx) -> num_value, "",
		  val_attr, 0);

	  tree_var.flags (tree.entryndx) =
	       tree_var.flags (tree.entryndx) | val_attr;

	  if shared.bug_mode | dt_sw
	  then call ioa_ ("^5x(update_symbol: ^d|^d ^a counter/^a ^f,^f)",
		  tree.areandx, tree.entryndx, symbol,
		  substr (mode_string,
		  2 * tree_var.mode (tree.entryndx) + 1, 2),
		  tree_var.num_loc (tree.entryndx) -> num_value,
		  tree_var.incr_loc (tree.entryndx) -> num_value);

	  return;
         end;

      if symbol = "Args" | buffer = "" | index (symbol, "CommandArg") = 1
      then
         do;
	  value = buffer;
	  goto str_vrbl;
         end;

      bufndx = 1;			/* evaluate the buffer */
      call comp_expr_eval_ (buffer, bufndx, addr (ctl.info), needtyp, exptyp,
	 logval, numval, value, val_attr, code);
      if code ^= 0
      then return;

      if bufndx > 0 & bufndx < length (buffer)
      then
         do;
	  if substr (buffer, bufndx, 1) = ")"
	  then call comp_report_ (2, 0, "Extra right parenthesis",
		  addr (ctl.info), ctl_line);
	  else call comp_report_ (2, 0, "Improper expression",
		  addr (ctl.info), ctl_line);
         end;

      if exptyp = STR
      then
         do;
str_vrbl:				/* if not stacked */
	  if ^substr (tree_var.flags (tree.entryndx), 9, 1)
	  then
	     do;			/* set to string type */
	        tree_var.flags (tree.entryndx) = string_attr;
				/* set value */
	        tree_var.str_loc (tree.entryndx) -> txtstr = value;
	     end;

	  else
	     do;			/* stacked */
	        tree_var.flags (tree.entryndx) = string_attr | push_attr;
				/* pushed string */
	        tree_var.num_loc (tree.entryndx) -> stack_box.txtstr = value;
	     end;

	  if shared.bug_mode | dt_sw
	  then call ioa_ ("^5x(update_symbol: ^d|^d ^a string (^d) ""^a"")",
		  tree.areandx, tree.entryndx, symbol, length (value),
		  comp_util_$display (value, 0, "0"b));
         end;

      else if exptyp = LOG
      then
         do;
	  if tree.areandx > 1 | tree.entryndx > const.builtin_count
	  then tree_var.flags (tree.entryndx) = flag_attr;
	  tree_var.flag_loc (tree.entryndx) -> flag_value = logval;

	  if shared.bug_mode | dt_sw
	  then call ioa_ ("^5x(update_symbol: ^d|^d ^a flag ^[T^;F^])",
		  tree.areandx, tree.entryndx, symbol, logval);
         end;

      else			/* numeric */
         do;			/* if not stacked */
	  if ^substr (tree_var.flags (tree.entryndx), 9, 1)
	  then
	     do;
	        tree_var.num_loc (tree.entryndx) -> num_value = numval;
	        tree_var.flags (tree.entryndx) = val_attr;
	     end;

	  else
	     do;
	        tree_var.flags (tree.entryndx) = val_attr | push_attr;
	        tree_var.flags (tree.entryndx) =
		   tree_var.flags (tree.entryndx) | push_attr;
	        tree_var.num_loc (tree.entryndx) -> stack_box.numval = numval;
	     end;

	  if shared.bug_mode | dt_sw
	  then
	     do;

	        if bool (tree_var.flags (tree.entryndx), hspace_attr, "0001"b)
		   ^= "0"b
	        then
		 do;
		    val_key = "hspc";
		    val_scale = 12000;
		 end;

	        else
		 do;
		    val_key = "unscl";
		    val_scale = 1000;
		 end;

	        call ioa_ ("^5x(update_symbol: ^d|^d ^a numeric(^a)/^a ^f)",
		   tree.areandx, tree.entryndx, symbol, val_key,
		   substr (mode_string,
		   2 * tree_var.mode (tree.entryndx) + 1, 2),
		   round (
		   dec (round (divide (numval, val_scale, 31, 11), 10), 11,
		   4), 3));
	     end;
         end;

      return;

      dcl dt_sw	     bit (1) static init ("0"b);
dtn:
   entry;
      dt_sw = "1"b;
      return;
dtf:
   entry;
      dt_sw = "0"b;
      return;
%page;
%include comp_entries;
%include comp_fntstk;
%include comp_page;
%include comp_shared;
%include comp_stack_box;
%include comp_text;
%include comp_tree;
%include comp_varattrs;
%include compstat;

   end comp_update_symbol_;




		    comp_use_ref_.pl1               04/23/85  1059.2rew 04/23/85  0910.5      326349



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

/* compose subroutine to evaluate symbol references */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_use_ref_:
  proc (buffer, art_flag, text_ref, a_info_ptr);

/* PARAMETERS */

    dcl buffer	   char (*) var;	/* buffer to be evaluated */
    dcl af_string_type fixed bin;
    dcl art_flag	   bit (1);	/* 1 = buffer contains artwork */
    dcl text_ref	   bit (1);	/* 1= text will be placed */
    dcl a_info_ptr	   ptr;		/* info structure for buffer */

/* LOCAL STORAGE */

    dcl arg_count	   fixed bin;
    dcl argct	   fixed bin;	/* to count i for Argi */
    dcl argno	   fixed bin;	/* which Arg for Argi reference */
    dcl argstr	   char (1020) var; /* local copy of Args */
    dcl add_text	   bit (1) aligned; /* text addition flag for ctls */
    dcl af_name	   char (32);	/* active function name */
    dcl bin_value	   fixed (35) based;/* for display of binaries */
    dcl CREATE	   bit (1) static options (constant) init ("1"b);
    dcl dbl_delim	   char (2);	/* double symbol delimiter */
				/* dir for given insert pathnames */
    dcl dirname	   char (168) init ("");
    dcl ercd	   fixed bin (35);
    dcl fxbin_value	   fixed bin (31);	/* for display of binaries */
    dcl (i, j, k, l, m, n)
		   fixed;		/* working index */
    dcl junk_str	   char (128) var;
    dcl label_value	   label based;	/* for functions */
    dcl left	   fixed (35) init (1);
				/* position of delim opener */
    dcl local_string   char (1020) varying;
				/* for string functions */
    dcl locater	   ptr;		/* points to value to be displayed */
    dcl LOG	   fixed bin static options (constant) init (1);
    dcl lrepl	   fixed bin (35);	/* length of replace */
    dcl lreplchar	   fixed bin (35);	/* length of replchar string */
    dcl mode	   fixed bin;	/* conversion mode for *c constructs */
    dcl myname	   char (8) init ("use_ref_")
				/* so we can get a pointer */
		   static options (constant);
    dcl nextchar	   char (1);	/* char following an <expr> */
    dcl NUM	   fixed bin static options (constant) init (2);
    dcl pageno_str	   char (32) var;	/* for PageNo */
    dcl qt_found	   bit (1);	/* 1= closing quote found */
    dcl 1 rd_bfr,			/* to catch data from user_input */
	2 len	   fixed (35) init (0),
	2 str	   char (120) init ("");
    dcl rd_bfr_ptr	   ptr;
    dcl rd_buffer	   char (120) varying based (rd_bfr_ptr);
    dcl replace	   char (1020) var; /* replacement string */
    dcl replchar	   char (20) varying init ("");
				/* replacement for hex & oct */
    dcl right	   fixed (35);	/* position of delim closer */
    dcl 1 save_ctl	   aligned like text_entry;
				/* to process embedded controls */
    dcl save_ctl_line  char (1020) var; /* for embedded controls */
    dcl tsymb	   char (32);	/* testing symbol */
    dcl zero	   fixed bin (35) static options (constant) init (0);
				/* for function returns */

    dcl (abs, addr, before, char, collate, copy, divide, fixed, hbound, index,
        length, ltrim, max, mod, null, rtrim, substr, unspec, verify)
		   builtin;

    dcl (active_function_error, comp_abort)
		   condition;
    dcl error_table_$null_brackets
		   ext static fixed (35);

    dcl com_err_	   entry options (variable);
    dcl cu_$evaluate_active_string
		   entry (ptr, char (*), fixed bin, char (*) var,
		   fixed bin (35));
    dcl expand_pathname_
		   entry (char (*), char (*), char (*), fixed (35));
    dcl find_condition_info_
		   entry (ptr, ptr, fixed (35));
    dcl hcs_$make_ptr  entry (ptr, char (*), char (*), ptr, fixed (35));
    dcl ioa_$rsnnl	   entry options (variable);
    dcl iox_$get_line  entry (ptr, ptr, fixed (35), fixed (35), fixed (35));

    dbl_delim = copy (shared.sym_delim, 2);
    rd_bfr_ptr = addr (rd_bfr);

    if shared.bug_mode
    then call ioa_ ("use_ref: ""^a""", comp_util_$display (buffer, 0, "0"b));

delim_loop:			/* if more in the buffer */
    if left <= length (buffer)	/* find a delimiter */
    then i = search (substr (buffer, left), shared.sym_delim || DC1);
    else i = 0;

    if i > 0			/* if one was found */
    then
      do;
        left = left + i - 1;		/* set its position */

        if index (substr (buffer, left), DC1) = 1
        then
	do;
	  DCxx_p = addr (substr (buffer, left));
	  left = left + 3 + dcxx.leng;
	  goto delim_loop;
	end;

        if left > 1			/* if its escaped */
        then if (index (substr (buffer, left - 1), "*%") = 1
	        | index (substr (buffer, left - 1), "ż%") = 1)
	   then if left = 2 | left > 2 & substr (buffer, left - 2, 2) ^= "**"
	        then
		do;		/* step over it */
		  left = left + 1;	/* and go look for another */
		  goto delim_loop;
		end;
test_dbl:
        if left < length (buffer)	/* if not last buffer char */
        then if substr (buffer, left, 2) = dbl_delim
	   then			/* if its a double */
	     do;			/* remove one delim */
	       buffer =
		  substr (buffer, 1, left) || substr (buffer, left + 2);
	       left = left + 1;	/* and step over it */
	       goto delim_loop;	/* go do it again */
	     end;

        right = 0;			/* set up for closer search loop */
find_closer:			/* look for a delimiter */
        j = index (substr (buffer, left + right + 1), shared.sym_delim);

        if j = 0			/* if none was found */
        then
	do;
	  if substr (buffer, left - 1, 2) ^= dbl_delim
	  then
	    do;			/* if previous delim is not doubled */
	      call comp_report_ (2, 0, "Unpaired symbol delimiter.",
		 a_info_ptr, buffer);
				/* set it to NUL to prevent loop */
	      substr (buffer, left, 1) = "";
	    end;
	  else left = left + 1;	/* step past 2nd of doubled delim */
	  goto delim_loop;		/* and start over */
	end;			/**/
				/* found one, if its escaped */
        else if substr (buffer, left + right + j - 1, 1) = "*"
	   & substr (buffer, left + right + j - 2, 2) ^= "**"
        then
	do;
	  right = right + j;	/* count space scanned */
	  goto find_closer;		/* and go look for another */
	end;

        else
	do;
	  right = right + j;	/* this one appears to be the closer */

/* evaluation */
	  if substr (buffer, left + 1, 1) = "{"
	  then call eval_expr;	/**/
				/* EVAL closer */
	  else if substr (buffer, left + right - 1, 1) = "}"
	  then
	    do;
	      left = left + right;
	      goto delim_loop;
	    end;

/* active function */
	  else if index (substr (buffer, left + 1), "[") = 1
	       | index (substr (buffer, left + 1), "|[") = 1
	       | index (substr (buffer, left + 1), "||[") = 1
	  then call act_fcn;	/**/
				/* AF closer */
	  else if index (substr (buffer, left + right - 1), "]") = 1
	  then
	    do;
	      left = left + right;
	      goto delim_loop;
	    end;

/* device control strings */
	  else if substr (buffer, left + 1, 1) = "("
	  then
	    do;

/* An embedded device control of the form "foo arg1 arg2 ... argn".
   "foo" must be looked up in the device table for a replacment string,
   possibly involving the arg's, and a support routine entry variable. */

	    end;			/**/
				/* device control closer */
	  else if substr (buffer, left + right - 1, 1) = ")"
	  then
	    do;
	      left = left + right;
	      goto delim_loop;
	    end;

/* embedded control */
	  else if substr (buffer, left + 1, 1) = "."
	  then call embed_ctl;

/* straight substitution */
	  else			/* else a simple variable evaluation */
	    do;			/* extract name and search tree */
	      if index (substr (buffer, left + 1, right - 1), " ") ^= 0
	      then
	        do;
		call comp_report_ (2, 0, "Invalid symbol reference.",
		     a_info_ptr, buffer);
		buffer =
		     substr (buffer, 1, left - 1)
		     || substr (buffer, left + 1 + right);
		goto delim_loop;
	        end;

	      tsymb = substr (buffer, left + 1, right - 1);
	      call comp_util_$search_tree (tsymb, ^CREATE);
	      tree_var_ptr = tree.var_ptr (tree.areandx);

	      if tree.entryndx = 0	/* undefined are null strings */
	      then
	        do;		/* check valid argument reference */
		if tsymb ^= "Arg" & tsymb ^= "ArgCount"
		     & index (tsymb, "Arg") = 1
		     & verify (rtrim (substr (tsymb, 4)), "0123456789") = 0
		then
		  do;		/* how manys Args for this call? */
		    arg_count =
		         divide (tree.var_ptr (1)
		         -> tree_var.num_loc (arg_count_symb_index)
		         -> stack_box.numval, 1000, 17, 0);
				/* which one? */
		    argno = bin (rtrim (substr (tsymb, 4)));
				/* dont have this one */
		    if argno > arg_count
		    then goto invalid_arg;
				/* ref to a valid Argi */
		    else
		      do;
		        call get_argi;
		        goto repl_str;
		      end;
		  end;

		else
		  do;
invalid_arg:
		    call comp_report_$ctlstr (2, 0, a_info_ptr, buffer,
		         "Variable ""^a"" undefined for this reference.",
		         rtrim (tsymb));
		    buffer =
		         substr (buffer, 1, left - 1)
		         || substr (buffer, left + 1 + right);
		  end;
	        end;

	      else
	        do;		/**/
				/* defined with no value */
		if tree_var.flags (tree.entryndx) = "0"b
		then
		  do;
		    buffer =
		         substr (buffer, 1, left - 1)
		         || substr (buffer, left + 1 + right);
		    lrepl = 0;
		  end;

/* numeric */
		else if OR (tree_var.flags (tree.entryndx), numeric_attr)
		then call numerics;

/* string */
		else if OR (tree_var.flags (tree.entryndx), string_attr)
		then
		  do;
		    if OR (tree_var.flags (tree.entryndx), function_attr)
		    then locater = use_fcn ();
		    else if OR (tree_var.flags (tree.entryndx), push_attr)
		    then locater =
			    addr (tree_var.num_loc (tree.entryndx)
			    -> stack_box.txtstr);
		    else locater = tree_var.str_loc (tree.entryndx);

		    replace = locater -> txtstr;
repl_str:
		    lrepl = length (replace);
		    if left + right + 1 <= length (buffer)
		    then buffer =
			    substr (buffer, 1, left - 1) || replace
			    || substr (buffer, left + 1 + right);
		    else buffer = substr (buffer, 1, left - 1) || replace;
		  end;

/* flag */
		else if OR (tree_var.flags (tree.entryndx), flag_attr)
		then
		  do;
		    if OR (tree_var.flags (tree.entryndx), function_attr)
		    then locater = use_fcn ();
		    else locater = tree_var.flag_loc (tree.entryndx);

		    if locater -> flag_value
		    then replace = "T";
		    else replace = "F";

		    lrepl = length (replace);
		    buffer =
		         substr (buffer, 1, left - 1) || replace
		         || substr (buffer, left + 1 + right);
		  end;

		if tsymb = "Eqcnt"
		then shared.eqn_refct = shared.eqn_refct + 1;
		left = left + lrepl;
	        end;
	    end;
	end;
        goto delim_loop;
      end;

return_:				/* process escapes? */
    if text_ref & index (buffer, "*") ^= 0
    then call comp_util_$escape (buffer, a_info_ptr);

    if shared.bug_mode
    then call ioa_ ("^5x(use_ref: ^d ""^a"")", length (buffer),
	    comp_util_$display (buffer, 0, "0"b));

    return;
%page;
/* evaluate %{<expr>}% */
eval_expr:
  proc;

    dcl exprtyp	   fixed bin;	/* <expr> type */
    dcl nxtcndx	   fixed bin (21);	/* position of nextchar */
    dcl resattr	   bit (9);	/* attribute of numeric result */
    dcl resnum	   fixed bin (31);	/* numeric result */
    dcl reslog	   bit (1);	/* logical result */

    if substr (buffer, left + right - 1, 1) = "}"
    then
      do;
        nxtcndx = left + 1;
        call comp_expr_eval_ (buffer, nxtcndx, a_info_ptr, 0, exprtyp, reslog,
	   resnum, replace, resattr, 0);

        if exprtyp = LOG		/* logical result? */
        then if reslog
	   then replace = "T";
	   else replace = "F";

        if exprtyp = NUM		/* numeric result? */
        then
	do;
	  if OR ((resattr), hspace_attr)
	  then resnum = divide (1000 * resnum, shared.EN_width, 31, 10);
				/* vertical space? */
	  else if OR ((resattr), vspace_attr)
	  then resnum = divide (1000 * resnum, 12000, 31, 10);

	  replace = rtrim (comp_util_$num_display (addr (resnum), 0), ".");
	end;

        if nxtcndx ^= 0 & nxtcndx <= length (buffer)
        then
	do;
	  nextchar = substr (buffer, nxtcndx, 1);
	  if nxtcndx ^= 0		/* 0 -> somebody already complained  */
	       & nextchar ^= "}"
	  then
	    do;			/* didn't use up whole expr	       */
	      if nextchar = ")"
	      then call comp_report_ (2, 0, "Extra right parenthesis.",
		      a_info_ptr, buffer);
	      else call comp_report_ (2, 0, "Improper expression.",
		      a_info_ptr, buffer);
				/* This can't happen?      */
	    end;
	end;

        buffer =
	   substr (buffer, 1, left - 1) || replace
	   || substr (buffer, left + right + 1);
        goto delim_loop;
      end;

    else
      do;				/* %{ at left nested or has vars */
        left = left + right;
        goto test_dbl;
      end;
  end eval_expr;
%page;
/* evaluate %[<active_string>]% */
act_fcn:
  proc;

    if substr (buffer, left + right - 1, 1) = "]"
    then
      do;				/* set AF string type */
        af_string_type = index (substr (buffer, left + 1, right - 2), "[");
				/* extract AF name */
        af_name =
	   before (after (substr (buffer, left + 1, right - 2), "["), " ");
				/* if path, expand it */
        if search (af_name, "<>") ^= 0
        then
	do;
	  call expand_pathname_ (af_name, dirname, af_name, ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_ (2, ercd,
		 "Expanding given active function pathname.", a_info_ptr,
		 (af_name));
	      goto af_done;
	    end;
	end;

        if dirname = ""		/* if not a path, search & initiate */
        then
	do;
	  call hcs_$make_ptr (addr (myname), af_name, "", null (), ercd);
	  if ercd ^= 0
	  then
	    do;
	      call comp_report_ (2, ercd,
		 "Initiating active function " || rtrim (af_name),
		 a_info_ptr, buffer);
	      goto af_done;
	    end;
	end;

        j, k = 1;			/* set loop indices */
        if substr (buffer, left + right - 2, 1) = """"
        then l = 4;
        else l = 3;			/* double up escaped quotes */
        do while (j ^= 0 & k < right - l);
	j = index (substr (buffer, left + 1 + k, right - l - k + 1), "*""");

	if j > 0
	then
	  do;
	    if substr (buffer, left + j + k - 1, 2) ^= "**"
	    then
	      do;
	        buffer =
		   substr (buffer, 1, left + j + k + 1) || """"
		   || substr (buffer, left + j + k + 2);
	        j = j + 1;
	        right = right + 1;
	      end;
	    k = k + j + 1;
	  end;
        end;

        on active_function_error
	begin;
	  call find_condition_info_ (null (), addr (cond_info), ercd);

	  if ercd ^= 0		/* report any error and punt */
	  then
	    do;
	      call com_err_ (ercd, "compose",
		 "Trying to find condition frame for active "
		 || "function error at line ^d of ^a.", a_info_ptr, buffer)
		 ;
	      signal comp_abort;
	    end;

	  af_err_copy = af_err_info;	/* copy info to static */
	  af_err_info.action_flags.quiet_restart = "1"b;
	  af_err_info.print_sw = "0"b;
	  goto af_err;
	end;

        replace = "";
        cond_info.info_ptr = null ();

        call cu_$evaluate_active_string (null (),
	   substr (buffer, left + af_string_type + 1,
	   right - af_string_type - 2), af_string_type, replace, ercd);

        if ercd ^= 0
        then
	do;
	  if ercd = 100
	  then call comp_report_ (2, error_table_$null_brackets, "",
		  a_info_ptr, buffer);
	  else call comp_report_ (2, ercd, "", a_info_ptr, buffer);
	  replace = substr (buffer, left, right + 1);
	end;

af_err:
        if cond_info.info_ptr ^= null ()/* if there was an AF err */
        then
	do;
	  call comp_report_ (2, af_err_copy.status_code,
	       "Error from active function " || rtrim (af_name), a_info_ptr,
	       buffer);
	  replace = substr (buffer, left, right + 1);
	end;

        revert active_function_error;

        if length (replace) >= 2	/* strip quotes, if any */
        then if substr (replace, 1, 1) = """"
	   then replace = substr (replace, 2, length (rtrim (replace)) - 2);

        j = 1;			/* set loop indices */
        k = 0;			/* single up doubled quotes */
        do while (j ^= 0);
	j = index (substr (replace, k + 1), "*""""");

	if j > 0
	then if k = 0 | k + j > 1 & substr (replace, k + j - 1, 2) ^= "**"
	     then
	       do;
	         replace =
		    substr (replace, 1, k + j)
		    || substr (replace, k + j + 2);
	         k = k + j + 1;
	       end;
        end;

        buffer =
	   substr (buffer, 1, left - 1) || replace
	   || substr (buffer, left + right + 1);

af_done:				/* if no errors */
        if ercd = 0 & cond_info.info_ptr = null ()
        then left = left + length (replace) - 2;
        else left = left + right + 1;

        goto delim_loop;
      end;

    else
      do;				/* %[ at left nested or has vars */
        left = left + right;
        goto test_dbl;
      end;
  end act_fcn;
%page;
/* process embedded controls */
embed_ctl:
  proc;

    if shared.bug_mode
    then call ioa_ ("embed_ctl: ""^a""",
	    comp_util_$display (rtrim (substr (buffer, left + 1, right - 1)),
	    0, "0"b));

    save_ctl = ctl;			/* save current control line */
    save_ctl_line = ctl_line;
    ctl_line =			/* extract embedded control */
         rtrim (substr (buffer, left + 1, right - 1));
    replace = "";
    add_text = "0"b;
    ctl.embedded = "1"b;

    call comp_ctls_ (add_text);	/* call control processor */

    save_ctl.cur.font = ctl.cur.font;	/* propagate fonts changes */
    replace = ctl_line;		/* whatever's left */
    lrepl = length (replace);
    ctl = save_ctl;			/* restore control line */
    ctl_line = save_ctl_line;
    buffer =
         substr (buffer, 1, left - 1) || replace
         || substr (buffer, left + 1 + right);
    left = left + lrepl;
    right = lrepl;

    if shared.bug_mode
    then call ioa_ ("^5x(embed_ctl) ""^a""",
	    comp_util_$display (buffer, 0, "0"b));
  end embed_ctl;
%page;
/* numeric values */
numerics:
  proc;				/**/
				/* a function? */
    if OR (tree_var.flags (tree.entryndx), function_attr)
    then locater = use_fcn ();	/**/
				/* a stacked variable? */
    else if OR (tree_var.flags (tree.entryndx), push_attr)
    then locater = addr (tree_var.num_loc (tree.entryndx) -> stack_box.numval);
				/* just some number */
    else locater = tree_var.num_loc (tree.entryndx);
				/* horizontal space? */
    if OR (tree_var.flags (tree.entryndx), hspace_attr)
    then fxbin_value = divide (1000 * locater -> bin_value, 7200, 31, 10);
				/* vertical space? */
    else if OR (tree_var.flags (tree.entryndx), vspace_attr)
    then fxbin_value = divide (1000 * locater -> bin_value, 12000, 31, 10);
				/* unscaled numeric? */
    else if OR (tree_var.flags (tree.entryndx), unscaled_attr)
    then fxbin_value = locater -> bin_value;
				/* binary */
    else fxbin_value = 1000 * locater -> bin_value;

    locater = addr (fxbin_value);

    if tree_var.mode (tree.entryndx) <= 7
    then
      do;
        replace =
	   comp_util_$num_display (locater, (tree_var.mode (tree.entryndx)));
        lrepl = length (replace);
      end;

    else
      do;
        call comp_report_ (2, 0,
	   "Bad display mode index for" || before (tsymb, " "), a_info_ptr,
	   buffer);
        goto delim_loop;
      end;

    buffer =
         substr (buffer, 1, left - 1) || replace
         || substr (buffer, left + 1 + right);

    if OR (tree_var.flags (tree.entryndx), counter_attr)
    then
      do;
        tree_var.num_loc (tree.entryndx) -> num_value =
	   tree_var.num_loc (tree.entryndx) -> num_value
	   + tree_var.incr_loc (tree.entryndx) -> num_value;
        if shared.bug_mode
        then call ioa_ ("^-(^a = ^f)", tsymb,
	        tree_var.num_loc (tree.entryndx) -> num_value);
      end;
  end numerics;
%page;
get_argi:
  proc;

    tree.areandx = 1;
    tree_var_ptr = tree.var_ptr (1);
    tree.entryndx = arg_count_symb_index + 1;
    argstr = tree_var.num_loc (tree.entryndx) -> stack_box.txtstr;

    do argct = 1 to argno;		/* find the one wanted */
      if index (argstr, """") = 1	/* if quoted */
      then
        do;
	i = 2;			/* look for closer */
	qt_found = "0"b;

	do while (^qt_found);
	  j = index (substr (argstr, i), """");
	  if j = 0		/* no more quotes in string */
	  then
	    do;
	      call comp_report_ (2, 0, "Missing string delimiter.",
		 addr (ctl.info), ctl_line);
	      qt_found = "1"b;
	      argstr = "";		/* to exit the loops */
	    end;

	  else if i + j > 3		/* found a quote */
	  then
	    do;			/* is it protected? */
	      if substr (argstr, i + j - 2, 1) = "*"
		 & substr (argstr, i + j - 3, 2) ^= "**"
		 & substr (argstr, i + j - 3, 2) ^= "ż*"
	      then i = i + j;	/* yes, keep going */

	      else
	        do;		/* found the closer */
		qt_found = "1"b;
		if argct < argno
		then argstr = ltrim (substr (argstr, i + j));
		else argstr = substr (argstr, 2, i + j - 3);
	        end;
	    end;

	  else
	    do;			/* found the closer */
	      qt_found = "1"b;
	      if argct < argno
	      then argstr = ltrim (substr (argstr, i + j));
	      else argstr = substr (argstr, 2, i + j - 3);
	    end;
	end;
        end;

      else if argct < argno		/* not quoted */
      then argstr = ltrim (after (argstr, " "));
      else argstr = before (argstr, " ");
    end;

    replace = argstr;
  end get_argi;
%page;
OR:
  proc (flag1, flag2) returns (bit (1));

    dcl flag1	   bit (9) aligned;
    dcl flag2	   bit (9);

    dcl bool	   builtin;

    return (bool (flag1, flag2, "0001"b) ^= "0"b);

  end OR;
%page;
use_fcn:
  proc returns (ptr);

    dcl align_modes	   (6) char (8) varying static options (constant)
		   init ("inside", "outside", "left", "center", "right",
		   "both");	/**/
				/* info structure for LineInput */
    dcl 1 call_info	   like text_entry.info;
    dcl false	   bit (1) static options (constant) init ("0"b);
    dcl (ii, jj)	   fixed bin;	/* working index */
    dcl null_str	   char (1) varying static options (constant) init ("");
    dcl pageno_adj	   fixed bin;
    dcl true	   bit (1) static options (constant) init ("1"b);

    dcl comp_error_table_$syntax_error
		   ext fixed bin (35);
    dcl comp_error_table_$usage_error
		   ext fixed bin (35);

/* assign values to function labels */
    tree.align_mode = align_mode;
    tree.art_mode = art_mode;
    tree.block_index = block_index;
    tree.block_name = block_name;
    tree.bottom_margin = bottom_margin;
    tree.calling_file_name = calling_file;
    tree.callers_lineno = callers_line;
    tree.devclass = devclass;
    tree.devname = devname;
    tree.dot_addltr = dot_addltr;
    tree.equation_mode = eqn_mode;
    tree.fill_mode = fill_mode;
    tree.fontname = fontname;
    tree.footer_margin = footer_margin;
    tree.frontpage = frontpage;
    tree.header_margin = header_margin;
    tree.head_space = headspace;
    tree.keep_mode = keep_mode;
    tree.left_indent = left_indent;
    tree.left_undent = left_undent;
    tree.line_input = lineinput;
    tree.linesleft = linesleft;
    tree.linespace = linespace;
    tree.measure_bif = measure;
    tree.next_pageno = next_pageno;
    tree.pagecount = pagecount;
    tree.pagelines = pagelines;
    tree.page_length = pagelength;
    tree.pageno = pageno;
    tree.pointsize = pointsize;
    tree.right_indent = right_indent;
    tree.right_undent = right_undent;
    tree.symbol_delimiter = symdelim;
    tree.text_depth = text_depth;
    tree.text_lineno = text_lineno;
    tree.text_width = text_width;
    tree.top_margin = top_margin;
    tree.title_delimiter = ttldelim;
    tree.trans = tr_tab;
    tree.userinput = user_input;

    if tree_var.num_loc (tree.entryndx) = null ()
    then
      do;
        call comp_report_ (2, 0,
	   "An unknown compose function reference has been encountered.",
	   a_info_ptr, buffer);
        goto return_;
      end;

    goto tree_var.num_loc (tree.entryndx) -> label_value;

align_mode:
    if shared.blkptr = null ()
    then
      do;
        if current_parms.quad & quadi
        then return (addr (align_modes (1)));
        else if current_parms.quad & quado
        then return (addr (align_modes (2)));
        else if current_parms.quad & quadl
        then return (addr (align_modes (3)));
        else if current_parms.quad & quadc
        then return (addr (align_modes (4)));
        else if current_parms.quad & quadr
        then return (addr (align_modes (5)));
        else if current_parms.quad & just
        then if current_parms.fill_mode
	   then return (addr (align_modes (6)));
	   else return (addr (align_modes (3)));
        else return (addr (align_modes (3)));
      end;
    else
      do;
        if text.parms.quad & quadi
        then return (addr (align_modes (1)));
        else if text.parms.quad & quado
        then return (addr (align_modes (2)));
        else if text.parms.quad & quadl
        then return (addr (align_modes (3)));
        else if text.parms.quad & quadc
        then return (addr (align_modes (4)));
        else if text.parms.quad & quadr
        then return (addr (align_modes (5)));
        else if text.parms.quad & just
        then if text.parms.fill_mode
	   then return (addr (align_modes (6)));
	   else return (addr (align_modes (3)));
        else return (addr (align_modes (3)));
      end;

art_mode:
    if shared.blkptr = null
    then return (addr (current_parms.art));
    else return (addr (text.parms.art));

block_index:
    if shared.blkptr ^= null ()
    then return (addr (text.blkndx));
    else return (addr (zero));

block_name:
    if shared.blkptr ^= null ()
    then return (addr (text.hdr.name));
    else return (addr (null_str));

bottom_margin:
    return (addr (page.parms.margin.bottom));

calling_file:
    if call_stack.index = 0
    then local_string = "";
    else local_string =
	    call_stack.ptr (call_stack.index - 1) -> call_box.refname;
    return (addr (local_string));

callers_line:
    if call_stack.index = 0		/* command input file? */
    then return (addr (zero));
    else return (
	    addr (call_stack.ptr (call_stack.index - 1)
	    -> call_box.exit_lineno));

devclass:
    local_string = rtrim (comp_dvt.devclass);
    return (addr (local_string));

devname:
    local_string = rtrim (comp_dvid.devname);
    return (addr (local_string));

dot_addltr:
    local_string = page.hdr.dot_addltr;
    return (addr (local_string));

eqn_mode:
    if shared.blkptr = null ()
    then return (addr (false));
    else return (addr (false));

fill_mode:
    if shared.blkptr = null ()
    then return (addr (current_parms.fill_mode));
    else return (addr (text.parms.fill_mode));

fontname:
    if shared.blkptr = null
    then local_string =
	    current_parms.fntstk.entry (current_parms.fntstk.index).name;
    else local_string = text.parms.fntstk.entry (text.parms.fntstk.index).name;
    return (addr (local_string));

footer_margin:
    return (addr (page.parms.margin.footer));

frontpage:
    if page.hdr.headed		/* is the page headed? */
    then return (addr (page.hdr.frontpage));
    else if page.hdr.frontpage
    then return (addr (false));
    else return (addr (true));

/*    else
/*      do;				/* page isnt headed */
/*        if page.hdr.dot_addltr = PAD & shared.dot_add_letter = PAD
/*	   & ^page.hdr.blankpage
/*        then if mod (shared.pagenum.nmbr (shared.pagenum.index), 2000) = 1000
/*	   then return (addr (true));
/*	   else return (addr (false));
/*        else if page.hdr.frontpage
/*        then return (addr (false));
/*        else return (addr (true));
/*      end;*/

header_margin:
    return (addr (page.parms.margin.header));

headspace:
    return (addr (col.hdr.pspc));

keep_mode:
    if shared.blkptr = null
    then return (addr (current_parms.keep));
    else return (addr (text.parms.keep));

left_indent:
    if shared.blkptr = null
    then return (addr (current_parms.left.indent));
    else return (addr (text.parms.left.indent));

left_undent:
    if shared.blkptr = null
    then return (addr (current_parms.left.undent));
    else return (addr (text.parms.left.undent));

lineinput:
    if call_stack.index = 0
    then
      do;
        call comp_report_$ctlstr (2, comp_error_table_$usage_error, a_info_ptr,
	   buffer,
	   "The LineInput builtin may not be used"
	   || " in a command line file.");
        return (addr (null_str));
      end;

    call_info.fileno =		/* callers insert index */
         insert_data.ptr (insert_data.index) -> insert.thrb;
				/* callers stack entry */
    call_box_ptr = call_stack.ptr (call_stack.index - 1);
    call_info.lineno = call_box.exit_lineno;
				/* fetch the line */
    call comp_read_$line (call_box_ptr, replace, "0"b);
				/* protect trigger chars */
    ii, jj = 1;			/* asterisks first */
    do while (ii <= length (replace) & jj > 0);
      jj = index (substr (replace, ii), "*");
      if jj > 0
      then
        do;
	ii = ii + jj + 1;
	replace =
	     substr (replace, 1, ii - 3) || "*" || substr (replace, ii - 2);
        end;
    end;

/*      ii, jj = 1;			/* symbol delimiters */
/*      do while (ii <= length (replace) & jj > 0);
/*         jj = index (substr (replace, ii), shared.sym_delim);
/*         if jj > 0
/*         then
/*	  do;
/*	     ii = ii + jj + 1;
/*	     replace =
/*	        substr (replace, 1, ii - 3) || "*"
/*	        || substr (replace, ii - 2);
/*	  end;
/*      end;*/

    ii, jj = 1;			/* quotes */
    do while (ii <= length (replace) & jj > 0);
      jj = index (substr (replace, ii), """");
      if jj > 0
      then
        do;
	ii = ii + jj + 1;
	replace =
	     substr (replace, 1, ii - 3) || "*" || substr (replace, ii - 2);
        end;
    end;				/**/
				/* update callers exit line number */
    call_box.exit_lineno = call_box.exit_lineno + 1;

    return (addr (replace));

linesleft:
    if page.hdr.col_index > 0
    then fxbin_value = col.hdr.net - col.hdr.used - col.hdr.ftn.usd;
    else fxbin_value = page.hdr.net - page.hdr.used - col0.hdr.ftn.usd;

    if shared.blkptr ^= null ()
    then
      do;
        fxbin_value = fxbin_value - text.hdr.used - text.hdr.ftn.usd;
        if length (text.input_line) > 0
        then fxbin_value = fxbin_value - text.input.linespace;
        if text.parms.hdrptr ^= null ()
        then fxbin_value = fxbin_value - text.parms.hdrptr -> hfcblk.hdr.used;
        if text.parms.ftrptr ^= null ()
        then fxbin_value = fxbin_value - text.parms.ftrptr -> hfcblk.hdr.used;
      end;

    return (addr (fxbin_value));

linespace:
    if shared.blkptr = null ()
    then return (addr (current_parms.linespace));
    else return (addr (text.parms.linespace));

measure:
    return (null ());

next_pageno:
    return (addr (shared.next_pagenmbr));

pagecount:
    if page.hdr.used > 0
    then fxbin_value = 1;
    else fxbin_value = 0;

    if shared.blkptr ^= null
    then if text.hdr.used > 0
         then fxbin_value = 1;

    fxbin_value = fxbin_value + shared.pagecount;

    return (addr (fxbin_value));

pagelines:
    if page.hdr.col_index > 0
    then fxbin_value = col.hdr.used;
    else fxbin_value = page.hdr.used;

    if shared.blkptr ^= null ()
    then
      do;
        fxbin_value = fxbin_value + text.hdr.used;
        if length (text.input_line) > 0
        then fxbin_value = fxbin_value + text.input.linespace;
      end;

    return (addr (fxbin_value));

pagelength:
    return (addr (page.parms.length));

pageno:
    local_string, junk_str = "";

    if ^page.hdr.headed		/* no header yet? */
    then
      do;
        call comp_util_$pageno (1000, local_string);
        call comp_util_$pageno (-1000, junk_str);
        return (addr (local_string));
      end;

    else if shared.blkptr ^= null	/* for page hdrs/ftrs */
    then if text.parms.page
         then return (addr (page.hdr.pageno));

    pageno_adj = 0;			/* preset to zero */
    pageno_str = "";
    if page.parms.cols.count = 0	/* do only if 0 columns */
    then
      do;
        if shared.blkptr ^= null	/* is there a text block? */
        then
	do;
	  pageno_adj =
	       1000
	       *
	       divide (col0.hdr.used + shared.picture.space
	       +
	       max (text.hdr.used, text.parms.linespace * shared.widow_size),
	       col0.hdr.net, 31, 0);

	  if text.parms.hdrptr ^= null ()
	  then pageno_adj =
		  pageno_adj
		  + 1000
		  *
		  divide (
		  max (text.parms.hdrptr -> hfcblk.hdr.used,
		  text.parms.hdrptr -> hfcblk.parms.linespace
		  * shared.widow_size), col0.hdr.net, 31, 0);
	end;

        else if col0.hdr.used + shared.picture.space > col0.hdr.net
        then pageno_adj =
	        1000
	        *
	        divide (col0.hdr.used + shared.picture.space, col0.hdr.net,
	        31, 0);

        else if ^page.hdr.headed	/* next page if this */
        then pageno_adj = 1000;	/* page isnt headed */
      end;

    call comp_util_$pageno (pageno_adj, pageno_str);

    if pageno_adj > 0
    then shared.pagenum.nmbr (shared.pagenum.index) =
	    shared.pagenum.nmbr (shared.pagenum.index) - pageno_adj;

    return (addr (pageno_str));

pointsize:
    if shared.blkptr = null
    then return (
	    addr (current_parms.fntstk.entry (current_parms.fntstk.index)
	    .size));
    else return (addr (text.parms.fntstk.entry (text.parms.fntstk.index).size))
	    ;

right_indent:
    if shared.blkptr = null
    then return (addr (current_parms.right.indent));
    else return (addr (text.parms.right.indent));

right_undent:
    if shared.blkptr = null
    then return (addr (current_parms.right.undent));
    else return (addr (text.parms.right.undent));

symdelim:
    local_string = shared.sym_delim;
    return (addr (local_string));

text_depth:
    if page.hdr.col_index > 0
    then fxbin_value = col.hdr.used + col.hdr.ftn.usd;
    else fxbin_value = page.hdr.used + col0.hdr.ftn.usd;

    if shared.blkptr ^= null ()
    then
      do;
        fxbin_value = fxbin_value + text.hdr.used + text.hdr.ftn.usd;
        if length (text.input_line) > 0
        then fxbin_value = fxbin_value + text.input.linespace;
        if text.parms.hdrptr ^= null ()
        then fxbin_value = fxbin_value + text.parms.hdrptr -> hfcblk.hdr.used;
        if text.parms.ftrptr ^= null ()
        then fxbin_value = fxbin_value + text.parms.ftrptr -> hfcblk.hdr.used;
      end;

    return (addr (fxbin_value));

text_lineno:
    fxbin_value = ctl.info.lineno;
    return (addr (fxbin_value));

text_width:
    if shared.blkptr ^= null ()
    then return (addr (text.parms.measure));
    else return (addr (current_parms.measure));

top_margin:
    return (addr (page.parms.margin.top));

ttldelim:
    local_string = shared.ttl_delim;
    return (addr (local_string));

tr_tab:
    local_string = "";
    do i = 1 to length (shared.trans.in);
      local_string =
	 local_string || substr (shared.trans.in, i, 1)
	 || substr (shared.trans.out, i, 1);
    end;
    return (addr (local_string));

user_input:
    rd_buffer = "";			/* insert from terminal input */
    call iox_$get_line (iox_$user_input, addr (rd_bfr.str), 120, rd_bfr.len,
         ercd);
    if ercd ^= 0
    then call comp_report_ (2, ercd, "Reading from user_input", a_info_ptr,
	    buffer);
    rd_buffer = before (rd_buffer, NL);
    return (rd_bfr_ptr);

use_abort_:
  end use_fcn;
%page;
%include comp_column;
%include comp_DCdata;
%include comp_entries;
%include comp_fntstk;
%include comp_insert;
%include comp_metacodes;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_stack_box;
%include comp_text;
    dcl 1 info	   like text_entry.info based (a_info_ptr);
    dcl 1 af_err_copy  static like af_err_info;
    dcl 1 af_err_info  based (cond_info.info_ptr),
	2 hdr	   like condition_info_header,
	2 name_ptr   ptr,
	2 name_lth   fixed,
	2 errmsg_ptr ptr,
	2 errmsg_lth fixed,
	2 max_errmsg_lth
		   fixed,
	2 print_sw   bit (1);
%include condition_info_header;
    dcl 1 cond_info	   static like condition_info;
%include condition_info;
%include comp_dvid;
%include comp_dvt;
%include comp_tree;
%include comp_varattrs;
%include compstat;

  end comp_use_ref_;




		    comp_util_.pl1                  04/23/85  1059.2rew 04/23/85  0910.7      584892



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

/* quickie utility routines for compose */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_util_:
  proc;				/* no entry at main level */

/* GLOBAL PARAMETERS */

    dcl (
        blkptr	   ptr,		/* pointer to target block */
        blktype	   char (2) aligned,/* block use */
        blk_parms_ptr  ptr,		/* initial parms for block */
        empty	   bit (1),	/* 1= dont get storage for block */
        esc_flag	   bit (1),	/* 1 = process escapes */
        icol	   fixed bin,	/* -1 if NOT a column block */
        line_ptr	   ptr,		/* -> line to be added or replaced */
        meas_sw	   bit (1),	/* 1 = measure the text */
        oflo	   bit (1),	/* overflow switch */
        repltxtptr	   ptr,		/* pointer to new text */
        symbol	   char (32),	/* variable to be pushed */
        trflag	   bit (1)	/* 1 = translate the text */
        )		   parameter;

/* LOCAL STORAGE */

    dcl abrt_sw	   bit (1) static init ("0"b);
    dcl art_cbar_line  char (1020) var static init (" ");
    dcl art_cbar_space fixed bin (31);	/* for multiline art and cbars */
    dcl art_cbar_sw	   bit (1);	/* for multiline art and cbars */
    dcl 1 blk_parms	   aligned like default_parms based (blk_parms_ptr);
    dcl 1 block			/* the target block */
		   aligned like text based (blkptr);
    dcl char_index	   fixed;		/* scanning index for *c constructs */
    dcl colblkndx	   fixed;		/* column data index for block */
    dcl coldepth	   fixed bin (31);	/* for debug */
    dcl collft	   fixed bin (31);	/* column space left */
    dcl cmode	   fixed bin;	/* conversion mode for *c */
    dcl CREATE	   bit (1) static options (constant) init ("1"b);
    dcl (i, k, l, m)   fixed bin;
    dcl len	   fixed bin;	/* length of digit string for *c */
    dcl 1 line	   aligned like text_entry based (line_ptr);
    dcl locolptr	   ptr;		/* for local reference */
    dcl 1 locol	   aligned like col based (locolptr);
    dcl loc_lead	   fixed bin (31);	/* local linespace value */
				/* for text measuring */
    dcl 1 meas1	   aligned like text_entry.cur;
    dcl 1 meas2	   aligned like text_entry.cur;
    dcl newblkptr	   ptr;		/* local block pointer */
    dcl 1 newblk	   aligned like text based (newblkptr);
    dcl 1 nullpic			/* empty picture block */
		   static options (constant),
	4 type			/* type = page/col */
		   char (4) init (""),
	4 place			/* place = top/cen/bot */
		   char (4) init (""),
	4 ptr	   ptr init (null), /* pointer to block */
	4 size			/* size of picture */
		   fixed bin (31) init (0);
    dcl rchar	   char (10) var;	/* replacement string */
    dcl ret_str	   char (8192) var;
/****dcl save_input aligned like text_entry;
/****dcl save_input_line cahr (1020) var;*/
    dcl tblcntxt	   bit (1);	/* 1= table format in context mode */
    dcl tblfillspc	   bit (1);	/* 1= table format fill space */
    dcl tbllin	   bit (1);	/* 1= adding a table line */
    dcl tdblkndx	   fixed;		/* tblkdata index for block */
    dcl tdlandx	   fixed;		/* tblkdata index for line area */
    dcl tdtandx	   fixed;		/* tblkdata index for text area */
    dcl wbuf	   char (1020) var; /* working buffer */

    dcl (addrel, bin, char, hbound, index, length, ltrim, max, min, mod, null,
        rel, rtrim, size, substr, translate)
		   builtin;
    dcl comp_abort	   condition;
%page;
getblk:				/* GET A BLOCK */
  entry (icol, blkptr, blktype, blk_parms_ptr, empty);

    if icol >= 0			/* if getting a block for a column */
    then
      do;
        locolptr = page.column_ptr (icol);
        colblkndx, locol.hdr.blkct = locol.hdr.blkct + 1;
        blkptr, locol.blkptr (colblkndx) = get_blk ();
      end;

    else blkptr = get_blk ();		/* get a loose block */

/* initialize the block */
    block.parms = blk_parms;		/* formatting parms */
    block.parms.left.undent, block.parms.right.undent = 0;
    if shared.pageblock & icol <= 0
    then
      do;
        block.parms.left.indent = 0;
        block.parms.measure = page.parms.measure;
        block.parms.page = "1"b;
      end;

    block.hdr = text_header;		/* block control stuff */
    block.hdr.art = blk_parms.art;
    block.hdr.colno = icol;
    block.hdr.tblblk = shared.table_mode;
    block.blktype = blktype;
    block.next_text = block.text_area.first -> text_area.strareaptr (1);

    block.input = text_entry;		/* initialize block input */
    block.input.ptr = addr (block.input_line);
    block.input.linespace = block.parms.linespace;
    block.input.quad = block.parms.quad;
    block.input.info = ctl.info;	/* copy ctl info */
    block.input.font, block.input.cur.font =
         block.parms.fntstk.entry (block.parms.fntstk.index);
    block.input_line = "";		/* clear the text input buffer */

    if shared.bug_mode
    then call ioa_ ("getblk: (^[col=^d^;LOOSE^s^]^[ EMPTY^] ^a ndx=^d "
	    || "fnt=^a ^f^[ K^])", (icol >= 0), icol, empty, block.blktype,
	    block.blkndx, block.input.font.name,
	    show (block.input.font.size, 1000), block.parms.keep);

get_blk:
  proc returns (ptr);

(nosubrg):			/* search for a free block */
    do tdblkndx = 1 to tblkdata.block.count
         while (^tblkdata.block.free (tdblkndx));
    end;

    if tdblkndx > tblkdata.block.count	/* dont have any */
    then
      do;
        if tblkdata.block.count = hbound (tblkdata.block.ptr, 1)
        then
	do;
	  call comp_report_ (4, 0,
	       "Implementation restriction, more than "
	       || ltrim (char (hbound (tblkdata.block.ptr, 1)))
	       || "blocks needed.", addr (ctl.info), ctl_line);
	  signal comp_abort;
	  goto return_;
	end;			/**/
				/* allocate new block */
        tdblkndx, tblkdata.block.count = tblkdata.block.count + 1;
        newblkptr, tblkdata.block.ptr (tdblkndx) =
	   allocate (const.local_area_ptr, size (text));

        unspec (newblk) = "0"b;	/* wipe it */
        newblk.blktype = "  ";
        newblk.blkndx = tdblkndx;
        newblk.line_area.first, newblk.line_area.cur = null;
        newblk.text_area.first, newblk.text_area.cur = null;
      end;

    else newblkptr = tblkdata.block.ptr (tdblkndx);

    if ^empty			/* if storage is wanted */
    then
      do;				/**/
				/* first line area */
        line_area_ptr, newblk.line_area.first, newblk.line_area.cur =
	   get_line_area (newblk.line_area.cur);
				/* first text area */
        newblk.text_area.first, newblk.text_area.cur =
	   get_text_area (newblk.text_area.cur);
      end;			/**/
				/* set up the new block */
				/* set area pointers */
    newblk.line_area.cur = newblk.line_area.first;
    newblk.text_area.cur = newblk.text_area.first;
				/* no longer free */
    tblkdata.block.free (tdblkndx) = "0"b;

    return (newblkptr);

  end get_blk;

get_line_area:
  proc (laptr) returns (ptr);

    dcl laptr	   ptr;		/* current line_area */
    dcl 1 larea	   like line_area based (laptr);

(nosubrg):			/* search for a free area */
    do tdlandx = 1 to tblkdata.line_area.count
         while (^tblkdata.line_area.free (tdlandx));
    end;				/**/
				/* dont have any */
    if tdlandx > tblkdata.line_area.count
    then
      do;
        if tblkdata.line_area.count = hbound (tblkdata.line_area.ptr, 1)
        then
	do;
	  call comp_report_ (4, 0,
	       "Implementation restriction, more than "
	       || ltrim (char (hbound (tblkdata.line_area.ptr, 1)))
	       || "line areas needed.", addr (ctl.info), ctl_line);
	  signal comp_abort;
	  goto return_;
	end;			/**/
				/* allocate new area */
        tdlandx, tblkdata.line_area.count = tblkdata.line_area.count + 1;
        line_area_ptr, tblkdata.line_area.ptr (tdlandx) =
	   allocate (const.local_area_ptr, size (line_area));
				/* set it up */
        line_area.count, line_area.ndx = 0;
        line_area.pndx = tdlandx;
        line_area.next, line_area.prev, line_area.linptr = null;
      end;

    else line_area_ptr = tblkdata.line_area.ptr (tdlandx);

    if laptr ^= null
    then larea.next = line_area_ptr;	/* set forward thread */
    line_area.prev = laptr;		/* set backward thread */
				/* no longer free */
    tblkdata.line_area.free (tdlandx) = "0"b;

    return (tblkdata.line_area.ptr (tdlandx));
  end get_line_area;

get_text_area:
  proc (taptr) returns (ptr);

    dcl taptr	   ptr;		/* current text_area */
    dcl 1 tarea	   like text_area based (taptr);

(nosubrg):			/* search for a free area */
    do tdtandx = 1 to tblkdata.text_area.count
         while (^tblkdata.text_area.free (tdtandx));
    end;				/**/
				/* dont have any */
    if tdtandx > tblkdata.text_area.count
    then
      do;
        if tblkdata.text_area.count = hbound (tblkdata.text_area.ptr, 1)
        then
	do;
	  call comp_report_ (4, 0,
	       "Implementation restriction, more than "
	       || ltrim (char (hbound (tblkdata.text_area.ptr, 1)))
	       || "text areas needed.", addr (ctl.info), ctl_line);
	  signal comp_abort;
	  goto return_;
	end;			/**/
				/* allocate new area */
        tdtandx, tblkdata.text_area.count = tblkdata.text_area.count + 1;
        text_area_ptr, tblkdata.text_area.ptr (tdtandx) =
	   allocate (const.local_area_ptr, size (text_area));

        text_area.pndx = tdtandx;	/* set it up */
        text_area.next, text_area.strareaptr = null;
        text_area.ndx = 0;
        text_area.count = 1;
        text_area.strareaptr (1) =
	   allocate (const.local_area_ptr, size (string_area));
        tblkdata.text_area.string_area_count =
	   tblkdata.text_area.string_area_count + 1;
      end;

    else text_area_ptr = tblkdata.text_area.ptr (tdtandx);

    if taptr ^= null
    then tarea.next = text_area_ptr;	/* set forward thread */
    text_area.ndx = 1;		/* make first strarea active */
				/* no longer free */
    tblkdata.text_area.free (tdtandx) = "0"b;

    return (tblkdata.text_area.ptr (tdtandx));

  end get_text_area;

    return;			/* end of getblk */
%page;
/* return a text block to the free list */

relblk:
  entry (icol, blkptr);		/**/
    if blkptr = null		/* has to be one to release! */
    then return;			/**/
				/* if returning a column block */
    if icol >= 0			/* count column blocks */
    then page.column_ptr (icol) -> col.hdr.blkct =
	    page.column_ptr (icol) -> col.hdr.blkct - 1;

    if shared.bug_mode
    then
      do;
        if icol >= 0
        then j = page.column_ptr (icol) -> col.hdr.blkct;

        call ioa_ ("util$relblk: (^d ^d ^a ^[col^d ^d^;LOOSE^2s^])",
	   block.blkndx, tblkdata.block.count, block.blktype, (icol >= 0),
	   icol, j);
      end;			/**/
				/* release line areas */
    do line_area_ptr = block.line_area.first repeat (line_area.next)
         while (line_area_ptr ^= null);
      line_area.ndx = 0;		/* no active lines */
      line_area.prev, line_area.next = null;
      tblkdata.line_area.free (line_area.pndx) = "1"b;
    end;
    block.line_area.first, block.line_area.cur = null;
				/* release text areas */
    do text_area_ptr = block.text_area.first repeat (text_area.next)
         while (text_area_ptr ^= null);
      text_area.ndx = 0;		/* no active areas */
      text_area.next = null;
      tblkdata.text_area.free (text_area.pndx) = "1"b;
    end;
    block.text_area.first, block.text_area.cur = null;
				/* block is now free */
    tblkdata.block.free (block.blkndx) = "1"b;

    blkptr = null ();		/* clear given pointer */

    return;			/* end of relblk */
%page;
add_text:				/* ADD A LINE TO A BLOCK */
  entry (blkptr, meas_sw, trflag, esc_flag, oflo, line_ptr);
				/* adding a table line? */
    if shared.table_mode & block.hdr.tblblk
    then
      do;
        tbllin = "1"b;
        tblfmtndx = tbldata.ndx;
        tblfmtptr = tbldata.fmt (tbldata.ndx).ptr;
        tblcntxt = tblfmt.context;
        tblcolndx = tblfmt.ccol;
        tblcolptr = tblfmt.colptr (tblcolndx);
      end;

    else
      do;
        tbllin = "0"b;
        tblfmtndx, tblcolndx = 0;
      end;

    if shared.bug_mode & dt_sw
    then
      do;
        call ioa_$nnl ("add_text: (^[col=^d^;LOOSE^s^] ^a=^d e^d u^f(^f) ld=^f"
	   || "^[ ftn=^d/^f^;^2s^]", (block.hdr.colno >= 0), block.hdr.colno,
	   block.blktype, block.blkndx, block.hdr.count,
	   show (block.hdr.used, 12000), show (block.hdr.trl_ws, 12000),
	   show (line.linespace, 12000), (line.ftn.ct > 0), line.ftn.ct,
	   show (line.ftn.used, 12000));

        if shared.table_mode & block.hdr.tblblk
        then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblcolndx, tblfmtndx,
	        show (tblcol.depth, 12000), show (tblfmt.maxdepth, 12000));

        call ioa_ (") ^[I^]^[O^]^[L^]^[C^]^[R^]^[J^] "
	   || "^[M^]^[E^]^[A^]^[H^]^[S^]", (line.sws.quad & quadi),
	   (line.sws.quad & quado),
	   (line.sws.quad & quadl | line.sws.quad = "0"b),
	   (line.sws.quad & quadc), (line.sws.quad & quadr),
	   (line.sws.quad & just), meas_sw, esc_flag, line.sws.art,
	   line.hanging, (unspec (line.sws.spcl) ^= "0"b));
      end;

    loc_lead = line.linespace;	/* local value */
    if ^line.sws.table
    then line.net = line.rmarg - line.lmarg;
    art_cbar_sw =
         (line.cbar.add | line.sws.art | block.parms.add | block.hdr.art);

    if art_cbar_sw			/* make individual entries */
    then
      do;
        call put_line (line_ptr, line.ptr, null, "0"b, min (loc_lead, 12000));
        line.cur.gaps, line.cur.width = 0;
        line.ftn = text_entry.ftn;
        art_cbar_space = line.linespace - min (loc_lead, 12000);

        if art_cbar_space > 12000	/* if multiline */
        then
	do while (art_cbar_space > 12000);
	  call put_line (line_ptr, addr (art_cbar_line), null, "0"b, 12000);
				/* next line */
	  loc_lead, art_cbar_space = art_cbar_space - 12000;
				/* count space */
	end;

        if art_cbar_space > 0		/* last line */
        then call put_line (line_ptr, addr (art_cbar_line), null, oflo,
	        art_cbar_space);
      end;			/**/
				/* make one entry */
    else call put_line (line_ptr, line.ptr, null, oflo, loc_lead);

    tblfillspc = "0"b;		/* force flag off */

    if page.hdr.col_index >= 0 & block.blktype ^= "fn"
    then page.hdr.depth = max (page.hdr.depth, col.hdr.depth);

return_:
    return;			/* end of add_text */
%page;
replace_text:
  entry (blkptr, meas_sw, line_ptr, repltxtptr);

    if shared.table_mode & block.hdr.tblblk
    then
      do;
        tblfmtndx = tbldata.ndx;
        tblfmtptr = tbldata.fmt (tblfmtndx).ptr;
        tblcolndx = tblfmt.ccol;
        tblcolptr = tblfmt.colptr (tblcolndx);
      end;
    else tblfmtndx, tblcolndx = 0;

    if shared.bug_mode & dt_sw
    then call ioa_ ("replace_text: (col=^d ^a=^d/^d^[ tbl=^d/^d^;^2s^]"
	    || " c^d mrg^f/^f/^f)"
	    || " ^[I^]^[O^]^[L^]^[C^]^[R^]^[J^] ^[|^]^[*^]^[A^]^[K^]^[T^]",
	    block.hdr.colno, block.blktype, block.blkndx, line.info.lineno,
	    (block.hdr.tblblk), tblcolndx, tblfmtndx,
	    length (repltxtptr -> txtstr), show (line.lmarg, 12000),
	    show (line.rmarg, 12000), show (line.net, 12000),
	    (line.sws.quad & quadi), (line.sws.quad & quado),
	    (line.sws.quad & quadl), (line.sws.quad & quadc),
	    (line.sws.quad & quadr), (line.sws.quad & just),
	    (line.cbar.mod | line.cbar.add), line.cbar.del, line.sws.art,
	    line.sws.keep, line.sws.title);

    call put_line (line_ptr, repltxtptr, line_ptr, "0"b, -1);

    return;			/* end of replace_text */
%page;
pictures:				/* place pictures that fit */
  entry (blkptr);			/**/
				/* find space remaining */
    collft = col.hdr.net - col.hdr.used - col.hdr.ftn.usd;

    if blkptr ^= null
    then collft = collft - block.hdr.used - block.hdr.ftn.usd;

    if shared.bug_mode
    then call ioa_ ("pictures: (ct=^d spc=^f lft=^f^[ galley^]^[ active^])",
	    shared.picture.count, show (shared.picture.space, 12000),
	    show (collft, 12000), option.galley_opt, (blkptr ^= null));

    if blkptr = null		/* if theres no active block, */
    then				/* dump all the pictures */
      do;
        do i = 1 to shared.picture.count;
	col.hdr.blkct = col.hdr.blkct + 1;
	col.blkptr (col.hdr.blkct) = shared.picture.ptr (i);
	col.hdr.used =
	     col.hdr.used + shared.picture.ptr (i) -> text.hdr.used;
	page.hdr.used =
	     page.hdr.used + shared.picture.ptr (i) -> text.hdr.used;
        end;

        shared.picture.blk = nullpic;	/* all gone */
        shared.picture.space, shared.picture.count = 0;
      end;			/**/
				/* put the ones that fit */
    else if shared.picture.blk (1).size <= collft
    then
      do;
/****save_input = text.input;
/****save_input_line = text.input_line;*/

        do i = 1 to shared.picture.count
	   while (shared.picture.blk (i).size <= collft | option.galley_opt);
	collft = collft - shared.picture.blk (i).size;

	do line_area_ptr =
	     shared.picture.blk (i).ptr -> block.line_area.first
	     repeat (line_area.next) while (line_area_ptr ^= null);
	  do j = 1 to line_area.ndx;
/****txtlinptr = line_area.linptr (j);
/****text.input = txtlin;
/****text.input_line =  txtlin.ptr -> txtstr;*/

	    call comp_util_$add_text (blkptr, "0"b, "0"b, "0"b, "0"b,
	         line_area.linptr (j));
	  end;
	end;

	line_area_ptr = text.line_area.cur;
	txtlinptr = line_area.linptr (line_area.ndx);
	txtlin.end_keep = "1"b;

	if shared.bug_mode
	then call ioa_ ("^-(pic=^d ^f)", i,
		show (shared.picture.ptr (i) -> text.hdr.used, 12000));

	shared.picture.space =
	     shared.picture.space - shared.picture.blk (i).size;
	call comp_util_$relblk (-1, shared.picture.blk (i).ptr);
	shared.picture.blk (i) = nullpic;
        end;

/****text.input = save_input;
/****        text.input_line = save_input_line;*/
/* clean up */
        do i = 1 to shared.picture.count
	   while (shared.picture.blk (i).ptr = null);
        end;

        if i <= shared.picture.count
        then
	do j = i to shared.picture.count;
	  shared.picture.blk (j - i + 1) = shared.picture.blk (j);
	  shared.picture.blk (j) = nullpic;
	end;

        shared.picture.count = shared.picture.count - i + 1;
      end;

    if shared.bug_mode
    then call ioa_ ("^5x(pictures: ct=^d spc=^f ^f)", shared.picture.count,
	    show (shared.picture.space, 12000),
	    show (sum (shared.picture.blk.size), 12000));

    return;			/* end of pictures */
%page;
set_net_page:			/* SET NET PAGE LENGTH */
  entry (set_current_page);

/* PARAMETER */

    dcl set_current_page		/* 1 = set current page if unheaded */
		   bit (1);

/* LOCAL STORAGE */

    dcl even_foot	   fixed bin (31);	/* even page footer size */
    dcl even_head	   fixed bin (31);	/* even page header size */
    dcl even_headspace fixed bin (31);	/* even page head space */
    dcl max_col	   fixed bin (31);	/* length of longest column */
    dcl odd_foot	   fixed bin (31);	/* odd page footer size */
    dcl odd_head	   fixed bin (31);	/* odd page header size */
    dcl odd_headspace  fixed bin (31);	/* odd page head space */
				/* clear local storage */
    even_foot, even_head, odd_foot, odd_head = 0;
    even_headspace, odd_headspace = page_parms.margin.top;
				/* preset both pages */
    page_parms.net.even, page_parms.net.odd =
         page_parms.length - page_parms.margin.top - page_parms.margin.header
         - page_parms.margin.footer - page_parms.margin.bottom;

    hfcblk_ptr = shared.epftrptr;	/* even footer? */
    if hfcblk_ptr ^= null
    then
      do;
        even_foot = hfcblk.hdr.used;
        page_parms.net.even = page_parms.net.even - even_foot;
      end;

    hfcblk_ptr = shared.ephdrptr;	/* even header? */
    if hfcblk_ptr ^= null
    then
      do;				/* if it wont fit */
        if page_parms.net.even - hfcblk.hdr.used < 0 & ^option.galley_opt
        then
	do;
	  call comp_report_ (2, 0,
	       "Even page header block exceeds "
	       || "available page space. It will be ignored.",
	       addr (ctl.info), ctl_line);
				/* erase the whole block */
	  hfcblk.hdr = text_header;
	end;

        even_head = hfcblk.hdr.used;
        page_parms.net.even = page_parms.net.even - even_head;
        even_headspace = 0;		/* reset head space */
      end;

    hfcblk_ptr = shared.opftrptr;	/* odd footer? */
    if hfcblk_ptr ^= null
    then
      do;
        odd_foot = hfcblk.hdr.used;
        page_parms.net.odd = page_parms.net.odd - odd_foot;
      end;

    hfcblk_ptr = shared.ophdrptr;	/* odd header? */
    if hfcblk_ptr ^= null
    then
      do;				/* if it wont fit */
        if page_parms.net.odd - hfcblk.hdr.used < 0 & ^option.galley_opt
        then
	do;
	  call comp_report_ (2, 0,
	       "Odd page header block exceeds "
	       || "available page space. It will be ignored.",
	       addr (ctl.info), ctl_line);
				/* erase the whole block */
	  hfcblk.hdr = text_header;
	end;

        odd_head = hfcblk.hdr.used;
        page_parms.net.odd = page_parms.net.odd - odd_head;
        odd_headspace = 0;		/* reset head space */
      end;

    odd_headspace = odd_headspace + page_parms.margin.header;
    even_headspace = even_headspace + page_parms.margin.header;

    if page.hdr.frontpage
    then colhdr.net, page_header.net = page_parms.net.odd;
    else colhdr.net, page_header.net = page_parms.net.even;

    max_col = 0;			/* if multi-column */
    if page.hdr.col_count > 1		/* find longest column */
    then
      do i = 1 to page.hdr.col_count;
        locolptr = page.column_ptr (i);
        max_col = max (max_col, col.hdr.used + col.hdr.ftn.usd);
      end;			/**/
				/* current page & all columns */
    if ^set_current_page | (set_current_page & ^page.hdr.headed)
    then
      do;
        page.parms.net = page_parms.net;
        if page.hdr.frontpage
        then page.hdr.net = page.parms.net.odd;
        else page.hdr.net = page.parms.net.even;
				/* set column 0 */
        col0.hdr.net = max (page.hdr.net - max_col, 0);

        if page.parms.cols.count > 0	/* if not 1-up set all columns */
        then
	do i = 1 to page.parms.cols.count;
	  locolptr = page.column_ptr (i);
	  locol.hdr.net =
	       page.hdr.net - col0.hdr.used - locol.ftrusd
	       - col0.hdr.ftn.usd;
	end;
      end;

    if shared.bug_mode
    then call ioa_ ("util$set_net_page: (^[^^^]current ^[^^^]headed"
	    || " odd=^f ^f evn=^f ^f act=^f ^f col=^d ^f(^f) ^f)",
	    ^set_current_page, ^page.hdr.headed,
	    show (page_parms.net.odd, 12000), show (odd_headspace, 12000),
	    show (page_parms.net.even, 12000), show (even_headspace, 12000),
	    show (page.hdr.net, 12000), show (page.hdr.hdspc, 12000),
	    page.hdr.col_index, show (col.hdr.net, 12000),
	    show (col.depth_adj, 12000), show (col.hdr.pspc, 12000));

    return;			/* end of set_net_page */
%page;
num_display:
  entry (val_ptr, displ_mode) returns (char (32) var);

/* PARAMETERS */

    dcl val_ptr	   ptr;		/* value to be converted */
    dcl displ_mode	   fixed bin;	/* display mode index */

/* LOCAL STORAGE */

    dcl alpha_repl	   (2) char (26) unal static options (constant)
		   init ("abcdefghijklmnopqrstuvwxyz",
		   "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
    dcl display_str	   char (91);	/* string to return */
    dcl hexb	   bit (4);	/* for hex fractions */
    dcl hexc	   char (16);	/* for hex fractions */
    dcl hexd	   fixed bin (4) unsigned;
				/* for hex fractions */
    dcl j		   fixed bin;	/* working index */
    dcl ldspl	   fixed bin;	/* length of display string */
    dcl octb	   bit (3);	/* for oct fractions */
    dcl octc	   char (16);	/* for oct fractions */
    dcl octd	   fixed bin (3) unsigned;
				/* for oct fractions */
    dcl (r, s)	   fixed bin (31);	/* working value */
    dcl roman_repl_1   (2, 4) char (1) static options (constant)
		   init ("i", "x", "c", "m", "I", "X", "C", "M");
    dcl roman_repl_2   (2, 3) char (1) static options (constant)
		   init ("v", "l", "d", "V", "L", "D");
    dcl val	   fixed bin (31) based (val_ptr);
    dcl val_pic	   pic "---------9.999v";
				/* for arabic displays */
    dcl (wa, wb)	   (8) fixed bin (35);

    dcl ioa_$rsnnl	   entry options (variable);

    display_str = "";		/* clear return value */

    if displ_mode = 0		/* arabic */
    then
      do;
        val_pic = val;		/* copy value */
        display_str = rtrim (rtrim (ltrim (val_pic), "0"), ".");
        ldspl = index (display_str, " ") - 1;
      end;

    else if displ_mode = 1		/* binary */
    then
      do;
        r = divide (val, 1000, 31, 0);	/* integer part */
        display_str = ltrim (char (unspec (r)), "0");
        if display_str = ""
        then display_str = "0";
        ldspl = index (display_str, " ") - 1;

        r = mod (val, 1000);		/* fraction part */
        if r > 0
        then
	do;
	  substr (display_str, ldspl + 1) = ".";
	  ldspl = ldspl + 1;
	  do j = 1 to 11 while (r > 0);
	    substr (display_str, ldspl + j) =
	         ltrim (char (divide (2 * r, 1000, 1, 0)));
	    r = mod (2 * r, 1000);
	  end;
	  display_str = rtrim (rtrim (display_str), "0");
	  ldspl = index (display_str, " ") - 1;
	end;
      end;

    else if displ_mode = 2		/* hexadecimal */
    then
      do;
        r = divide (val, 1000, 31, 0);	/* integer part */
        call ioa_$rsnnl ("^.4b", display_str, 0, unspec (r));
        display_str = ltrim (display_str, "0");
        if display_str = ""
        then display_str = "0";
        ldspl = index (display_str, " ") - 1;

        r = mod (val, 1000);		/* fraction part */
        if r > 0
        then
	do;
	  substr (display_str, ldspl + 1) = ".";
	  ldspl = ldspl + 1;
	  do j = 1 to 3 while (r > 0);
	    hexd = divide (16 * r, 1000, 4, 0);
	    hexb = bit (hexd);
	    call ioa_$rsnnl ("^.4b", hexc, 0, hexb);
	    substr (display_str, ldspl + j) = rtrim (hexc);
	    r = mod (16 * r, 1000);
	  end;
	  display_str = rtrim (rtrim (display_str), "0");
	  ldspl = index (display_str, " ") - 1;
	end;
      end;

    else if displ_mode = 3		/* octal */
    then
      do;
        r = divide (val, 1000, 31, 0);	/* integer part */
        call ioa_$rsnnl ("^.3b", display_str, 0, unspec (r));
        display_str = ltrim (display_str, "0");
        if display_str = ""
        then display_str = "0";
        ldspl = index (display_str, " ") - 1;

        r = mod (val, 1000);		/* fraction part */
        if r > 0
        then
	do;
	  substr (display_str, ldspl + 1) = ".";
	  ldspl = ldspl + 1;
	  do j = 1 to 4 while (r > 0);
	    octd = divide (8 * r, 1000, 4, 0);
	    octb = bit (octd);
	    call ioa_$rsnnl ("^.3b", octc, 0, octb);
	    substr (display_str, ldspl + j) = rtrim (octc);
	    r = mod (8 * r, 1000);
	  end;
	  display_str = rtrim (rtrim (display_str), "0");
	  ldspl = index (display_str, " ") - 1;
	end;
      end;

    else if displ_mode <= 5		/* alpha */
    then
      do;
        if val = 0			/* map 0 to a blank */
        then
	do;
	  display_str = " ";
	  ldspl = 1;
	end;

        else if val > 26 ** 8		/* check top of conversion range */
        then
	do;
	  display_str = copy ("*", 8);
	  ldspl = 8;
	end;

        else
	do;
	  r = divide (val, 1000, 31, 0);
				/* integer part */
	  wa (*) = 0;		/* clear local storage */
	  do j = 8 to 1 by -1 while (r > 0);
	    if mod (r, 26) = 0
	    then wa (j) = 26;
	    else wa (j) = mod (r, 26);
	    if mod (r, 26) = 0
	    then r = divide (r, 26, 35) - 1;
	    else r = divide (r, 26, 35);
	  end;

	  ldspl = 0;
	  do j = 1 to 8;
	    if wa (j) > 0
	    then
	      do;
	        ldspl = ldspl + 1;
	        substr (display_str, ldspl, 1) =
		   substr (alpha_repl (displ_mode - 3), wa (j), 1);
	      end;
	  end;
	end;
      end;

    else if displ_mode <= 7		/* roman */
    then
      do;
        if val = 0			/* value undefined in roman, show as blank */
        then
	do;
	  display_str = " ";
	  ldspl = 1;
	end;

        else
	do;
	  r = divide (val, 1000, 31, 0);
				/* discard fraction part */
	  wa (*), wb (*) = 0;	/* clear local storage */
				/* "parse" the value */
	  do j = 1 to 3;		/* roman has 3 "decades";
				   x - 10, c - 100, m - 1000
				   each having a "quintade";
				   v - 5, l - 50, d - 500
				   we will not bother with the higher
				   "overbarred" orders since this mode
				   is intended for page numbers */
	    s = mod (r, 10);	/* value within the decade */
	    wa (j) = mod (s, 5);	/* residue within the quintade */
	    wb (j) = divide (s, 5, 35);
				/* which quintade? */
	    r = divide (r, 10, 35);	/* next decade */
	  end;

	  ldspl = 0;		/* clear display char counter */

	  if r > 0		/* use Ms for high order value */
	  then
	    do;
	      display_str = copy (roman_repl_1 (displ_mode - 5, 4), r);
	      ldspl = r;
	    end;

	  do j = 3 to 1 by -1;	/* go thru decades from high to low */
	    if wa (j) > 0		/* anything for this one? */
	    then
	      do;

	        if wa (j) = 4	/* if residue is 4 */
	        then
		do;		/* use one of these */
		  substr (display_str, ldspl + 1, 1) =
		       roman_repl_1 (displ_mode - 5, j);
		  if wb (j) = 1	/* and one of the next higher decade */
		  then substr (display_str, ldspl + 2, 1) =
			  roman_repl_1 (displ_mode - 5, j + 1);
		  else substr (display_str, ldspl + 2, 1) =
				/* or quintade */
			  roman_repl_2 (displ_mode - 5, j);
		  ldspl = ldspl + 2;
		end;

	        else
		do;
		  if wb (j) = 1	/* if in the second quintade */
		  then
		    do;		/* use one of them */
		      ldspl = ldspl + 1;
		      substr (display_str, ldspl, 1) =
			 roman_repl_2 (displ_mode - 5, j);
		    end;		/* and the residue number of this decade */
		  substr (display_str, ldspl + 1, wa (j)) =
		       copy (roman_repl_1 (displ_mode - 5, j), wa (j));
		  ldspl = ldspl + wa (j);
		end;
	      end;
	    else if wb (j) > 0
	    then
	      do;
	        ldspl = ldspl + 1;
	        substr (display_str, ldspl, 1) =
		   roman_repl_2 (displ_mode - 5, j);
	      end;
	  end;
	end;
      end;

    return (substr (display_str, 1, ldspl));
				/* end of num_display */
%page;
escape:
  entry (buffer, info_ptr);

/* PARAMETERS */

    dcl buffer	   char (*) var;
    dcl info_ptr	   ptr;

    rchar = "";			/* clear local storage */
    wbuf = buffer;			/* copy buffer */

    if shared.bug_mode & dt_sw
    then call ioa_ ("escape: ^a", comp_util_$display (buffer, 0, "0"b));

    l, k = 1;
    do while (l > 0 & k < length (wbuf));
				/* scan for escapes */
      l = search (substr (wbuf, k), "*" || DC1);

      if l > 0			/* find anything? */
      then
        do;			/* step over DC1 control strings */
	if substr (wbuf, k + l - 1, 1) = DC1
	then k = k + l + 2 + bin (unspec (substr (wbuf, k + l + 1, 1)));

	else
	  do;			/* must be a * */
	    if k + l > 2		/* an escaped *? */
	    then if index (substr (wbuf, k + l - 2), "ż") = 1
	         then
		 do;
		   k = k + l + 1;
		   goto srch;
		 end;

	    k, m = k + l;
	    if k <= length (wbuf)	/* if not a trailing * */
	    then
	      do;			/* replace * with \277 */
	        substr (wbuf, k - 1, 1) = "ż";
	        rchar = substr (wbuf, k, 1);

	        if rchar = "'"
	        then rchar = rquote;

	        else if rchar = """"
	        then rchar = rquote;

	        else if rchar = "`"
	        then rchar = lquote;

	        else if rchar = "M"
	        then rchar = EM;

	        else if rchar = "N"
	        then rchar = EN;

	        else if rchar = "-"
	        then
		do;
		  if index (substr (wbuf, k), "-*-") = 1
		  then
		    do;
		      rchar = EMdash;
		      substr (wbuf, k, 2) = "żż";
		      k, m = k + 2;
		    end;
		  else rchar = ENd;
		end;

	        else if rchar = "b"
	        then rchar = BSP;

	        else if rchar = "n"
	        then rchar = NL;

	        else if rchar = "s"
	        then rchar = " ";

	        else if rchar = "t"
	        then rchar = HT;

	        else if rchar = "f"
	        then rchar = FF;

	        else if rchar = "c" | rchar = "C"
	        then
		do;		/* numeric character value */
		  rchar = "ż";	/* octal 277 to replace the c */
		  m = m + 1;
		  if substr (wbuf, m, 1) = "#"
				/* octal value */
		  then
		    do;
		      cmode = 8;
		      rchar = rchar || "ż";
				/* octal 277 to replace the # */
		      m = m + 1;
		    end;
		  else cmode = 10;	/* decimal value */

		  char_index = 0;	/* clear value accumulator */
		  len = min (verify (substr (wbuf, m), "0123456789") - 1,
		       3);
		  if len = -1
		  then len = length (wbuf) - m + 1;
		  if len = 0
		  then call comp_report_ (2, 0, "Numeric value expected.",
			  info_ptr, buffer);
		  else
		    do;
		      do m = m to m + len - 1;
		        char_index =
			   cmode * char_index
			   + bin (substr (wbuf, m, 1));
		      end;
		      rchar = rchar || copy ("ż", len - 1)
			 || substr (collate9 (), char_index + 1, 1);
		      m = m - 1;
		    end;
		end;		/* everything else just passes through */
	        if rchar ^= ""
	        then
		do;
		  if m < length (wbuf)
		  then wbuf = substr (wbuf, 1, k - 1) || rchar
			  || substr (wbuf, m + 1);
		  else wbuf = substr (wbuf, 1, k - 1) || rchar;
		  rchar = "";
		  len = 1;
		end;
	        k = k + 1;
	      end;
	  end;
srch:
        end;
    end;

    buffer = wbuf;			/* copy result back to buffer */

    if shared.bug_mode & dt_sw
    then
      do;
        call ioa_ ("^5x(escape) ^a", comp_util_$display (buffer, 0, "0"b));
      end;

    return;			/* end of escape */
%page;

/* SEARCH SYMBOL TREE */
search_tree:
  entry (symbol, create);

/* PARAMETERS */

    dcl create	   bit (1);	/* 1= create the symbol */

    if shared.bug_mode & dt_sw
    then call ioa_ ("search_tree: (^a^[ CREATE^])", symbol, create);

    tree.entryndx = 0;
    do tree.areandx = 1 to tree.count	/* run thru allocated name areas */
         while (tree.entryndx = 0);
      tree_names_ptr = tree.name_ptr (tree.areandx);
      tree.entryndx = index (string (tree_names), symbol);
    end;

    if tree.entryndx = 0 & create	/* create it if not there? */
    then
      do;
        tree.areandx = tree.count;	/* use the last area */
				/* full up? - then get a new area */
        if tree.entry_ct (tree.areandx) = MAX_TREE_AREA_CT
        then
	do;			/* all out of areas? */
	  if tree.count = MAX_TREE_AREAS
	  then
	    do;
	      call comp_report_$ctlstr (4, 0, addr (ctl.info), ctl_line,
		 "Too many user variables. Program limit is ^d.",
		 MAX_TREE_AREAS * MAX_TREE_AREA_CT);
	      return;
	    end;			/**/
				/* create storage for new area */
	  tree.areandx, tree.count = tree.count + 1;
	  tree.flag_ptr (tree.areandx) =
	       allocate (const.local_area_ptr, size (tree_flags));
	  tree_names_ptr, tree.name_ptr (tree.areandx) =
	       allocate (const.local_area_ptr, size (tree_names));
	  tree_names = "";
	  tree.num_ptr (tree.areandx) =
	       allocate (const.local_area_ptr, size (tree_nums));
	  tree.incr_ptr (tree.areandx) =
	       allocate (const.local_area_ptr, size (tree_incrs));
	  tree.var_ptr (tree.areandx) =
	       allocate (const.local_area_ptr, size (tree_var));
	  tree.entry_ct (tree.areandx) = 0;
	end;			/**/
				/* record new variable */
        tree.entryndx, tree.entry_ct (tree.areandx) =
	   tree.entry_ct (tree.areandx) + 1;
        tree_names_ptr = tree.name_ptr (tree.areandx);
        tree_names (tree.entryndx) = symbol;
        tree_var_ptr = tree.var_ptr (tree.areandx);
        tree_var.flags (tree.entryndx) = "000000000"b;
        tree_var.mode (tree.entryndx) = 0;
				/* set initial values */
        tree_var.flag_loc (tree.entryndx) = addr (tree_flags (tree.entryndx));
        tree_var.flag_loc (tree.entryndx) -> flag_value = "0"b;
        tree_var.num_loc (tree.entryndx) = addr (tree_nums (tree.entryndx));
        tree_var.num_loc (tree.entryndx) -> num_value = 0;
        tree_var.incr_loc (tree.entryndx) = addr (tree_incrs (tree.entryndx));
        tree_var.incr_loc (tree.entryndx) -> num_value = 1000;
        tree_var.str_loc (tree.entryndx) =
	   allocate (const.local_area_ptr, size (string_area));
        tree_var.str_loc (tree.entryndx) -> txtstr = "";
      end;

    else
      do;
        tree.areandx = tree.areandx - 1;/* loop counts one to many */
				/* true symbol index */
        tree.entryndx = divide (tree.entryndx + 31, 32, 17, 0);
      end;

    if shared.bug_mode & dt_sw
    then call ioa_ ("^5x(search_tree: ^d|^d)", tree.areandx, tree.entryndx);

    return;			/* end of search_tree */
%page;
set_bin:				/* SET BINARY PARAMETERS */
  entry (param, param_name, default, min_param, max_param, scale, res);

/* PARAMETERS */

    dcl param	   fixed bin (31);	/* (IN/OUT) parameter to be set */
    dcl param_name	   char (32) var;	/* (IN) the name of the parameter */
    dcl default	   fixed bin (31);	/* (IN) default value for param */
    dcl min_param	   fixed bin (31);	/* (IN) minimum parameter value */
    dcl max_param	   fixed bin (31);	/* (IN) maximum parameter value */
				/* (IN) conversion scale factor */
    dcl scale	   (*) fixed bin (31);
    dcl res	   fixed bin (31);	/* (IN) resolution (min value) */

/* LOCAL STORAGE */

    dcl old_param	   fixed bin (31);	/* working storage */
				/* for errors */
    dcl max_param_pic  pic "zzzzzz9.999";
    dcl min_param_pic  pic "zzzzzz9.999";
    dcl value	   fixed bin (31);	/* new or delta value */

    if shared.bug_mode & dt_sw
    then call ioa_ ("util$set_bin: (cr=^f df=^f mn=^f mx=^[^f^;none^s^])",
	    show (param, 12000), show (default, 12000),
	    show (min_param, 12000), (max_param > 0),
	    show (max_param, 12000));

    old_param = param;		/* save old value */
    param = default;		/* preset to default value */

    if ctl.index <= length (ctl_line)	/* if value is given */
    then if substr (ctl_line, ctl.index, 1) ^= ","
         then
	 do;			/*  delta? */
	   if index ("+-", substr (ctl_line, ctl.index, 1)) ^= 0
	   then
	     do;
	       value = res		/* read delta value */
		  *
		  round (
		  divide (
		  comp_read_$number (ctl_line, scale, ctl.index, ctl.index,
		  addr (ctl.info), 0), res, 31, 1), 0);

	       if max_param >= 0 & old_param + value > max_param
	       then
	         do;
		 call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		      "Given value for ^a too large. "
		      || "Current max value, ^f, will be used.",
		      param_name, show (max_param, scale (1)));
		 param = max_param;
	         end;

	       else if old_param + value - min_param < -scale (1)
	       then
	         do;
		 call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		      "Given value for ^a too small. "
		      || "Current min value, ^f, will be used.",
		      param_name, show (min_param, scale (1)));
		 param = min_param;
	         end;

	       else param = old_param + value;
	     end;

	   else			/* resetting to cardinal value */
	     do;
	       value = res
		  *
		  round (
		  divide (
		  comp_read_$number (ctl_line, scale, ctl.index, ctl.index,
		  addr (ctl.info), 0), res, 31, 1), 0);

	       if max_param >= 0 & value > max_param
	       then
	         do;
		 call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		      "Given value for ^a too large. "
		      || "Current max value, ^f, will be used.",
		      param_name, show (max_param, scale (1)));
		 param = max_param;
	         end;

	       else if value < min_param
	       then
	         do;
		 call comp_report_$ctlstr (2, 0, addr (ctl.info), ctl_line,
		      "Given value for ^a too small. "
		      || "Current min value, ^f, will be used.",
		      param_name, show (min_param, scale (1)));
		 param = min_param;
	         end;

	       else param = value;
	     end;
	 end;

    if ctl.index <= length (ctl_line)	/* to skip comma or overflow ctl line */
    then if substr (ctl_line, ctl.index, 1) = ","
         then ctl.index = ctl.index + 1;

    if shared.bug_mode & dt_sw
    then call ioa_ ("^5x(set_bin: ^a ^f)", param_name, show (param, 12000));

    return;			/* end of set_bin */
%page;
pageno:
  entry (page_incr, pageno_str);

/* PARAMETERS */

    dcl page_incr	   fixed bin;	/* page count page_increment */
    dcl pageno_str	   char (*) var;	/* PageNo string to be returned */

/* LOCAL STORAGE */

    dcl local_str	   char (32) var;	/* for each PageNo element */
    dcl next_pageno_val
		   fixed bin (31);

    if shared.bug_mode & dt_sw
    then call ioa_$nnl ("pageno: (^a -> ", pageno_str);
				/* advance as requested */
    shared.pagenum.nmbr (shared.pagenum.index) =
         shared.pagenum.nmbr (shared.pagenum.index) + page_incr;
				/* clear target strings */
    pageno_str, shared.next_pagenmbr = "";
				/* for each element */
    do i = 1 to shared.pagenum.index;	/* display in its own mode */
      local_str =
	 comp_util_$num_display (addr (shared.pagenum.nmbr (i)),
	 (shared.pagenum.mode (i)));
      pageno_str = pageno_str || local_str;

      if i < shared.pagenum.index	/* add separator if more */
      then
        do;
	shared.next_pagenmbr = shared.next_pagenmbr || local_str;
	pageno_str = pageno_str || shared.pagenum.sep (i);
	shared.next_pagenmbr =
	     shared.next_pagenmbr || shared.pagenum.sep (i);
        end;

      else
        do;
	next_pageno_val = shared.pagenum.nmbr (i) + max (page_incr, 1000);
	local_str =
	     comp_util_$num_display (addr (next_pageno_val),
	     (shared.pagenum.mode (i)));
	shared.next_pagenmbr = shared.next_pagenmbr || local_str;
        end;
    end;

    if shared.bug_mode & dt_sw
    then call ioa_ ("^a^[ front^; back^]) ", pageno_str, page.hdr.frontpage);

    return;			/* end of pageno */
%page;
push:
  entry (symbol);			/* push a stack variable */

/* For stack variables, tree_var.num_loc points to the current stack box */
/* and tree_var.str_loc points to the first stack box */

    if shared.bug_mode & dt_sw
    then call ioa_ ("push: ^a", rtrim (symbol));

    tree_var_ptr = tree.var_ptr (tree.areandx);
				/* not stacked? */
    if ^substr (tree_var.flags (tree.entryndx), 9, 1)
    then
      do;				/* make it stacked */
        tree_var.flags (tree.entryndx) =
	   tree_var.flags (tree.entryndx) | push_attr;
				/* first box */
        stkbox_ptr = allocate (const.local_area_ptr, size (stack_box));

        stack_box = init_stack_box;	/* move current values */
        if tree_var.num_loc (tree.entryndx) ^= null ()
        then stack_box.numval = tree_var.num_loc (tree.entryndx) -> num_value;
        if tree_var.incr_loc (tree.entryndx) ^= null ()
        then stack_box.incrval =
	        tree_var.incr_loc (tree.entryndx) -> num_value;
        stack_box.txtstr = tree_var.str_loc (tree.entryndx) -> txtstr;
				/* point to the box */
        tree_var.str_loc (tree.entryndx), tree_var.num_loc (tree.entryndx) =
	   stkbox_ptr;
      end;			/* its already stacked */
				/* set stack box pointer */
    else stkbox_ptr = tree_var.num_loc (tree.entryndx);

    if stack_box.fthrd = null ()	/* need a new box? */
    then
      do;
        stack_box.fthrd = allocate (const.local_area_ptr, size (stack_box));
        stack_box.fthrd -> stack_box = init_stack_box;
        stack_box.fthrd -> stack_box.bthrd = stkbox_ptr;
      end;			/**/
				/* set forward thread */
    tree_var.num_loc (tree.entryndx), stkbox_ptr = stack_box.fthrd;
				/* advance stack level */
    tree_var.str_loc (tree.entryndx) -> stack_box.level =
         tree_var.str_loc (tree.entryndx) -> stack_box.level + 1;

push_return:
    if shared.bug_mode & dt_sw
    then call ioa_ ("^5x(push: ^d|^d stk=^d ^a)", tree.areandx, tree.entryndx,
	    tree_var.str_loc (tree.entryndx) -> stack_box.level,
	    rtrim (symbol));

    return;			/* end of push */

pop:
  entry (symbol);

/* Same PARAMETERS as push above */

    dcl bad_stack_pop  condition;	/* for debugging */

    call comp_util_$search_tree (symbol, ^CREATE);

    if tree.entryndx = 0		/* not there? */
    then
      do;
no_pop:
        call comp_report_ (4, 0,
	   "Program error. Attempting to pop an "
	   || "undefined stack variable.", addr (ctl.info), ctl_line);
        if option.debug_opt
        then signal bad_stack_pop;
        else signal comp_abort;
        return;
      end;

    tree_var_ptr = tree.var_ptr (tree.areandx);

    if tree_var.num_loc (tree.entryndx) ^= null ()
				/* do the pop */
    then tree_var.num_loc (tree.entryndx), stkbox_ptr =
	    tree_var.num_loc (tree.entryndx) -> stack_box.bthrd;
				/* retard stack level */
    tree_var.str_loc (tree.entryndx) -> stack_box.level =
         tree_var.str_loc (tree.entryndx) -> stack_box.level - 1;
				/* at the base? */
    if tree_var.str_loc (tree.entryndx) -> stack_box.level = 0
    then tree_var.num_loc (tree.entryndx) = tree_var.str_loc (tree.entryndx);

pop_return:
    if shared.bug_mode & dt_sw
    then
      do;
        if tree_var.num_loc (tree.entryndx) = null ()
        then call ioa_ ("util$pop: (^d(^d),^a=null)", tree.entryndx,
	        tree_var.str_loc (tree.entryndx) -> stack_box.level,
	        rtrim (symbol));
        else call ioa_ ("util$pop: (^d(^d),^a=^[^d^;^s^]^[^a^;^s^])",
	        tree.entryndx,
	        tree_var.str_loc (tree.entryndx) -> stack_box.level,
	        rtrim (symbol),
	        (tree_var.flags (tree.entryndx) & numeric_attr),
	        stack_box.numval,
	        (tree_var.flags (tree.entryndx) & string_attr),
	        stack_box.txtstr);
      end;

    return;			/* end of pop */
%page;
translate:
  entry (tr_str) returns (char (*) var);

/* PARAMETERS */

    dcl tr_str	   char (*) var;	/* string to be translated */

/* LOCAL STORAGE */

    dcl rtn_str	   char (1020) var; /* return string */

    if shared.bug_mode & dt_sw
    then call ioa_ ("util$translate: ^a",
	    comp_util_$display (substr (tr_str, 1, length (tr_str)), 0, "0"b)
	    );

    rtn_str = "";			/* clear return string */
    i = 1;			/* set up loop index */

    do while (i <= length (tr_str));
      j = index (substr (tr_str, i), DC1);
				/* look for ctl str */
      if j ^= 0			/* found one? */
      then
        do;
	if j > 1			/* translate preceding text */
	then rtn_str =
		rtn_str
		||
		translate (substr (tr_str, i, j - 1), shared.trans.out,
		shared.trans.in);
	i = i + j - 1;		/* step to start of ctl str */
	j = bin (unspec (substr (tr_str, i + 2, 1))) + 3;
				/* length of ctl str */
	rtn_str = rtn_str || substr (tr_str, i, j);
				/* move the ctl str */
	i = i + j;		/* and step over it */
        end;
      else
        do;
	rtn_str =
	     rtn_str
	     ||
	     translate (substr (tr_str, i), shared.trans.out,
	     shared.trans.in);
	i = length (tr_str) + 1;	/* exit the loop */
        end;
    end;

    if shared.bug_mode & dt_sw
    then call ioa_ ("^5x(translate) ^a",
	    comp_util_$display (substr (rtn_str, 1, length (tr_str)), 0,
	    "0"b));

    return (rtn_str);		/* end of translate */
%page;
display:
  entry (dtext, dlen, nl_sw) returns (char (*) var);

/* PARAMETERS */

    dcl dtext	   char (*) var;	/* string to display */
    dcl dlen	   fixed bin;	/* number of dtext chars displayed */
    dcl nl_sw	   bit (1);	/* 1= append NL to output */

/* LOCAL STORAGE */

    dcl ch	   char (1);	/* character to be displayed */
    dcl ct	   fixed bin;	/* # of duplicate chars */
    dcl ctl_decode	   (0:31) char (3) var int static options (constant)
		   init ("NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK",
		   "BEL", "BSP", "HT", "NL", "VT", "FF", "CR", "SO", "SI",
		   "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
		   "CAN", "031", "SUB", "ESC", "FS", "GS", "RS", "US");
    dcl dstr	   char (2048) var;
    dcl (ii, jj, jjj)  fixed bin (24);
    dcl ichr	   fixed bin;
    dcl 1 meta	   static options (constant),
	2 codes	   (63) char
		   init ("", " ", "Ş", "Ť", "Ź", "­", "Ż", "ą", "ť", "˝",
		   "ż", "Á", "Ă", "Ä", "Í", "Î", "Đ", "Ô", "Ö", "Ú", "ß",
		   "ę", "đ", "ý", "ţ", "˙", "", "", "", "", "", "",
		   "", "", "", "	", "
", "", "", "", "", "", "",
		   "", "", "", "", "", "", "", "", "", "", "",
		   "", "", "", "", " ", "!", """, "#", "$"),
	2 decodes	   (63) char (8) var
		   init ("DEL", "space", "multiply", "pls-min", "nabla",
		   "EM-", "slash", "dagger", "perpen", "not-eql", "PAD",
		   "dbldaggr", "cright", "delta", "bullet", "parallel",
		   "PI", "trdmark", "therfore", "approx", "infinity",
		   "theta", "pi", "square", "overbar", "PS", "sup0",
		   "sup1", "sup2", "sup3", "sup4", "sup5", "sup6", "sup7",
		   "sup8", "sup9", "EM", "EM_", "EN", "EN_", "ENd", "THIN",
		   "PIXEL", "lquote", "rquote", "multiply", "modmark",
		   "dnarro", "diambot", "diamlf", "delmark", "diamrt",
		   "diamtop", "lfarro", "{1hi", "[1hi", "lfcirc", "(1hi",
		   "rtarro", "}1hi", "]1hi", "rtcirc", ")1hi");

/*
                    600
                    601
                    602
                    603
                    604
                    605
                    606
                    607
                    610
                    611
	          612
	          613
	          614
	          615
	          616
	          617
	          620
	          621
	          622
	          623
	          624
	          625
	          626
	          627
	          630
	          631
	          632
	          633
	          634
	          635
	          636
	          637
	          640
	          641
	          642
	          643
	          644
445 uparo           645
446                 646
447 [tp             647
450 [ht             650
451 [md             651
452 [bt             652
453 [hb             653
454 [fl             654
455 ]tp             655
456 ]ht             656
457 ]md             657
460 ]bt             660
461 ]hb             661
462 ]fl             662
463 {tp             663
464 {ht             664
465 {md             665
466 {bt             666
467 {hb             667
470 {fl             670
471 }tp             671
472 }ht             672
473 }md             673
474 }bt             674
475 }hb             675
476 }fl             676
477 art)            677
500 art             700
501 art             701
502 art             702
503 art             703
504 art             704
505 art             705
506 art             706
507 art             707
510 art             710
511 art             711
512 art             712
513 art             713
514 art             714
515 art             715
516 art             716
517 art             717
520 art             720
521 art             721
522 art             722
523 art             723
524 art             724
525 art             725
526 art             726
527 art             727
530 art             730
531 /onehi          731
532 vrule           732
533 hstrt           733
534 hline           734
535 hterm           735
536 lslnt           736
537 rslnt           737
540 boxtl           740
541 boxt            741
542 boxtr           742
543 boxl            743
544 box+            744
545 boxr            745
546 boxbl           746
547 boxb            747
550 boxbr           750
551 loztl           751
552 loztr           752
553 lozl            753
554 lozr            754
555 lozbl           755
556 lozbr           756
557                 757
560                 760
561                 761
562                 762
563                 763
564                 764
565                 765
566                 766
567                 767
570                 770
571                 771
572                 772
573                 773
574                 774
575                 775
576                 776
577                 777
*/
    dcl printable	   char (95) static options (constant)
		   init (" !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLM"
		   || "NOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
				/* area for comp_dvt.displayproc */
    dcl work	   (100) fixed bin (35);

    ret_str = "";
    work (*) = 0;

    ii = 1;
    do while (ii <= length (dtext));	/**/
				/* display any printing chars */
      jj = verify (substr (dtext, ii), printable);
      if jj = 0
      then jj = length (dtext) - ii + 1;
      else jj = jj - 1;

      if jj > 0			/* any printables? */
      then ret_str = ret_str || substr (dtext, ii, jj);
      ii = ii + jj;			/* step over them */

      if ii <= length (dtext)		/* more? */
      then
        do;
	ch = substr (dtext, ii, 1);	/**/

	if rank (ch) < 32		/* ASCII control chars */
	     | rank (ch) >= 127	/* or meta characters */
	then
	  do;
	    dstr = comp_dvt		/* does the device know this one? */
	         .displayproc (substr (dtext, ii), jjj, "0"b);
	    if jjj > 0		/* yes */
	    then ii = ii + jjj;

	    else if jjj < 0
	    then goto display_rtn;

	    else			/* not a device character */
	      do;
	        if rank (ch) = 0	/* special handling for NUL */
	        then
		do;
		  if ii = length (dtext)
		  then call ioa_$rsnnl ("<NUL>", dstr, 0);
		  else call ioa_$rsnnl (
			  "<NUL> -- <<plus ^d characters starting "
			  || "with \^.3b>>", dstr, 0,
			  length (dtext) - ii,
			  unspec (substr (dtext, ii + 1, 1)));
		  ii = length (dtext) + 1;
		end;		/**/
				/* check for escapes */
	        else if ch = "ż" & length (dtext) > ii
	        then
		do;
		  ct = 2;		/* count for this first bunch */
		  if substr (dtext, ii + 1, 1) = lquote
		  then dstr = "<lquote>";
		  else if substr (dtext, ii + 1, 1) = rquote
		  then dstr = "<rquote>";
		  else if substr (dtext, ii + 1, 1) = EN
		  then dstr = "<EN>";
		  else if substr (dtext, ii + 1, 1) = EM
		  then dstr = "<EM>";
		  else if substr (dtext, ii + 1, 1) = ENd
		  then dstr = "<ENd>";
		  else if index (substr (dtext, ii + 1), "żż" || EMdash)
		       = 1
		  then
		    do;
		      dstr = "<EMdash>";
		      ct = 4;
		    end;

		  else
		    do;
		      ct =	/* how many? */
			 verify (substr (dtext, ii), "ż");
		      if ct = 0	/* all the rest */
		      then ct = length (dtext) - ii + 1;
		      else ct = ct - 1;

		      if ct > 1	/* if more than one */
		      then call ioa_$rsnnl ("<PAD*^d>", dstr, 0, ct);
		      else dstr = "<PAD>";
		    end;

		  ii = ii + ct;
		end;

	        else if ch = DC1
	        then
		do;
		  DCxx_p = addr (substr (dtext, ii));
				/* shift controls */
		  if dclong_val.type = type_slx
		  then call ioa_$rsnnl ("<<HSFT: ^f>>", dstr, 0,
			  show (fixed (dclong_val.v1), 12000));

		  else if dclong_val.type = type_sly
		  then call ioa_$rsnnl ("<<VSFT: ^f>>", dstr, 0,
			  show (fixed (dclong_val.v1), 12000));

		  else if dcshort_val.type = type_sy
		  then call ioa_$rsnnl ("<<VSFT: ^f>>", dstr, 0,
			  show (fixed (dcshort_val.v1), 12000));
				/* vector controls */
		  else if dclong_val.type = type_vlx
		  then call ioa_$rsnnl ("<<VEC: ^f>>", dstr, 0,
			  show (fixed (dclong_val.v1), 12000));
				/* font change controls */
		  else if dcctl.type = type_font
		  then call ioa_$rsnnl ("<<FNT: ^a ^f>>", dstr, 0,
			  fnttbldata.ptr (dcfs.f) -> fnttbl.entry.name,
			  show (fixed (dcfs.p), 1000));

		  else if dcctl.type = type_wait
		  then call ioa_$rsnnl ("<<WAIT:>>", dstr, 0);

		  else if dcctl.type = type_unstart
		  then call ioa_$rsnnl ("<<UNSTART:>>", dstr, 0);

		  else if dcctl.type = type_unstop
		  then call ioa_$rsnnl ("<<UNSTOP:>>", dstr, 0);

		  ii = ii + dcxx.leng + 3;
		end;		/* DC1 controls */

	        else
		do;
		  ct =		/* how many? */
		       verify (substr (dtext, ii), ch);
		  if ct = 0	/* all the rest */
		  then ct = length (dtext) - ii + 1;
		  else ct = ct - 1;

		  if rank (ch) < 32
		  then
		    do;
		      if ct > 1	/* if more than one */
		      then call ioa_$rsnnl ("<^a*^d>", dstr, 0,
			      ctl_decode (rank (ch)), ct);
		      else dstr = "<" || ctl_decode (rank (ch)) || ">";
		    end;

		  else
		    do;
		      ichr = index (string (meta.codes), ch);
		      if ichr > 0	/**/
				/* TEMPORARY IF CLAUSE */
			 & ichr <= hbound (meta.codes, 1)
		      then
		        do;
			if ct > 1 /* if more than one */
			then call ioa_$rsnnl ("<^a*^d>", dstr, 0,
				meta.decodes (ichr), ct);
			else dstr = "<" || meta.decodes (ichr) || ">";
		        end;	/**/
				/* not a known character */
		      else
		        do;
			if ct > 1 /* if more than one */
			then call ioa_$rsnnl ("<<^.3b>" || "*^d>", dstr,
				0, unspec (ch), ct);
			else call ioa_$rsnnl ("<^.3b>", dstr, 0,
				unspec (ch));
		        end;
		    end;

		  ii = ii + ct;
		end;

	        if ch = NL
	        then if nl_sw
		   then dstr = dstr || NL;
	      end;
	  end;			/**/
				/* not a known character */

/*	else
/*	  do;
/*	    call ioa_$rsnnl ("<^.3b>", dstr, 0, unspec (ch));
/*	    ct = 1;
/*	    ii = ii + 1;
/*	  end;*/

	ret_str = ret_str || dstr;
        end;
    end;

display_rtn:
    dlen = ii - 1;
    return (ret_str);		/* end of display */

put_line:				/* to put lines into the block */
  proc (aline_ptr, newtxtptr, tline_ptr, oflo, lead);

    dcl aline_ptr	   ptr;		/* line to be added */
    dcl 1 aline	   aligned like text_entry based (aline_ptr);
    dcl newtxtptr	   ptr;		/* -> new/replacement text */
    dcl tline_ptr	   ptr;		/* target line - if null, new line */
    dcl oflo	   bit (1);	/* overflow switch */
    dcl lead	   fixed bin (31);	/* lead for this line */

    dcl arearel	   fixed bin (18) uns;
    dcl newtxt	   char (1020) var based (newtxtptr);
    dcl newwrds	   fixed bin (18) uns;
    dcl nextrel	   fixed bin (18) uns;
    dcl plead	   fixed bin (31);
    dcl tchars	   fixed bin;	/* count of chars in added text */
				/* txtstr overlay */
    dcl 1 tstr	   based (txtstrptr),
	2 leng	   fixed bin (21),
	2 chars	   char (1020);

    dcl (index, max, size)
		   builtin;

    line_area_ptr = block.line_area.cur;
    text_area_ptr = block.text_area.cur;

    if tline_ptr = null		/* new line wanted? */
    then
      do;
        if line_area.ndx > 0
        then plead = line_area.linptr (line_area.ndx) -> txtlin.linespace;
        else plead = block.parms.linespace;

        block.hdr.count = block.hdr.count + 1;
				/* need a new line structure? */
        if line_area.ndx = line_area.count
        then
	do;			/**/
				/* need a new line area? */
	  if line_area.count = LINE_AREA_SIZE
	  then line_area_ptr, block.line_area.cur =
		  get_line_area (block.line_area.cur);
				/* allocate a new line if needed */
	  if line_area.ndx = line_area.count
	  then
	    do;
	      line_area.count = line_area.count + 1;
	      line_area.linptr (line_area.count) =
		 allocate (const.local_area_ptr, size (text_entry));
	    end;
	end;			/**/
				/* activate the next line */
        line_area.ndx = line_area.ndx + 1;
        txtlinptr = line_area.linptr (line_area.ndx);

        txtlin = aline;		/* move the line */

        block.hdr.modified =		/* do the cbars */
	   block.hdr.modified | txtlin.cbar.mod | txtlin.cbar.add
	   | txtlin.cbar.del;
        if block.parms.cbar.del
        then shared.cbar_type = "";
        block.parms.cbar.del, text_parms.cbar.del = "0"b;
        if txtlinptr ^= aline_ptr
        then aline.cbar.del = "0"b;

        txtlin.art = txtlin.art | aline.art;
        aline.art = current_parms.art;	/**/

        txtlin.linespace = lead;	/* set lead for this line */
				/* depth & space for this line */
        if shared.table_mode & block.hdr.tblblk
	   & (tblcolndx > 0 | tblcolndx = 0 & (tblfillspc | tblcntxt))
        then
	do;
	  txtlin.table = "1"b;
	  txtlin.tblcol = tblcolndx;
	  txtlin.depth = tblcol.depth;
	  tblcol.depth = tblcol.depth + lead;
	  if tblcol.depth > tblfmt.maxdepth
	  then block.hdr.used =
		  block.hdr.used + tblcol.depth - tblfmt.maxdepth;
	  tblfmt.maxdepth = max (tblfmt.maxdepth, tblcol.depth);
	end;

        else block.hdr.used = block.hdr.used + lead;

        if (txtlin.white | newtxt = "") & plead > 0
        then block.hdr.trl_ws = block.hdr.trl_ws + lead;
        else block.hdr.trl_ws = 0;

        oflo = (col.hdr.used + block.hdr.used + col.depth_adj
	   > col.hdr.net + shared.widow_size * current_parms.linespace);
      end;

    else txtlinptr = tline_ptr;	/* no, just replacing text */

    tchars = length (newtxt);
    newwrds = divide (tchars + 7, 4, 17, 0);

    if newwrds > size (string_area)	/* will it fit at all? */
    then
      do;
        call comp_report_$ctlstr (4, 0, addr (ctl.info), ctl_line,
	   "Line has too many characters. Program limit is 1020.");
        newwrds, tchars = 0;
      end;

    nextrel = bin (rel (block.next_text));
    arearel = bin (rel (text_area.strareaptr (text_area.ndx)));
				/* does it overflow current area? */
    if nextrel - arearel + newwrds >= size (string_area)
    then
      do;				/* get a new string area */
        if text_area.ndx = text_area.count
        then
	do;
	  if text_area.count = TEXT_AREA_SIZE
	  then text_area_ptr, block.text_area.cur =
		  get_text_area (block.text_area.cur);
	  else
	    do;
	      text_area.ndx, text_area.count = text_area.count + 1;
	      text_area.strareaptr (text_area.ndx) =
		 allocate (const.local_area_ptr, size (string_area));
	      tblkdata.text_area.string_area_count =
		 tblkdata.text_area.string_area_count + 1;
	    end;
	end;
        else text_area.ndx = text_area.ndx + 1;

        block.next_text = text_area.strareaptr (text_area.ndx);
        arearel, nextrel = bin (rel (block.next_text));
      end;			/**/
				/* text pointer for this line */
    txtstrptr, txtlin.ptr = block.next_text;
    tstr.leng = tchars;		/* add line to text block */
(nostrg):
    substr (tstr.chars, 1, tchars) = substr (newtxt, 1, tchars);

    if tchars > 0 & txtstr ^= " "	/* if not empty or blank */
    then
      do;
        if meas_sw
        then
	do;			/* assure beginning font */
	  unspec (txtlin.cur) = "0"b;
	  txtlin.cur.font = txtlin.font;
	  call comp_measure_ (txtstr, addr (txtlin.cur.font), "0"b,
	       txtlin.art, txtlin.quad, 0, addr (txtlin.cur), addr (meas2),
	       addr (txtlin.info));
	  txtlin.width = txtlin.cur.width + txtlin.cur.avg;
	end;

(nostrg):
        if trflag & search (substr (txtstr, 1, tchars), shared.trans.in) > 0
        then
(nostrg):
	substr (tstr.chars, 1, tchars) = comp_util_$translate (newtxt);

        if esc_flag
        then if index (txtstr, "*") ^= 0
	   then call comp_util_$escape (txtstr, addr (ctl.info));

        block.hdr.white = "0"b;	/* its not white any more */
        if block.blktype = "ws"	/* change block type, too */
        then block.blktype = "tx";
      end;

    if block.parms.keep		/* a keep block? */
    then
      do;
        txtlin.keep = "1"b;
        block.hdr.keep_count = block.hdr.keep_count - 1;
        if block.hdr.keep_count = 0
        then
	do;
	  text_parms.keep, txtlin.keep, block.parms.keep = "0"b;
	  txtlin.end_keep = "1"b;
	end;
      end;			/**/
				/* update next text pointer */
    block.next_text = addrel (block.next_text, newwrds);

/****    if (block.hdr.colno >= 0		/* if block belongs to a column */
/****         | block.blktype = "th")	/* or is a text header */
/****    then if txtstr ^= " "		/* and not a blank line */
/****	    & ^aline.fnt_chng	/* and not a font change string */
/****         then col.hdr.pspc = 0;	/* reset column head space */

    if shared.bug_mode & dt_sw
    then
      do;
        call ioa_$nnl ("^5x(put_line: ^a=^d/^d e^d u^f(^f) ch^d w^f g^d "
	   || "mrg^f/^f/^f fnt=^a ^f", block.blktype, block.blkndx,
	   txtlin.info.lineno, block.hdr.count, show (block.hdr.used, 12000),
	   show (block.hdr.trl_ws, 12000), length (newtxt),
	   show (txtlin.width, 12000), txtlin.cur.gaps,
	   show (txtlin.lmarg, 12000), show (txtlin.rmarg, 12000),
	   show (txtlin.net, 12000), txtlin.font.name,
	   show (txtlin.font.size, 1000));

        if shared.table_mode & block.hdr.tblblk
        then call ioa_$nnl (" tbl=^d/^d d^f/^f", tblcolndx, tblfmtndx,
	        show (tblcol.depth, 12000), show (tblfmt.maxdepth, 12000));

        call ioa_ (") ^[|^]^[*^]^[A^]^[K^]^[^^K^]^[T^]^[H^]"
	   || "^[W^[(n)^]^;^s^]^[ SPCL^]^[FRF^]^/^5x""^a""",
	   (txtlin.cbar.mod | txtlin.cbar.add), txtlin.cbar.del, txtlin.art,
	   txtlin.keep, txtlin.end_keep, txtlin.title, txtlin.hanging,
	   txtlin.white, txtlin.no_trim, (unspec (txtlin.spcl) ^= "0"b),
	   txtlin.footref,
	   comp_util_$display (txtlin.ptr -> txtstr, 0, "0"b));
      end;

  end put_line;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;

    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;

abrtn:
  entry;
    abrt_sw = "1"b;
    return;
abrtf:
  entry;
    abrt_sw = "0"b;
    return;
%page;
%include comp_column;
%include comp_DCdata;
%include comp_dvt;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_metacodes;
%include comp_option;
%include comp_shared;
%include comp_page;
%include comp_stack_box;
%include comp_table;
%include comp_text;
%include comp_tree;
%include comp_varattrs;
%include compstat;
%include translator_temp_alloc;

  end comp_util_;




		    comp_write_page_.pl1            04/23/85  1059.2rew 04/23/85  0910.9      335754



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

/* compose subroutine to write out a page */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

comp_write_page_:
  proc;

/* LOCAL STORAGE */

    dcl BELHT	   char (2) static options (constant) init ("	");
    dcl blkct	   fixed bin;	/* local block counter */
				/* selected block */
    dcl 1 block	   aligned like text based (blkptr);
    dcl blkptr	   ptr;		/* working block pointer */
    dcl BUILD	   fixed bin static options (constant) init (0);
    dcl changed_front  bit (1);
    dcl changed_page   bit (1) init ("0"b);
    dcl col0blk	   fixed bin;	/* ftn/ftr block in col 0 */
    dcl colblkcnt	   fixed bin;	/* local block count */
    dcl colstrt	   fixed bin;	/* column # to start column merge */
    dcl debug_sw	   bit (1);	/* effective debug switch */
    dcl ercd	   fixed bin (35);	/* error code */
    dcl flin_sw	   bit (1);	/* 1= first line of block */
    dcl FN_pic	   pic "zzz";	/* pictured insert file index */
    dcl (i, j, k)	   fixed bin init (0);
    dcl iblk	   fixed bin;	/* block counter */
    dcl icol	   fixed bin;	/* column counter */
    dcl ilin	   fixed bin;	/* line counter */
    dcl INIT	   fixed bin static options (constant) init (1);
				/* last font for annotating */
    dcl last_font	   fixed bin init (-1);
				/* last size for annotating */
    dcl last_size	   fixed bin (31) init (-1);
				/* left margin text image lines */
    dcl lcol_text	   (max_image_lines) char (10) varying
		   based (lcolimage.text_ptr);
    dcl left_margin_note_space	/* space for linenos & cbars */
		   fixed bin (31);
    dcl LN_pic	   pic "zzzzzz";	/* for line numbers option */
    dcl LNdw	   fixed bin (31);	/* line number digit width */
				/* selected column */
    dcl 1 locol	   aligned like col based (locolptr);
    dcl locolptr	   ptr;		/* working column pointer */
    dcl n_read	   fixed bin (35);	/* chars read into user_discard */
    dcl next_depth	   fixed bin (31);	/* next page depth */
    dcl next_rec	   bit (36);	/* for output record control */
    dcl obverse_opt	   bit (1) static	/* dummy until something */
		   init ("0"b);	/* shown in option */
    dcl PADHT	   char (2) static options (constant) init ("	");
				/* the current preface */
    dcl print_sw	   bit (1);	/* local print switch */
    dcl rawo_mode	   bit (1) static	/* 1 = actually in RAWO */
		   init ("0"b);	/**/
				/* right margin text */
    dcl rcol_text	   (max_image_lines) char (128) var
		   based (rcolimage.text_ptr);
    dcl recleng	   fixed bin (24);	/* length of record in words */
    dcl sequential_output
		   fixed bin static options (constant) init (5);
    dcl size_str	   char (16) var;	/* for annotating */
				/* for special output lines */
    dcl spcl_line	   char (1020) var;
    dcl stop_signal	   char (5);	/* 2 ({BEL}||HT)||CR */
    dcl type_font_chars
		   char (2) static options (constant) init ("Ŕ");
    dcl user_discard   char (80);	/* string to support -stop option */
    dcl wt_mark	   char (8) static options (constant) init ("<<.wt>>
");

    dcl str_p	   ptr;
    dcl 1 bstr	   based (str_p),
	2 str_l	   fixed bin,
	2 str	   char (bstr.str_l);

/* EXTERNAL STORAGE */

    dcl (addr, addrel, copy, fixed, index, length, max, null, pointer, rel,
        size, substr)  builtin;

    dcl (comp_abort, quit)
		   condition;

    dcl error_table_$long_record
		   fixed (35) ext static;

    dcl com_err_	   entry options (variable);
    dcl continue_to_signal_
		   entry (fixed bin (35));
    dcl get_temp_segment_
		   entry (char (*), ptr, fixed bin (35));
    dcl ioa_$rsnnl	   entry options (variable);
    dcl iox_$control   entry (ptr, char (*), ptr, fixed (35));
    dcl iox_$get_line  entry (ptr, ptr, fixed (35), fixed (35), fixed (35));
    dcl iox_$modes	   entry (ptr, char (*), char (*), fixed (35));
    dcl iox_$put_chars entry (ptr, ptr, fixed (24), fixed (35));
    dcl iox_$write_record
		   entry (ptr, ptr, fixed bin (24), fixed bin (35));

    debug_sw = shared.bug_mode | db_sw;

    if debug_sw
    then call ioa_ ("write_page: (page=^a^[ MOD^] cols=^d dev=^a)",
	    page.hdr.pageno, page.hdr.modified, page.hdr.col_count,
	    option.device);

    if option.nobell_opt
    then stop_signal = PADHT || PADHT || CR;
    else stop_signal = BELHT || BELHT || CR;

    LNdw = comp_dvt.init_ps;		/* must tackle the problem of what   */
				/*  font and size do line numbers    */
				/*  get set in.  I think they	       */
				/*  should use the superscript       */
				/*  digits as are present on the     */
				/*  CSR font.  Perhaps compdv needs  */
				/*  a control which specifies this   */
				/*  kind of information.	       */

    if (shared.print_flag		/* set local print switch */
         | (option.page_chng_opt & shared.pass_counter <= 1
         & (page.hdr.modified & page.hdr.pgc_select = option.cbar.level
         | page.hdr.dot_addltr = option.pgc_select))) & ^option.check_opt
    then print_sw = "1"b;
    else print_sw = "0"b;

    if print_sw			/* is this page to be printed? */
    then
      do;
        if page.image_ptr = null	/* allocate page image structure */
        then
	do;
	  page.image_ptr =
	       allocate (const.local_area_ptr, size (page_image));
				/* use a temp seg for the actual text 
				/* since we may need a whole segment */
	  call get_temp_segment_ ("compose", page_image.text_ptr, ercd);
	  if ercd ^= 0
	  then
	    do;
	      call com_err_ (ercd, "compose",
		 "Getting a temp segment for the output page image.");
	      signal comp_abort;
	      goto return_;
	    end;
	end;			/**/
				/* initialize writer for this page */
        call comp_dvt.outproc (INIT, ercd);
        if ercd ^= 0
        then
	do;			/* WHAT ABOUT IT ??!! */
	end;

        page_image.count = 0;		/* clear page image */
				/* set file id */
        page_image.file_id = shared.output_file;
        page_image.func = BUILD;	/* set function to build */
        record_ptr = page_image.text_ptr;

        if option.number_opt		/* line numbers or change bars? */
	   | option.cbar_opt & ^option.galley_opt & option.cbar.place ^= "r"
	   | page.hdr.col_count > 1
        then
	do;
	  if page.col_image_ptr (-1) = null ()
	  then
	    do;			/* allocate left margin column */
	      page.col_image_ptr (-1) =
		 allocate (const.local_area_ptr, size (lcolimage));
	      unspec (lcolimage) = "0"b;
	      lcolimage.text_ptr =
		 allocate (const.local_area_ptr, size (lcol_text));
	    end;

	  lcolimage.count = 0;	/* clear the image */
				/* so 1st line gets a lineno */
	  lcolimage.line (1).depth = -1;
	end;			/**/
				/* change bars or annotating? */
        if option.cbar_opt | option.annot_opt | annot_sw
        then
	do;
	  if page.col_image_ptr (-2) = null ()
	  then
	    do;			/* allocate right margin column */
	      page.col_image_ptr (-2) =
		 allocate (const.local_area_ptr, size (rcolimage));
	      unspec (rcolimage) = "0"b;
	      rcolimage.text_ptr =
		 allocate (const.local_area_ptr, size (rcol_text));
	    end;

	  rcolimage.count = 0;	/* clear it */
				/* so 1st line gets a mark */
	  rcolimage.line (1).depth = -1;
	end;

        left_margin_note_space =
	   10 * LNdw * fixed (option.number_opt)
	   * (bin (^option.galley_opt) * page.hdr.col_count + 1)
	   + page.hdr.lmarg + option.extra_indent;

        if option.cbar_opt & ^option.galley_opt & option.cbar.place ^= "r"
        then
	do;
	  if page.parms.cols.count = 0
	  then left_margin_note_space =
		  left_margin_note_space + option.cbar.space;
	  else if option.cbar.space > col1.margin.left
	  then left_margin_note_space =
		  left_margin_note_space + option.cbar.space
		  - col0.margin.left;
	end;
      end;			/**/
				/* have to go thru the motions here */
				/* for possible hit and toc lines in */
				/* the image */
col_loop:				/* build image for each column */
    do icol = 0 to page.hdr.col_count;
      locolptr = page.column_ptr (icol);

      if print_sw
      then
        do;
	if page.col_image_ptr (icol) = null ()
	then page.col_image_ptr (icol) =
		allocate (const.local_area_ptr, size (colimage));
	colimage_ptr = page.col_image_ptr (icol);
	colimage.count = 0;		/* clear column image */

	if debug_sw
	then call ioa_ ("^5x(col=^d b=^d u=^f mrg=^f/^f lmrg=^f)"
		|| "^[^/bk ct fn/ln  ch gp   lmarg   rmarg   width   "
		|| "depth    lead set^]", icol, locol.hdr.blkct,
		show (locol.hdr.used, 12000),
		show (locol.margin.left, 12000),
		show (locol.margin.right, 12000),
		show (left_margin_note_space, 12000),
		(locol.hdr.blkct > 0));
        end;

      colblkcnt = locol.hdr.blkct;

      do iblk = 1 to colblkcnt;	/* for each block in the column */
        blkptr = locol.blkptr (iblk);
        flin_sw = "1"b;		/* set first line on */

        if blkptr ^= null
        then call build_block_image (max (0, bin (^option.galley_opt) * icol));
      end;
    end col_loop;			/* end of first column loop */

    if print_sw			/* now gather all the column images */
    then				/* and merge them into the page image */
      do;
        if option.number_opt |	/* set starting column for merge */
	   option.cbar_opt & ^option.galley_opt & option.cbar.place ^= "r"
	   | page.hdr.col_count > 1
        then colstrt = -1;
        else colstrt = 0;

        do icol = colstrt to page.hdr.col_count;
	colimage_ptr = page.col_image_ptr (icol);
				/* add column image to page image */
	addr (page_image.line (page_image.count + 1)) -> image_lines =
	     addr (colimage.line (1)) -> image_lines;
	page_image.count = page_image.count + colimage.count;
        end;			/**/
				/* next, add the right margin column */
        if option.cbar_opt | option.annot_opt | annot_sw
        then
	do;
	  colimage_ptr = page.col_image_ptr (-2);
	  addr (page_image.line (page_image.count + 1)) -> image_lines =
	       addr (colimage.line (1)) -> image_lines;
	  page_image.count = page_image.count + colimage.count;
	end;

        if (option.number_opt		/* if line numbers are active */
	   | option.cbar_opt	/* or change bars are active */
	   | page.hdr.art		/* or theres page artwork */
	   | option.annot_opt | annot_sw
				/* or annotating */
	   | page.hdr.col_count > 0)	/* or a multi-column page */
	   & comp_dvt.interleave	/* and device needs interleaving */
        then colimage_ptr = page.image_ptr;

        if ^option.page_chng_opt	/* printing everything? */
        then goto do_processing;	/* ...then do it */

        changed_front = record.changed & record.front;
				/* remember status of prev page */

        if ^obverse_opt		/* not concerned with obverse pages? */
        then
	do;
	  if changed_page		/* then print only if changed */
	  then goto do_processing;
	  goto skip_page;
	end;

        if page.hdr.frontpage
        then
	do;
	  if record.pending
	  then ;			/* error: 2 fronts in a row! */
	  goto do_processing;
	end;

        if changed_front
        then
	do;
	  goto do_processing;
	end;

        if ^record.pending
        then
	do;			/* error: 2 backs in a row */
	end;

do_processing:
        if option.wait_opt & ^option.output_file_opt
        then
	do;
	  if wait_ () = ""
	  then ;
	  option.wait_opt = "0"b;	/* reset -wait after one time */
	end;

        record.MBZ = "0"b;
        record.changed = changed_page;

        if option.galley_opt
        then
	do;
	  record.pageid = "-1";
	  record.front = "1"b;
	end;

        else
	do;
	  record.pageid = page.hdr.pageno;
	  record.front = page.hdr.frontpage;
	  record.blank = page.hdr.blankpage;
	end;

        if page_image.count > 0	/* build the page image */
        then
	do;
	  call comp_dvt.outproc (BUILD, ercd);
	  if ercd ^= 0
	  then call comp_report_ (2, ercd, "While in output writer.",
		  addr (ctl.info), "");

	  if option.page_chng_opt
	  then if ^(changed_page | changed_front)
	       then goto return_;

	  call print_page;		/* write the current page image */
	end;
      end;

skip_page:
    if ^option.galley_opt
    then
      do;
        do i = 0 to page.hdr.col_count; /* return all blocks printed */
	locolptr = page.column_ptr (i);
	blkct = locol.hdr.blkct;
	do j = 1 to blkct;
	  if shared.blkptr = locol.blkptr (j)
	  then shared.blkptr = null ();
	  if locol.blkptr (j) ^= null
	  then call comp_util_$relblk (i, locol.blkptr (j));
	end;
        end;
      end;

return_:
    if debug_sw
    then call ioa_ ("     (write_page page=^a)", page.hdr.pageno);
    return;
%page;
build_block_image:
  proc (jcol);

    dcl jcol	   fixed bin;
    dcl jlin	   fixed bin;

    jlin = 0;
    do line_area_ptr = block.line_area.first repeat (line_area.next)
         while (line_area_ptr ^= null & jlin < block.hdr.count);
      do ilin = 1 to line_area.ndx;
        txtlinptr = line_area.linptr (ilin);
        txtstrptr = txtlin.ptr;
        jlin = jlin + 1;		/**/
				/* if not a null line */
        if ^(txtstr = "" & txtlin.linespace = 0)
        then
	do;
	  if debug_sw & print_sw
	  then call ioa_$nnl ("^[^2i^3i^;^5x^]", flin_sw, block.blkndx,
		  block.hdr.count);
	  flin_sw = "0"b;

	  if txtlin.spcl.file	/* special output line? */
	  then
	    do;
	      if debug_sw & print_sw
	      then call ioa_ ("^3i/^d^12tspecial line", ilin, txtlin.lineno);

	      if txtlin.spcl_iocbp = null ()
	      then
	        do;
		call comp_report_ (4, 0,
		     "Program error. No IOCB pointer for special line.",
		     addr (txtlin.info), txtstr);
		signal comp_abort;
		return;
	        end;

	      if txtlin.default	/* a hit line? */
	      then call ioa_$rsnnl ("^a ^a^/", spcl_line, 0, txtstr,
		      page.hdr.pageno);
	      else spcl_line = txtstr;

	      call iox_$put_chars (txtlin.spcl_iocbp,
		 addrel (addr (spcl_line), 1), length (spcl_line), ercd);
	      if ercd ^= 0
	      then
	        do;
		call comp_report_ (4, ercd, "Writing special output line.",
		     addr (txtlin.info), txtstr);
		signal comp_abort;
		return;
	        end;
	    end;

	  else if print_sw
	  then
	    do;
	      if colimage.count = 0	/* set column depth */
	      then next_depth = txtlin.depth;

	      else if txtlin.depth > next_depth
	      then next_depth = txtlin.depth;

	      j, colimage.count = colimage.count + 1;
				/* if line numbers are wanted */
	      if option.number_opt	/* and not white space */
	      then if txtlin.ptr -> txtstr ^= ""
				/* and there isnt one at this depth */
				/* for this column */
		      & lcolimage.line (max (lcolimage.count, 1)).depth
		      ^= txtlin.depth
		      | (lcolimage.line (max (lcolimage.count, 1)).depth
		      = txtlin.depth
		      & lcolimage.line (max (lcolimage.count, 1)).lmarg
		      ^= LNdw * 10 * jcol)
		 then
		   do;		/* form line number */
		     FN_pic = txtlin.info.fileno;
		     LN_pic = txtlin.info.lineno;

		     i, lcolimage.count = lcolimage.count + 1;
		     lcolimage.line (i).ptr = addr (lcol_text (i));
		     lcolimage.line (i).lfnt = 2;
		     lcolimage.line (i).lsize = LNdw;
		     lcolimage.line (i).depth = txtlin.depth;
		     lcolimage.line (i).width = LNdw * 10;
		     lcolimage.line (i).lmarg = LNdw * 10 * jcol;
		     lcolimage.line (i).rmarg = LNdw * 10 * (jcol + 1);
		     lcolimage.line (i).lead = 0;
		     lcolimage.line (i).mrgtxt = "1"b;
		     lcolimage.line (i).info = txtlin.info;

		     if jcol < page.hdr.col_count & ^option.galley_opt
		     then lcol_text (i) = FN_pic || LN_pic || "|";
		     else lcol_text (i) = FN_pic || LN_pic || " ";
		   end;

	      if option.cbar_opt	/* if change bars are active */
		 & unspec (txtlin.cbar) ^= "0"b
	      then call add_cbars;

	      colimage.line (j).ptr = txtlin.ptr;
	      colimage.line (j).depth = txtlin.depth;
	      colimage.line (j).lmarg =
		 locol.margin.left + left_margin_note_space + txtlin.lmarg;
	      colimage.line (j).rmarg =
		 locol.margin.left + left_margin_note_space + txtlin.rmarg;
	      colimage.line (j).net = txtlin.net;
	      colimage.line (j).width = txtlin.width;
	      colimage.line (j).lfnt = txtlin.font.devfnt;
	      colimage.line (j).lsize = txtlin.font.size;
	      colimage.line (j).quad = txtlin.quad;
	      colimage.line (j).white = txtlin.white;
	      colimage.line (j).gaps = txtlin.cur.gaps;
	      colimage.line (j).lead = txtlin.linespace;
	      colimage.line (j).info = txtlin.info;

	      if txtlin.quad = quado
	      then if page.hdr.frontpage
		 then colimage.line (j).quad = quadr;
		 else colimage.line (j).quad = quadl;

	      if txtlin.quad = quadi
	      then if ^page.hdr.frontpage
		 then colimage.line (j).quad = quadr;
		 else colimage.line (j).quad = quadl;

	      if debug_sw & print_sw
	      then call ioa_ ("^3d/^d^8t^3i^3i^5(^8f^)  ^[I^]^[O^]"
		      || "^[L^]^[C^]^[R^]^[J^]^[|^]^[*^]", txtlin.fileno,
		      txtlin.lineno, length (txtstr), txtlin.cur.gaps,
		      show (colimage.line (j).lmarg, 12000),
		      show (colimage.line (j).rmarg, 12000),
		      show (txtlin.width, 12000),
		      show (txtlin.depth, 12000),
		      show (txtlin.linespace, 12000), txtlin.quad & quadi,
		      txtlin.quad & quado,
		      (txtlin.quad & quadl | txtlin.quad = "0"b),
		      txtlin.quad & quadc, txtlin.quad & quadr,
		      txtlin.quad & just,
		      (txtlin.cbar.mod | txtlin.cbar.add), txtlin.cbar.del)
		      ;		/* annotation wanted? */
	      if (option.annot_opt | annot_sw) & txtstr ^= ""
				/* dont annotate WS */
	      then
	        do;
		i = rcolimage.count;/* current rcol line index */
				/* new font for this line? */
		if last_font ^= txtlin.font.devfnt
		     | last_size ^= txtlin.font.size
		then
		  do;
		    last_font = txtlin.font.devfnt;
				/* record it */
		    last_size = txtlin.font.size;

		    call ioa_$rsnnl ("^f", size_str, 0,
		         show (last_size, 1000));

		    if i > 0	/* adding one? */
		         & rcolimage.line (i).depth = txtlin.depth
		    then rcol_text (i) =
			    rcol_text (i) || " - "
			    || fnttbldata.ptr (last_font)
			    -> fnttbl.entry.name || " " || size_str;

		    else
		      do;		/* first for this line */
		        i, rcolimage.count = rcolimage.count + 1;
		        rcol_text (i) =
			   " - "
			   || fnttbldata.ptr (last_font)
			   -> fnttbl.entry.name || " " || size_str;
		        rcolimage.line (i).ptr = addr (rcol_text (i));
		        rcolimage.line (i).lfnt = 2;
		        rcolimage.line (i).lsize = LNdw;
		        rcolimage.line (i).depth = txtlin.depth;
		        rcolimage.line (i).lmarg =
			   col0.margin.right + left_margin_note_space
			   + 21600 * bin (option.cbar_opt);
		        rcolimage.line (i).rmarg = 950400;
		        rcolimage.line (i).net =
			   rcolimage.line (i).rmarg
			   - rcolimage.line (i).lmarg;
		        rcolimage.line (i).width = 0;
		        rcolimage.line (i).mrgtxt = "1"b;
		        rcolimage.line (i).lead = block.parms.linespace;
		        rcolimage.line (i).info = txtlin.info;
		      end;
		  end;		/* look for embedded changes */
		if index (txtstr, type_font_chars) ^= 0
		then
		  do;
		    if i > 0 & rcolimage.line (i).depth = txtlin.depth
		    then ;

		    else
		      do;
		        i, rcolimage.count = rcolimage.count + 1;
		        call ioa_$rsnnl ("^f", size_str, 0,
			   show (txtlin.font.size, 1000));
		        rcol_text (i) =
			   " - " || rtrim (txtlin.font.fam_name)
			   || rtrim (txtlin.font.mem_name) || " "
			   || size_str;
		        rcolimage.line (i).ptr = addr (rcol_text (i));
		        rcolimage.line (i).lfnt = 2;
		        rcolimage.line (i).lsize = LNdw;
		        rcolimage.line (i).depth = txtlin.depth;
		        rcolimage.line (i).lmarg =
			   col0.margin.right + left_margin_note_space
			   + 21600 * bin (option.cbar_opt);
		        rcolimage.line (i).rmarg =
			   rcolimage.line (i).lmarg + 921600;
		        rcolimage.line (i).net =
			   rcolimage.line (i).rmarg
			   - rcolimage.line (i).lmarg;
		        rcolimage.line (i).width = 0;
		        rcolimage.line (i).lead = block.parms.linespace;
		        rcolimage.line (i).info = txtlin.info;
		      end;

		    j, k = 1;
		    do while (k ^= 0 & j < length (txtstr));
		      k = index (substr (txtstr, j), type_font_chars);

		      if k > 0
		      then
		        do;
			DCxx_p = addr (substr (txtstr, j + k - 1, 1));

			last_size = dcfs.p;
			last_font = dcfs.f;

			call ioa_$rsnnl ("^f", size_str, 0,
			     show (last_size, 1000));
			rcol_text (i) =
			     rcol_text (i) || " - "
			     || fnttbldata.ptr (last_font)
			     -> fnttbl.entry.name || " " || size_str;
			j = j + k + dcfs_len + 3;
		        end;
		    end;
		  end;
	        end;

	      changed_page =
		 changed_page | txtlin.cbar.mod | txtlin.cbar.add
		 | txtlin.cbar.del; /* next depth in column */
	      next_depth = next_depth + txtlin.linespace;
	    end;
	end;
      end;
    end;
  end build_block_image;
%page;
add_cbars:
  proc;				/* add change bars to line */

    if page.hdr.col_count <= 1	/* one-up */
         | icol = 0 | option.galley_opt /* or column 0 of multicolumn */
    then
      do;
        if (option.cbar.place = "l" |	/* marking the left margin? */
	   option.cbar.place = "o" & ^page.hdr.frontpage
	   | option.cbar.place = "i" & page.hdr.frontpage)
	   & ^option.galley_opt
        then
	do;
	  i = max (lcolimage.count, 1);
				/* if there isnt one at this depth */
	  if (lcolimage.line (i).depth ^= txtlin.depth
	       | lcolimage.line (i).rmarg
	       > lcolimage.line (i).lmarg + option.cbar.space)
	  then
	    do;
	      i, lcolimage.count = lcolimage.count + 1;
	      lcolimage.line (i).ptr = addr (lcol_text (i));
	      lcolimage.line (i).lfnt = 2;
	      lcolimage.line (i).lsize = 14000;
	      lcolimage.line (i).quad = quadl;
	      lcolimage.line (i).depth = txtlin.depth;
	      lcolimage.line (i).lmarg =
		 left_margin_note_space - option.cbar.space;
	      if page.parms.cols.count > 0
	      then lcolimage.line (i).lmarg =
		      lcolimage.line (i).lmarg + col1.margin.left;
	      lcolimage.line (i).rmarg =
		 lcolimage.line (i).lmarg + option.cbar.space;
	      lcolimage.line (i).width = 0;
	      lcolimage.line (i).lead = 0;
	      lcolimage.line (i).art = option.cbar_art_opt;
	      lcolimage.line (i).cbar = "1"b;
	      lcolimage.line (i).info = txtlin.info;
				/* need a mod mark */
	      if (txtlin.cbar.mod | txtlin.cbar.add)
	      then lcol_text (i) = option.cbar.left.mark;
				/* need a del mark */
	      else if txtlin.cbar.del
	      then lcol_text (i) = option.cbar.del.mark;
	    end;
	end;

        if (option.cbar.place = "r"	/* marking the right margin */
	   | page.hdr.col_count > 1
	   | option.cbar.place = "i" & ^page.hdr.frontpage
	   | option.cbar.place = "o" & page.hdr.frontpage
	   | option.galley_opt)	/* and there isnt one at this depth */
	   & rcolimage.line (max (rcolimage.count, 1)).depth ^= txtlin.depth
        then
	do;
	  i, rcolimage.count = rcolimage.count + 1;
	  rcolimage.line (i).ptr = addr (rcol_text (i));
	  rcolimage.line (i).lfnt = 2;
	  rcolimage.line (i).lsize = 14000;
	  rcolimage.line (i).quad = quadr;
	  rcolimage.line (i).depth = txtlin.depth;
	  rcolimage.line (i).lmarg =
	       left_margin_note_space
	       + page.column_ptr (icol) -> col.margin.right;
	  rcolimage.line (i).rmarg =
	       rcolimage.line (i).lmarg + option.cbar.right.sep
	       + option.cbar.right.width;
	  rcolimage.line (i).net =
	       rcolimage.line (i).rmarg - rcolimage.line (i).lmarg;
	  rcolimage.line (i).lead = block.parms.linespace;
	  rcolimage.line (i).art = option.cbar_art_opt;
	  rcolimage.line (i).cbar = "1"b;
	  rcolimage.line (i).info = txtlin.info;
				/* need a mod mark? */
	  if (txtlin.cbar.mod | txtlin.cbar.add)
	  then
	    do;
	      rcol_text (i) = option.cbar.right.mark;
	      rcolimage.line (i).width = option.cbar.right.width;
	    end;

	  else if txtlin.cbar.del	/* need a del mark? */
	  then
	    do;
	      rcol_text (i) = option.cbar.del.mark;
	      rcolimage.line (i).width = option.cbar.del.width;
	    end;
	end;
      end;

    else if page.hdr.col_count = 2	/* 2-up change bars */
    then
      do;
        if icol = 1			/* left margin for column 1 */
	   & (txtlin.cbar.mod | txtlin.cbar.add | txtlin.cbar.del)
        then
	do;
	  i = max (lcolimage.count, 1);
				/* if there isnt one at this depth */
	  if (lcolimage.line (i).depth ^= txtlin.depth
	       | lcolimage.line (i).rmarg
	       > lcolimage.line (i).lmarg + option.cbar.space)
	  then
	    do;
	      i, lcolimage.count = lcolimage.count + 1;
	      lcolimage.line (i).ptr = addr (lcol_text (i));
	      lcolimage.line (i).lfnt = 2;
	      lcolimage.line (i).lsize = 14000;
	      lcolimage.line (i).quad = quadl;
	      lcolimage.line (i).depth = txtlin.depth;
	      lcolimage.line (i).lmarg =
		 page.hdr.lmarg
		 + LNdw * 10 * fixed (option.number_opt)
		 * (page.hdr.col_count + 1) + option.extra_indent;
	      lcolimage.line (i).rmarg =
		 lcolimage.line (i).lmarg + option.cbar.space;
	      lcolimage.line (i).width = 0;
	      lcolimage.line (i).lead = 0;
	      lcolimage.line (i).art = option.cbar_art_opt;
	      lcolimage.line (i).info = txtlin.info;

	      if (txtlin.cbar.mod | txtlin.cbar.add)
				/* need a mod mark */
	      then lcol_text (i) = option.cbar.left.mark;

	      else if txtlin.cbar.del /* need a del mark */
	      then lcol_text (i) = option.cbar.del.mark;
	    end;
	end;

        else if (txtlin.cbar.mod | txtlin.cbar.add | txtlin.cbar.del)
				/* and there isnt one at this depth */
	   & rcolimage.line (max (rcolimage.count, 1)).depth ^= txtlin.depth
        then
	do;			/* right margin for column 2 */
	  i, rcolimage.count = rcolimage.count + 1;
	  rcolimage.line (i).ptr = addr (rcol_text (i));
	  rcolimage.line (i).lfnt = 2;
	  rcolimage.line (i).lsize = 14000;
	  rcolimage.line (i).quad = quadr;
	  rcolimage.line (i).depth = txtlin.depth;
	  rcolimage.line (i).lmarg =
	       left_margin_note_space
	       + page.column_ptr (2) -> col.margin.right;
	  rcolimage.line (i).rmarg =
	       rcolimage.line (i).lmarg + option.cbar.right.sep
	       + option.cbar.right.width;
	  rcolimage.line (i).net =
	       rcolimage.line (i).rmarg - rcolimage.line (i).lmarg;
	  rcolimage.line (i).lead = block.parms.linespace;
	  rcolimage.line (i).art = option.cbar_art_opt;
	  rcolimage.line (i).cbar = "1"b;
	  rcolimage.line (i).info = txtlin.info;

	  if (txtlin.cbar.mod | txtlin.cbar.add)
				/* need a mod mark */
	  then rcol_text (i) = option.cbar.right.mark;

	  else if txtlin.cbar.del	/* need a del mark */
	  then rcol_text (i) = option.cbar.del.mark;
	end;
      end;

    else
      do;				/* multicolumn change bars ???? */
      end;
  end add_cbars;
%page;
print_page:
  proc;

    dcl change_signal  char (128);
    dcl first_sw	   bit (1) init ("1"b);
    dcl mounted_wheel  fixed bin static init (1);
    dcl 1 preface	   aligned like page_record based (page_record_ptr);
    dcl PREFACE	   char (500) varying static;

    record.pending = "0"b;		/**/
				/* if outputting to a file */
    if option.output_file_opt		/* and its a sequential file */
         & comp_dvt.open_mode = sequential_output
    then
      do;
        page_record_ptr = addr (page_image.text_ptr -> record.page_record);

        if shared.compout_not_headed	/* write file header */
        then
	do;			/* set length of cleanup string */
	  if comp_dvt.cleanup_r = "0"b
	  then l_cleanup = 0;
	  else
	    do;
	      str_p = pointer (const.devptr, comp_dvt.cleanup_r);
	      l_cleanup = 4 * divide (bstr.str_l + 3, 4, 17, 0);
	    end;			/**/
				/* set length of comment string */
	  if comp_dvt.comment_r = "0"b
	  then l_comment = 0;
	  else
	    do;
	      str_p = pointer (const.devptr, comp_dvt.comment_r);
	      l_comment = 4 * divide (bstr.str_l + 3, 4, 17, 0);
	    end;

	  begin;
	    dcl 1 file_header  aligned like fileheader;
	    file_header.version = filedata_version_4;
	    file_header.device_class = comp_dvt.devclass;
	    file_header.device_name = comp_dvid.devname;
	    file_header.device = option.device;
	    file_header.recleng = comp_dvt.recleng;
	    file_header.max_pages = comp_dvt.max_pages;
	    file_header.max_files = comp_dvt.max_files;
	    file_header.page_len = page.parms.length;

	    file_header.cleanup_leng = l_cleanup;
	    if l_cleanup > 0
	    then
	      do;
	        str_p = pointer (const.devptr, comp_dvt.cleanup_r);
	        file_header.cleanup = bstr.str;
	      end;

	    file_header.comment_leng = l_comment;
	    if l_comment > 0
	    then
	      do;
	        str_p = pointer (const.devptr, comp_dvt.comment_r);
	        file_header.comment = bstr.str;
	      end;

	    call iox_$write_record ((shared.compout_ptr), addr (file_header),
	         4 * size (file_header), ercd);
	    if ercd ^= 0
	    then goto ioerr;
	    shared.compout_not_headed = "0"b;
	  end;
	end;

        next_rec = "1"b;
        do page_record_ptr = page_record_ptr
	   repeat (addr (page_record.nextref)) while (next_rec ^= "0"b);
	recleng =
	     bin (rel (addr (page_record.nextref)))
	     - bin (rel (page_image.text_ptr));
	next_rec = page_record.nextref;
        end;

        call iox_$write_record ((shared.compout_ptr),
				/* write page image */
	   (page_image.text_ptr), 4 * recleng, ercd);
        if ercd ^= 0
        then goto ioerr;
      end;

    else
      do;				/* stream output - file or terminal */
reprint:
        page_record_ptr = addr (page_image.text_ptr -> record.page_record);
        next_rec = "1"b;

        do page_record_ptr = page_record_ptr
	   repeat (addr (page_record.nextref)) while (next_rec ^= "0"b);

	if first_sw & page_record.preface
				/* if this is the first preface */
	then
	  do;
	    PREFACE = page_record.text;
	    first_sw = "0"b;
	  end;

	if ^page_record.preface	/* if this isnt a preface */
	     | page_record.text ^= PREFACE
				/* or is a different preface */
	then			/* we need to print it */
	  do;			/* if not writing through vfile_ */
	    if ^option.output_file_opt/* and not file_output */
	         & iox_$user_output -> iocb.syn_father -> iocb.name
	         = "user_i/o"
	    then
	      do;
	        if page_record.rawo	/* does the device want RAWO? */
	        then
		do;
		  call iox_$modes (iox_$user_output, "rawo", "", ercd);
		  if ercd ^= 0
		  then
		    do;
		      call comp_report_ (2, ercd, "Setting RAWO mode.",
			 addr (ctl.info), "");
		      return;
		    end;
		  rawo_mode = "1"b; /* note that we are now in RAWO */

		  on quit		/* handler goes away at block exit */
		    begin;
		      call iox_$control (iox_$user_output, "resetwrite",
			 null (), ercd);
		      call clean_;
		      call continue_to_signal_ (ercd);
		    end;		/**/
				/* handler goes away at block exit */
		  on cleanup call clean_;
		end;		/**/
				/* need a print wheel change? */
	        if preface.pwheel > 0 & preface.pwheel ^= mounted_wheel
	        then
		do;
		  if option.nobell_opt
		  then change_signal = copy (PADHT, preface.pwheel);
		  else change_signal = copy (BELHT, preface.pwheel);

		  call iox_$control (iox_$user_input, "resetread", null (),
		       ercd);
		  call iox_$put_chars (iox_$user_output,
		       addr (change_signal), 2 * preface.pwheel, ercd);
		  call iox_$get_line (iox_$user_input, addr (user_discard),
		       80, n_read, ercd);
		  call iox_$put_chars (iox_$user_output,
		       addr (stop_signal), 5, ercd);
		  call iox_$get_line (iox_$user_input, addr (user_discard),
		       80, n_read, ercd);
		end;		/**/

	        call iox_$put_chars (shared.compout_ptr,
		   addr (substr (page_record.text, 1)), page_record.leng,
		   ercd);
	        if ercd ^= 0
	        then goto ioerr;

	        if page_record.halt4	/* mid-page wait		       */
	        then
		do;
		  call iox_$control (iox_$user_input, "resetread", null (),
		       ercd);
		  if option.nobell_opt
		  then call ioa_$nnl ("");
				/* null string */
		  else call ioa_$nnl ("");
				/* BELL		       */
		  call iox_$modes (iox_$user_output, "rawo", "", ercd);
		  if ercd ^= 0
		  then
		    do;
		      call comp_report_ (2, ercd, "Setting RAWO mode.",
			 addr (ctl.info), "");
		      return;
		    end;
		  call iox_$get_line (iox_$user_input, addr (user_discard),
		       80, n_read, ercd);
		  call iox_$modes (iox_$user_output, "^rawo", "", ercd);
				/* leave RAWO mode */
		  page_record.halt4 = "0"b;
		end;
	      end;

	    else
	      do;			/* write image to compout file */
	        call iox_$put_chars ((shared.compout_ptr),
		   addr (page_record.text), page_record.leng, ercd);
	        if ercd ^= 0
	        then
		do;
ioerr:
		  call comp_report_ (2, ercd,
		       "Writing compout for page " || page.hdr.pageno,
		       addr (ctl.info), "");
		  signal cleanup;
		  return;
		end;

	        if page_record.halt4	/* mid-page wait		       */
	        then call iox_$put_chars ((shared.compout_ptr),
		        addr (wt_mark), length (wt_mark), ercd);
	      end;
	  end;
	if page_record.preface	/* if this is a preface, */
	then PREFACE = page_record.text;
				/* remember it for future reference */
	next_rec = page_record.nextref;
        end;

        if rawo_mode
        then call clean_;

        if option.stop_opt & ^option.output_file_opt
				/* stop wanted? */
	   & ^option.galley_opt	/* and not galley */
        then if wait_ () = "r"
	   then goto reprint;
      end;
  end print_page;
%page;
wait_:
  proc returns (char (1));

    if ^option.wait_opt		/* if the wait flag is not set */
    then call iox_$control (iox_$user_input, "resetread", null (), ercd);
				/* set RAWO mode */
    call iox_$modes (iox_$user_output, "rawo", "", ercd);
				/* emit the stop signal */
    call iox_$put_chars (iox_$user_output, addr (stop_signal), 5, ercd);
				/* leave RAWO mode */
    call iox_$modes (iox_$user_output, "^rawo", "", ercd);

    call iox_$get_line (iox_$user_input, addr (user_discard), 80, n_read, ercd)
         ;
    if ercd ^= 0 & ercd ^= error_table_$long_record
    then
      do;
        call comp_report_ (2, ercd, "Attempting stop/wait option.",
	   addr (ctl.info), "");
        goto quit_;
      end;

    if n_read > 1
    then
      do;				/* quit? */
        if substr (user_discard, 1, 1) = "q"
	   | substr (user_discard, 1, 1) = "Q"
        then
	do;
quit_:
	  signal comp_abort;
	  return ("");
	end;

        if substr (user_discard, 1, 1) = "r"
				/* reprint? */
	   | substr (user_discard, 1, 1) = "R"
        then return ("r");
      end;

    return ("");
  end wait_;

clean_:
  proc;

    dcl clean_strp	   ptr;

    if rawo_mode			/* do only if we are really in RAWO */
    then
      do;				/* if device has a cleanup string */
        if comp_dvt.cleanup_r ^= "0"b
        then
	do;
	  clean_strp = pointer (const.devptr, comp_dvt.cleanup_r);
	  call iox_$put_chars (iox_$user_output,
	       addrel (addr (clean_strp -> txtstr), 1),
	       length (clean_strp -> txtstr), ercd);
	  if ercd ^= 0
	  then call comp_report_ (2, ercd, "Attempting device cleanup.",
		  addr (ctl.info), "");
	end;

        call iox_$put_chars (iox_$user_output, addr (CR), 1, ercd);

        call iox_$modes (iox_$user_output, "^rawo", "", ercd);
				/* leave RAWO mode */
        if ercd ^= 0 & ^debug_sw
        then call comp_report_ (2, ercd, "Resetting RAWO mode.",
	        addr (ctl.info), "");
        rawo_mode = "0"b;		/* reset flag so clean_ wont try again */
      end;

  end clean_;
%page;
show:
  proc (datum, scale) returns (fixed dec (11, 3));
    dcl datum	   fixed bin (31);
    dcl scale	   fixed bin (31);

    return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3));
  end show;

    dcl alloc_sw	   bit (1) static init ("0"b);
    dcl get_pdir_	   entry returns (char (168));
    dcl list	   entry options (variable);
    dcl annot_sw	   bit (1) static init ("0"b);
ann:
  entry;
    annot_sw = "1"b;
    return;
anf:
  entry;
    annot_sw = "0"b;
    return;
    dcl db_sw	   bit (1) static init ("0"b);
dbn:
  entry;
    db_sw = "1"b;
    return;
dbf:
  entry;
    db_sw = "0"b;
    return;
%page;
%include comp_column;
    dcl 1 col1	   aligned like col based (page.column_ptr (1));
%include comp_DCdata;
%include comp_entries;
%include comp_fntstk;
%include comp_font;
%include comp_metacodes;
%include comp_option;
%include comp_output;
/* madeup column image */
    dcl 1 colimage	   aligned like page_image based (colimage_ptr);
    dcl colimage_ptr   ptr;		/* current col image block pointer */
				/* main body text image lines */
    dcl 1 image_lines  (colimage.count) like page_image.line based;
				/* left margin column image - this
				   column holds line numbers and left
				   margin change bars */
    dcl 1 lcolimage	   aligned like page_image based (page.col_image_ptr (-1));
				/* right margin column image */
    dcl 1 rcolimage	   aligned like page_image based (page.col_image_ptr (-2));
%include comp_page;
%include comp_shared;
%include comp_text;
%include comp_dvid;
%include comp_dvt;
%include comp_tree;
%include compstat;
%include iocbx;
%include translator_temp_alloc;

  end comp_write_page_;




		    compose.pl1                     04/23/85  1059.2rew 04/23/85  0908.5      490347



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

/* An advanced feature text formatting program based on the concepts of runoff.

   The essential features of runoff are retained and many new, advanced
   features are added. The formatting and processing algorithms are grossly
   different. */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */

compose:
comp:
  proc;

/* GLOBAL INITIALIZE */

    compose_severity_ = 5;		/* all command line errors abort */
    unspec (null_info) = "0"b;

/* check for recursive invocation */
    if re_call
    then
      do;				/* if this flag is set, then */
        if substr (ips_mask, 36, 1)	/* ips_mask is off, turn it back on */
        then call hcs_$reset_ips_mask (ips_mask, ips_mask);

        call com_err_ (0, "compose",
	   " A prior invocation has been interrupted.^/^-Type 'start', "
	   || "'release', or 'program_interrupt' to finish it.");
        return;
      end;

here:				/* "Where we are?" */
    call hcs_$fs_get_path_name (codeptr (here), compose_dir, 0, "", ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose",
	   "Setting referencing dir (dir containing compose).");
        return;
      end;			/**/
				/* set constants structure pointer */
    compstat$compconst.ptr = addr (compstat$compconst.ptr);

    if dt_sw
    then call ioa_ ("^a (Vers. ^a)", rtrim (compose_dir),
	    compstat$compconst.comp_version);

    if const.version ^= const_version	/* bad version? */
    then
      do;
        call com_err_ (error_table_$unimplemented_version, "compose",
	   "Program constants structure.");
        return;
      end;

    const.comp_dir = compose_dir;

/* establish the cleanup handler */
    on cleanup call comp_cleanup;	/* comp_init_ might signal it */
    re_call = "1"b;			/* we have been called */
				/* initialize those parts of the */
				/* internal data base needed for */
    call comp_init_$one;		/* argument processing */
%page;
/* PROCESS COMMAND ARGUMENTS */

    call cu_$arg_count (nargs);	/* get argument count */

    if nargs = 0			/* if none are given ... */
    then
      do;
        call com_err_ (0, "compose",
	   "(Vers. ^a) Proper usage is: compose " || "paths {-control_args}",
	   const.comp_version);
        goto clean_;
      end;

    optnptr = addr (option.argument_opt);
				/* option flags as bit (36)x */

    source_list.count = 0;		/* empty the source file table */

    on conversion
      begin;			/* set a conversion error handler */
        call com_err_ (ercd, "compose",
	   "Nonnumeric parameter given for ^a option.",
	   rtrim (option_keyword));
        badcall = "1"b;		/* set static flags */
        goto skip_arg;		/* go to next arg */
      end;

    do iarg = 1 by 1 while (iarg <= nargs);
				/* do arguments one at a time */
      call cu_$arg_ptr (iarg, argp, argl, ercd);
				/* get an arg pointer */
      if ercd ^= 0
      then
        do;
	call com_err_ (ercd, "compose", "Reading argument ^d", iarg);
	goto clean_;
        end;

no_param:
      if iarg > nargs		/* if there aren't any more */
      then goto end_args;

      if index (arg, "-") ^= 1	/* if not an option */
      then
        do;			/* if control line is already bad */
	if badcall		/* is it numeric? */
	then if verify (arg, "0123456789") = 0
	     then
	       do;
	         call com_err_ (0, "compose",
		    "The numeric parameter "
		    ||
		    """^a"" cannot be associated with a control argument.",
		    arg);
	         badcall = "1"b;
	         goto skip_arg;
	       end;

is_a_file:			/* process as an source file name */
				/* check file limit */
	if source_list.count = hbound (source_list.ptr, 1)
	then
	  do;
	    call com_err_ (0, "compose",
	         "Too many input files." || " Program limit is ^d.",
	         hbound (source_list.ptr, 1));
	    goto clean_;
	  end;			/**/
				/* get a new source file block */
	source_list.count = source_list.count + 1;
	source_file_ptr =
	     allocate (const.global_area_ptr, size (source_file));
	source_list.ptr (source_list.count) = source_file_ptr;
	source_file = init_file_data;

	call comp_get_file_$find (arg, source_file_ptr, (const.comp_dir),
	     "1"b, "compin", ercd);
	if ercd ^= 0		/* cant find it? */
	then
	  do;
	    badcall = "1"b;
	    goto skip_arg;
	  end;			/**/
				/* if writing to a compout */
	if option.output_file_opt	/* check name length */
	     & length (rtrim (source_file.entryname)) > 31
	then
	  do;
	    call com_err_ (0, "compose",
	         "Input entryname ""^a"" is too long", arg);
	    badcall = "1"b;
	    goto skip_arg;
	  end;

	call comp_get_file_$open (source_file_ptr, "1"b, ercd);
	if ercd ^= 0		/* cant use file? */
	then
	  do;
	    badcall = "1"b;
	    goto skip_arg;
	  end;
        end;

      else if index (arg, "-") = 1	/* is it an option? */
      then
        do;
is_option:
	option_keyword = arg;	/* save option keyword */
				/* search option list */
	optndx = index (ctlargstr, option_keyword);

	if optndx = 0
	then
	  do;
	    call com_err_ (error_table_$badopt, "compose", """^a""", arg);
	    badcall = "1"b;
	  end;

	else
	  do;			/* calculate true index */
	    optndx = option_data.flag_index (divide (optndx, 32, 17) + 1);
	    optns (optndx) = "1"b;	/* set the flag */

	    if optndx <= to_optndx	/* these have parameters */
	    then
	      do;
	        iarg = iarg + 1;	/* fetch expected parameter */
	        call cu_$arg_ptr (iarg, argp, argl, ercd);
	        if ercd ^= 0
	        then
		do;
param_err:
		  if ercd ^= error_table_$noarg
		  then
		    do;
		      call com_err_ (ercd, "compose",
			 "Reading value for ^a option.",
			 rtrim (option_keyword));
		      badcall = "1"b;
		      goto skip_arg;
		    end;
		  argl = 0;	/*		 if ercd = error_table_$noarg
/*		 then ercd = 0;*/
		end;

/* -arguments option */
	        if optndx = arg_optndx
	        then goto end_args;	/* abort arg processing */

/* -change_bars option */
	        else if optndx = cb_optndx
	        then
		do;
cbar_opt:				/* defaults only wanted? */
		  if index (arg, "-") = 1 | argl = 0
		  then goto no_param;
				/* copy parameter arg */
		  local_arg = arg;	/**/
				/* level */
		  if index (local_arg, ",") > 1
		  then option.cbar.level = before (local_arg, ",");
		  else if local_arg ^= "" & index (local_arg, ",") ^= 1
		  then option.cbar.level = local_arg;
		  local_arg = after (local_arg, ",");
				/**/
				/* placement */
		  if index (local_arg, ",") > 1
		  then option.cbar.place = before (local_arg, ",");
		  else if local_arg ^= "" & index (local_arg, ",") ^= 1
		  then option.cbar.place = before (local_arg, ",");
		  local_arg = after (local_arg, ",");
				/**/
				/* left mark */
		  if index (local_arg, ",") > 1
		       | local_arg ^= "" & index (local_arg, ",") ^= 1
		  then
		    do;
		      if index ("0123456789", substr (local_arg, 1, 1))
			 ^= 0
		      then
		        do;
			option.cbar.left.sep =
			     12000 * bin (substr (local_arg, 1, 1));
			local_arg = substr (local_arg, 2);
		        end;

		      if index (local_arg, """") = 1
		      then
		        do;
			local_arg = after (local_arg, """");
			option.cbar.left.mark = before (local_arg, """");
			local_arg = after (local_arg, """");
		        end;
		      else option.cbar.left.mark = before (local_arg, ",");
		    end;
		  local_arg = after (local_arg, ",");
				/**/
				/* right mark */
		  if index (local_arg, ",") > 1
		       | local_arg ^= "" & index (local_arg, ",") ^= 1
		  then
		    do;
		      if index ("0123456789", substr (local_arg, 1, 1))
			 ^= 0
		      then
		        do;
			option.cbar.right.sep =
			     12000 * bin (substr (local_arg, 1, 1));
			local_arg = substr (local_arg, 2);
		        end;
		      if index (local_arg, """") = 1
		      then
		        do;
			local_arg = after (local_arg, """");
			option.cbar.right.mark =
			     before (local_arg, """");
			local_arg = after (local_arg, """");
		        end;
		      else option.cbar.right.mark =
			      before (local_arg, ",");
		    end;
		  local_arg = after (local_arg, ",");
				/**/
				/* del mark */
		  if length (local_arg) > 0
		       | local_arg ^= "" & index (local_arg, ",") ^= 1
		  then
		    do;
		      if index ("0123456789", substr (local_arg, 1, 1))
			 ^= 0
		      then
		        do;	/* numeric 1st char is separation */
			option.cbar.del.sep =
			     12000 * bin (substr (local_arg, 1, 1));
			local_arg = substr (local_arg, 2);
		        end;
		      if index (local_arg, """") = 1
		      then
		        do;
			local_arg = after (local_arg, """");
			option.cbar.del.mark = before (local_arg, """");
			local_arg = after (local_arg, """");
		        end;
		      else option.cbar.del.mark = before (local_arg, ",");
		    end;
		  local_arg = after (local_arg, ",");
		end;

/* -change_bars_art option */
	        else if optndx = cba_optndx
	        then
		do;
		  option.cbar_opt = "1"b;
				/* set -change_bars option */
		  goto cbar_opt;	/* and do as for -cb */
		end;

/* UNDOCUMENTED OPTION: -debug {n1}{,n2}
   Produces debugging output for lines n1 thru n2 of source file
   or given insert file */
	        else if optndx = db_optndx
	        then
		do;
		  if ercd = 0
		  then
		    do;
		      if index (arg, "-") = 1
		      then goto is_option;

		      if verify (arg, "0123456789,$") ^= 0
		      then goto is_a_file;
				/* look for a comma */
		      i = index (arg, ",");

		      if i ^= 0	/* if one is given ... */
		      then
		        do;
			if i > 1
			then option.db_line_strt =
				bin (substr (arg, 1, i - 1));

			if i < argl
			then
			  do;	/* if ",$" -> debug only end_output */
			    if substr (arg, i + 1, 1) = "$"
			    then option.db_line_end = -1;
			    else option.db_line_end =
				    bin (substr (arg, i + 1, argl - i))
				    ;
			  end;
		        end;

		      else option.db_line_strt = bin (arg);
		    end;
		end;

/* UNDOCUMENTED OPTION: -debug_all {n1}{,n2}
   Enables debug output for all input lines (including inserted files)
   encountered between lines n1 and n2 of the debug file */
	        else if optndx = dba_optndx
	        then
		do;
		  option.debug_opt, option.db_all_opt = "1"b;
		  if ercd = 0
		  then
		    do;
		      if index ("0123456789,", substr (arg, 1, 1)) = 0
		      then goto no_param;
		      i = index (arg, ",");
				/* look for a comma */

		      if i ^= 0	/* if one is given ... */
		      then
		        do;
			if i > 1
			then option.db_after_line =
				bin (substr (arg, 1, i - 1));

			if i < argl
			then option.db_before_line =
				bin (substr (arg, i + 1, argl - i));
		        end;

		      else option.db_after_line = bin (arg);
		    end;
		end;

/* UNDOCUMENTED OPTION: -debug_file <file_name>
   Enables -debug output for a named file */
	        else if optndx = dbf_optndx
	        then
		do;
		  option.debug_opt, option.db_file_opt = "1"b;
		  option.db_file = "ALLFILES";
				/* "" -> ALLFILES */

		  if index (arg, "-") = 1
		  then goto is_option;

		  else
		    do;
		      if arg ^= ""
		      then option.db_file = arg;

		      iarg = iarg + 1;
				/* fetch next arg */
		      call cu_$arg_ptr (iarg, argp, argl, ercd);
		      if ercd ^= 0
		      then if ercd = error_table_$noarg
			 then goto skip_arg;

		      if index (arg, "-") = 1
				/* no after line */
		      then goto is_option;
		      else option.db_file_after = bin (arg);
		    end;
		end;

/* -device option */
	        else if optndx = dv_optndx
	        then dsm_path = arg;

/* -execute option */
	        else if optndx = ex_optndx
	        then
		do;
		  call com_err_ (0, "compose",
		       "The -execute control argument is not yet implemented."
		       );
		  option.execute_opt = "0"b;
				/* REMOVE THIS CATCHER */
		  if index (arg, "-") = 1
		  then goto no_param;
				/* EXECUTE OPTION STUFF GOES HERE.
				   MUST BE A QUOTED, SEMI-COLON */
		end;		/* SEPARATED CONTROL STRING */

/* -from option */
	        else if optndx = fm_optndx
	        then
		do;
		  if option.pages_opt
		  then
		    do;
page_err_1:
		      call com_err_ (0, "compose",
			 "The -from/-to and "
			 || "-pages options may not be used together.");
		      badcall = "1"b;
		      goto skip_arg;
		    end;

		  option.pglst (0).from = arg;
		end;

/* -galley option */
	        else if optndx = gl_optndx
	        then
		do;
		  if ercd = 0
		  then
		    do;

		      if index ("0123456789,.", substr (arg, 1, 1)) = 0
		      then goto no_param;

		      i = index (arg, ",");
				/* look for a comma */
		      if i ^= 0	/* if one is given ... */
		      then
		        do;
			if i > 1
			then option.line_1 =
				bin (substr (arg, 1, i - 1));

			if i < argl
			     & substr (arg, i + 1, argl - i) ^= "$"
			then option.line_2 =
				bin (substr (arg, i + 1, argl - i));

			if option.line_2 < option.line_1
			then
			  do;
			    call com_err_ (0, "compose",
			         "Ending line number"
			         || " less than starting line number.");
			    badcall = "1"b;
			  end;
		        end;

		      else option.line_1 = bin (arg);
		    end;
		end;

/* -hyphenation option */
	        else if optndx = hyph_optndx
	        then
		do;
		  if argl = 0 | verify (arg, "0123456789") ^= 0
		  then goto no_param;
		  else option.hyph_size = bin (arg);
		end;

/* -indent option */
	        else if optndx = ind_optndx
	        then
		do;
		  if search (arg, "0123456789.") ^= 1
		  then goto no_param;
		  else option.extra_indent =
			  comp_read_$number ((arg), hscales, 1, 0,
			  addr (null_info), ercd);
		  if ercd ^= 0
		  then goto no_param;
		end;

/* -input_file option */
	        else if optndx = if_optndx
	        then goto is_a_file;

/* -linespace option */
	        else if optndx = ls_optndx
	        then
		do;
		  if search (arg, "0123456789.") ^= 1
		  then goto no_param;
		  else option.linespace =
			  comp_read_$number ((arg), hscales, 1, 0,
			  addr (null_info), ercd);
		  if ercd ^= 0
		  then goto no_param;
		  else option.linespace = 12000 * dec (arg, 11, 3);
		end;

/* -output_file option */
	        else if optndx = of_optndx
	        then
		do;
		  wdir = get_wdir_ ();

		  if argl > 0	/* if there is another arg */
		  then
		    do;
		      if index (arg, "-") = 1
				/* if no given path */
		      then goto is_option;

		      if search ("<>", arg) ^= 0
				/* if a path is given */
		      then
		        do;
			call expand_pathname_ (arg, bulk_file.dir,
			     bulk_file.entryname, ercd);
			if ercd ^= 0
			then
			  do;
			    call com_err_ (ercd, "compose",
			         "Expanding path for ""^a""", arg);
			    goto clean_;
			  end;
		        end;

		      else
		        do;	/* only a name, use wdir */
			if argl > 32
			then
			  do;
			    call com_err_ (error_table_$entlong,
			         "compose", "Bulk output file name.");
			    goto clean_;
			  end;
			bulk_file.entryname = arg;
			bulk_file.dir = wdir;
		        end;	/* construct the path name */
		      bulk_file.path =
			 rtrim (bulk_file.dir) || ">"
			 || rtrim (bulk_file.entryname);
		    end;
		end;

/* -pages option */
	        else if optndx = pg_optndx
	        then
		do;
		  if option.from_opt | option.to_opt
		  then goto page_err_1;
				/* NG if already -from/-to */

		  if index (arg, "-") = 1
				/* if no list is given */
		  then goto is_option;
				/* do them all */

pglst_loop:
		  if index (arg, ",") = 0
				/* if not a page pair */
		  then
		    do;
		      if option.pglstct >= 50
		      then
		        do;
page_err_3:
			call com_err_ (0, "compose",
			     "More than 50 page selectors given.");
			badcall = "1"b;
			goto skip_arg;
		        end;

		      option.pglstct = option.pglstct + 1;
		      option.pglst (option.pglstct).from,
			 option.pglst (option.pglstct).to = arg;
		    end;

		  else
		    do;
		      if option.pglstct >= 50
		      then goto page_err_3;

		      option.pglstct = option.pglstct + 1;
		      option.pglst (option.pglstct).from =
			 before (arg, ",");
		      option.pglst (option.pglstct).to = after (arg, ",");
		    end;

		  iarg = iarg + 1;	/* fetch next list value */
		  call cu_$arg_ptr (iarg, argp, argl, ercd);
		  if ercd ^= 0
		  then if ercd = error_table_$noarg
		       then goto skip_arg;
		       else goto param_err;

		  if index (arg, "-") = 1
				/* must be end of page list */
		  then goto is_option;

		  goto pglst_loop;
		end;

/* -pages_changed option */
	        else if optndx = pgc_optndx
	        then
		do;
		  if ercd ^= 0 | argl = 0
		  then goto skip_arg;
		  else if index (arg, "-") = 1
		  then goto is_option;
		  if argl > 2
		  then goto is_a_file;
				/* cancel default from */
		  option.pglst.from = "";
		  option.pgc_select = substr (arg, 1, 1);
				/* PAIR/SINGLE CODE GOES HERE */
		end;

/* -parameter option */
	        else if optndx = pm_optndx
	        then option.parameter = arg;

/* -passes option */
	        else if optndx = pass_optndx
	        then
		do;
		  if verify (arg, "0123456789.") ^= 0
		  then goto no_param;
		  else option.passes = bin (arg);
		end;

/* -to option */
	        else if optndx = to_optndx
	        then
		do;

		  if option.pages_opt
		  then goto page_err_1;

		  option.pglst (0).to = arg;
		end;

skip_arg:
	      end;
	  end;
        end;
    end;

end_args:
    revert conversion;

    if option.debug_opt & ^dt_sw
    then call ioa_ ("^a (Vers. ^a)", rtrim (const.comp_dir),
	    const.comp_version);

    if source_list.count = 0		/* if no source files were given */
    then
      do;
        call com_err_ (0, "compose", "No input files given.");
        badcall = "1"b;
      end;

    if badcall
    then goto clean_;

    if option.stop_opt		/* if stop is given, also set wait */
    then option.wait_opt = "1"b;	/* as a first time flag */
%page;
/* INITIALIZE FOR EXECUTION BASED ON COMMAND LINE INPUT */

/* extend the stack, errors will be caught by oob */
    call hcs_$set_max_length_seg (stackbaseptr (), sys_info$max_seg_size, ercd)
         ;
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose", "Extending user stack.");
        goto clean_;
      end;

    if option.argument_opt		/* any command line arguments? */
    then
      do;				/* how many? */
        command_arg_ct = max (nargs - iarg + 1, 0);

        if command_arg_ct > 0
        then
	do;
	  command_arg_ptr =
	       allocate (const.global_area_ptr, size (command_arg));

	  do i = iarg to nargs;	/* move them */
	    call cu_$arg_ptr (i, argp, argl, ercd);
	    if ercd ^= 0
	    then
	      do;
	        call com_err_ (ercd, "compose", "Reading argument ^d", i);
	        goto clean_;
	      end;

	    command_arg (i - iarg + 1) = arg;
	    option.arg_count = option.arg_count + 1;
	  end;
	end;			/**/
				/* no args; cancel the option */
        else option.argument_opt = "0"b;
      end;

    if dsm_path = ""		/* no device given? */
    then
      do;
        if option.output_file_opt	/* set defaults */
        then const.dsm_name = "printer.comp_dsm";
        else const.dsm_name = "ascii.comp_dsm";
      end;
    else
      do;
        call expand_pathname_$add_suffix (dsm_path, "comp_dsm", dsm_dir,
	   const.dsm_name, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compose",
	       "Expanding device table pathname.  ^a", dsm_path);
	  go to clean_;
	end;
      end;			/**/
				/* look for the device table */
    if search ("<>", dsm_path) = 0	/* if search is needed */
    then
      do;
        call search_paths_$find_dir ("compose", null (), (const.dsm_name),
	   (const.comp_dir), dsm_dir, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compose", "Searching for ^a.",
	       const.dsm_name);
	  goto clean_;
	end;
      end;

    dsm_path = pathname_ (dsm_dir, (const.dsm_name));

/* second init step - this is all */
    call comp_init_$two;		/* the data base stuff that is */
				/* needed for file processing and */
				/* doesnt depend on the contents of */
				/* the files or their size */

/* initialize the device module */
    call hcs_$initiate (dsm_dir, const.dsm_name, const.dsm_name, 0, 0,
         dsm_baseptr, ercd);
    if dsm_baseptr = null ()
    then
      do;
        call com_err_ (ercd, "compose", "Initiating ^a", dsm_path);
        go to clean_;
      end;
    if ercd ^= 0
    then if ercd = error_table_$namedup
         then
	 do;
	   call term_$single_refname (const.dsm_name, (0));
	   call hcs_$initiate (dsm_dir, const.dsm_name, const.dsm_name, 0, 0,
	        dsm_baseptr, ercd);
	   if dsm_baseptr = null ()
	   then
	     do;
	       call com_err_ (ercd, "compose", "Forcibly initiating ^a",
		  dsm_path);
	       go to clean_;
	     end;
	 end;

(nostrz):
(nostrg):				/* make a pointer to dvid table */
    option.device = before (const.dsm_name, ".comp_dsm");
    const.dvt_name = option.device || ".dvt";
    call hcs_$make_ptr (null (), const.dsm_name, const.dvt_name, const.dvidptr,
         ercd);
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose", "Getting pointer to ^a$^a", dsm_path,
	   const.dvt_name);
        goto clean_;
      end;

    if comp_dvid.version ^= comp_dvid_version
    then
      do;				/* terminate device writer */
        call com_err_ (error_table_$unimplemented_version, "compose",
	   "Device table ^a cannot be used with ^a>compose.", dsm_path,
	   const.comp_dir);
        go to clean_;
      end;			/* make a pointer to device table */
    const.devptr = pointer (const.dvidptr, comp_dvid.dvt_r);

    call comp_dvt.outproc (2, ercd);	/* initialize output writer */
    if ercd ^= 0
    then
      do;
        call com_err_ (ercd, "compose",
	   "Initializing device writer procedure.^/^-"
	   || "Writer for ^a cannot be used with ^a>compose.", dsm_path,
	   const.comp_dir);
        goto clean_;
      end;

    if option.number_brief_opt | option.number_append_opt
    then option.number_opt = "1"b;

    if option.galley_opt		/* adjust debug range if not given */
    then
      do;
        if ^option.db_file_opt
        then
	do;
	  if option.db_line_strt = 0
	  then option.db_line_strt = option.line_1;
	  if option.db_all_opt & option.db_after_line = 0
	  then option.db_after_line = option.line_1;
	end;

        if option.cbar_opt
        then option.cbar.place = "r";
      end;			/**/
				/* output to terminal */
    if ^(option.output_file_opt | option.check_opt)
    then shared.compout_ptr = iox_$user_output;

/* set up bulk output file */
    if ^option.check_opt & bulk_file.path ^= ""
    then
      do;
        call initiate_file_ (bulk_file.dir, bulk_file.entryname, W_ACCESS,
	   bulk_file.ptr, 0, ercd);
        if ercd ^= 0 & ercd ^= error_table_$segknown
	   & ercd ^= error_table_$namedup & ercd ^= error_table_$noentry
        then
	do;
	  call com_err_ (ercd, "compose", "Accessing ^a", bulk_file.path);
	  goto clean_;
	end;

        if bulk_file.ptr ^= null
        then
	do i = 1 to source_list.count;/* check for file overwrite */
	  if baseno (source_list.ptr (i) -> source.pointer)
	       = baseno (bulk_file.ptr)
	  then
	    do;
	      call com_err_ (0, "compose",
		 "Output would overwrite " || "input file ^a",
		 source_list.ptr (i) -> source.path);
	      goto clean_;
	    end;
	end;

        atd = "vfile_ " || bulk_file.path;
        shared.output_file = bulk_file.entryname;

        call iox_$attach_name ("COMPOUT", shared.compout_ptr, atd, null (),
	   ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compose", "Attaching ^a",
	       bulk_file.entryname);
	  goto clean_;
	end;

        call iox_$open (shared.compout_ptr, comp_dvt.open_mode, "0"b, ercd);
        if ercd ^= 0
        then
	do;
	  call com_err_ (ercd, "compose", "Opening ^a", bulk_file.path);
	  call iox_$detach_iocb (shared.compout_ptr, ercd);
	  ercd = 0;
	  goto clean_;
	end;
      end;

    source_ptr = allocate (const.global_area_ptr, size (source));
				/* pass -pm value to the file */
    shared.parameter = option.parameter;
    shared.param_pres = (shared.parameter ^= "");

    if option.passes > 1 | source_list.count > 1
    then
      do;
        const.save_shared_ptr =
	   allocate (const.global_area_ptr, size (save_shared));
        save_shared = shared;		/* save all constructed data */
      end;

    if option.debug_opt &		/* debugging wanted? */
         option.db_line_end ^= 0	/* more than salutory? */
    then call ioa_ ("(debug display = picas, device = ^a)", option.device);

    if option.debug_opt & dt_sw
    then call ioa_ ("^5x(^a>^a)", rtrim (const.comp_dir), const.dsm_name);

    on program_interrupt		/* set a pi handler */
      goto print_pi_stuff;
%page;
/* PROCESS INPUT FILES */

    compose_severity_ = 0;		/* reset severity indicator */

    on cleanup call comp_cleanup;

input_file_loop:
    do filndx = 1 to source_list.count;

      if option.debug_opt		/* initialize meter data */
      then
        do;
	call cpu_time_and_paging_ (pf_start, vcpu_start, 0);
	call hcs_$quota_read (get_pdir_ (), 0, 0, "0"b, "0"b, 0,
	     pd_used_start, ercd);
        end;

      if filndx > 1			/* for additional files */
      then shared = save_shared;	/* reinitialize shared data */

      if bulk_file.path = ""
      then shared.compout_not_headed = "1"b;

      call comp_init_$three;		/* third init step */
      call comp_dvt.outproc (2, ercd);	/* initialize output writer */

/* open the next input file */
      source_file_ptr = source_list.ptr (filndx);
      source.label.count = 0;		/* discard old labels */

(nostrz):
(nostrg):
      shared.input_filename, shared.source_filename =
	 before (source_file.entryname, ".compin");
      shared.insert_ptr, source_file.insert_ptr = source_ptr;
      unspec (insert) = "0"b;
      insert.file, call_box0 = source_file;
      insert.callers_name = "";	/**/
				/* if no debug file, set source file */
      if ^option.db_file_opt		/* as debug file */
      then option.db_file = shared.source_filename;
				/* not syntax check */
      if ^option.check_opt		/* and output to individual files */
	 & option.output_file_opt & bulk_file.path = ""
      then
        do;
	call suffixed_name_$new_suffix ((source.entryname), "compin",
	     "compout", compout_name, ercd);
	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose",
	         "Forming output file name for ^a", source.entryname);
	    goto clean_;
	  end;

	shared.output_file = compout_name;
	compout_path = pathname_ (wdir, compout_name);

	call initiate_file_ (wdir, compout_name, W_ACCESS, compout_seg_ptr,
	     0, ercd);
	if ercd ^= 0 & ercd ^= error_table_$segknown
	     & ercd ^= error_table_$namedup & ercd ^= error_table_$noentry
	then
	  do;
	    call com_err_ (ercd, "compose", "Accessing ^a", compout_path);
	    goto skip_file;		/* skip this one */
	  end;

	if baseno (source.pointer) = baseno (compout_seg_ptr)
	then
	  do;
	    call com_err_ (0, "compose",
	         "Output would overwrite " || "input file ^a",
	         source_list.ptr (i) -> source.path);
	    goto skip_file;
	  end;

	atd = "vfile_ " || compout_path;
	call iox_$attach_name ("COMPOUT", shared.compout_ptr, atd, null (),
	     ercd);
	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose", "Attaching ^a", compout_name);
	    compose_severity_ = 5;
	    goto clean_;
	  end;
	call iox_$open (shared.compout_ptr, comp_dvt.open_mode, "0"b, ercd);
	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose", "Opening ^a", compout_name);
	    call iox_$detach_iocb (shared.compout_ptr, ercd);
	    ercd = 0;
	    compose_severity_ = 5;
	    goto clean_;
	  end;

	if option.passes > 1
	then
	  do;
	    save_shared.output_file = shared.output_file;
	    save_shared.compout_ptr = shared.compout_ptr;
	  end;
        end;

      if option.passes > 1
      then save_shared = shared;

/* for given number of passes */
      do shared.pass_counter = option.passes by -1 to 1;
        if option.passes > 1 &	/* reinitialize shared data for */
	   shared.pass_counter < option.passes
        then shared = save_shared;	/* each additional pass */

        call_stack.index = 0;		/* refresh file data */
        call_box0 = source_file;	/* refresh command line args */
        do i = 1 to option.arg_count;
	call comp_update_symbol_ ("1"b, "0"b, "0"b,
	     "CommandArg" || ltrim (char (i)), command_arg (i));
        end;

        if shared.pass_counter <= 1	/* set print control */
        then if option.galley_opt & option.line_1 <= 1
				/* galley */
	        | ^option.galley_opt	/* or paged and not -from or -pages */
	        &
	        ^(option.from_opt | option.pages_opt | option.page_chng_opt)
	   then shared.print_flag = "1"b;
				/* set page formatting parameters */
        page_parms = init_page_parms;
        page_parms.measure = min (comp_dvt.pdw_max, 468000);
        page.parms = page_parms;

        unspec (page_header) = "0"b;	/* and the control stuff */
        page_header.net = 720000;
        page_header.pageno = "";
        page_header.dot_addltr = "";	/* = PAD */
        page.hdr = page_header;	/**/
				/* start in column 0 */
        shared.colptr = page.column_ptr (0);
        unspec (colhdr) = "0"b;
        colhdr.balblk = 1;
        colhdr.net = 720000;
        col.hdr = colhdr;		/**/
				/* initialize parms */
        default_parms.measure, col0.parms.measure = page_parms.measure;
        default_parms.linespace = option.linespace;
        default_parms.fill_mode = ^option.nofill_opt;

        text_parms, footnote_parms = default_parms;
        call comp_font_ ("1"b, "", ""); /* initialize the font stack */

        const.current_parms_ptr = const.text_parms_ptr;

        if option.debug_opt		/* debugging wanted? */
        then
	do;
	  if option.line_1 <= 1 & option.db_after_line <= 1
	       & option.db_line_strt <= 1 & option.db_line_end >= 1
	       & (option.db_file = "ALLFILES"
	       | shared.input_filename = option.db_file)
	  then shared.bug_mode = "1"b;
	end;
        else shared.bug_mode = "0"b;	/**/
				/* net page/column space */
        call comp_util_$set_net_page ("0"b);

        if option.cbar_opt
        then
	do;
	  unspec (meas1) = "0"b;	/* measure left mark */
	  call comp_measure_ ((option.cbar.left.mark),
	       addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
	       addr (meas1), addr (meas2), addr (text_entry.info));
	  option.cbar.left.width =
	       meas1.width + meas1.gaps * shared.EN_width;

	  unspec (meas1) = "0"b;	/* measure right mark */
	  call comp_measure_ ((option.cbar.right.mark),
	       addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
	       addr (meas1), addr (meas2), addr (text_entry.info));
	  option.cbar.right.width =
	       meas1.width + meas1.gaps * shared.EN_width;

	  unspec (meas1) = "0"b;	/* measure del mark */
	  call comp_measure_ ((option.cbar.del.mark),
	       addr (default_parms.fntstk.entry (0)), "0"b, "1"b, "0"b, 0,
	       addr (meas1), addr (meas2), addr (text_entry.info));
	  option.cbar.del.width = meas1.width + meas1.gaps * shared.EN_width;

	  option.cbar.space =
	       max (option.cbar.left.width + option.cbar.left.sep,
	       option.cbar.del.width + option.cbar.del.sep);
	end;

        ctltxtptr = ctl.ptr;		/* save pointer around re-init */
        unspec (ctl) = ""b;		/* clear control line structure */
        ctl.font, ctl.cur.font = default_parms.fntstk.entry (0);
        ctl.ptr = ctltxtptr;		/* set input buffer pointer */
        ctl.ptr -> txtstr = "";	/* and clear the buffer */
        ctl.fileno,			/* command line file */
	   source_file.fileno = 0;
        unspec (text_entry) = ""b;
        text_entry.quad = just;
        text_entry.linespace = option.linespace;

        shared.end_output = "0"b;	/* turn off flags */
        if option.pages_opt		/* set page list index */
        then option.pglstndx = 1;
        else option.pglstndx = 0;

        if shared.bug_mode
        then call ioa_ ("Input file - ^a", source.entryname);
				/* set a handler for aborting */
        on comp_abort goto file_abort;

        if option.debug_opt
        then call ioa_ ("(^a pass=^d)", shared.input_filename,
	        shared.pass_counter);

        call comp_;			/* call formatter */

        if option.passes > 1 | source_list.count > 1
        then
	do;
	  if option.passes > 1
	  then
	    do;
	      save_shared.compout_not_headed = shared.compout_not_headed;
	      save_shared.firstpass = "0"b;
	    end;			/**/
				/* close any auxiliary files */
	  if shared.aux_file_data_ptr ^= null ()
	  then if aux_file_data.count > 0
	       then
	         do i = 1 to aux_file_data.count;
		 if aux_file_data.entry (i).iocb_ptr ^= null ()
		 then
		   do;
		     call iox_$close (aux_file_data.entry (i).iocb_ptr,
			ercd);
		     call iox_$detach_iocb (aux_file_data.entry (i)
			.iocb_ptr, ercd);
		   end;
		 aux_file_data.count = 0;
	         end;
	end;

file_abort:
      end;

      call comp_make_page_$cleanup;

      if const.errblk_ptr ^= null ()	/* if there is an error list */
      then
        do;
	if error.count > 0		/* any errors that havent been */
	     & ^option.output_file_opt & ^option.check_opt
				/* reported? */
	then call print_errs;
        end;

      if option.number_opt & ^option.number_brief_opt
      then call print_files;

      if ^option.check_opt		/* close output file */
	 & option.output_file_opt & length (bulk_file.path) = 0
      then
        do;
	call hcs_$set_ips_mask (""b, ips_mask);
				/* dont interrupt this */
	call iox_$close ((shared.compout_ptr), ercd);
	if ercd = 0
	then call iox_$detach_iocb ((shared.compout_ptr), ercd);
	shared.compout_ptr = null ();

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose",
	         "Closing/detaching compout file.");
	    compose_severity_ = 5;
	    goto clean_;
	  end;
        end;

      if shared.compx_ptr ^= null ()	/* close the .compx file */
      then
        do;
	call hcs_$set_ips_mask (""b, ips_mask);
				/* dont interrupt this */
	call iox_$close ((shared.compx_ptr), ercd);
	if ercd = 0
	then call iox_$detach_iocb ((shared.compx_ptr), ercd);
	shared.compx_ptr = null ();

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose", "Closing/detaching compx file.");
	    compose_severity_ = 5;
	    goto clean_;
	  end;
        end;

      if shared.aux_file_data_ptr ^= null ()
				/* terminate any aux files */
      then if aux_file_data.count > 0
	 then
	   do i = 1 to aux_file_data.count;
	     if aux_file_data.entry (i).iocb_ptr ^= null ()
	     then
	       do;
	         call iox_$close (aux_file_data.entry (i).iocb_ptr, ercd);
	         call iox_$detach_iocb (aux_file_data.entry (i).iocb_ptr,
		    ercd);
	         call adjust_bit_count_ ((aux_file_data.entry (i).dir),
		    (aux_file_data.entry (i).name), "1"b, 0, ercd);
	       end;
	   end;			/**/
				/* so clean wont try to close again */
      shared.aux_file_data_ptr = null ();
				/* a couple of NLs so ready */
      if shared.end_output &		/* message misses the form */
	 ^(option.output_file_opt | option.check_opt)
      then call ioa_ ("^/");

      if option.debug_opt		/* capture process data */
      then
        do;
	call cpu_time_and_paging_ (pf_end, vcpu_end, 0);
	call hcs_$quota_read (get_pdir_ (), 0, 0, "0"b, "0"b, 0, pd_used_end,
	     ercd);

	call ioa_ ("^5xdone (^a^26t^7.3f pf=^d qt=^d "
	     || "blks=^d la=^d ta=^d sa=^d)", shared.input_filename,
	     dec (vcpu_end - vcpu_start) / 1e6, pf_end - pf_start,
	     pd_used_end - pd_used_start, tblkdata.block.count,
	     tblkdata.line_area.count, tblkdata.text_area.count,
	     text_area.string_area_count);
        end;			/**/
				/* terminate any insert files */
      if const.insert_data_ptr ^= null ()
      then
        do;
	do i = 1 to insert_data.count;
	  if insert_data.ptr (i) -> insert.fcb_ptr ^= null ()
	  then call msf_manager_$close
		  ((insert_data.ptr (i) -> insert.fcb_ptr));
	end;
	insert_data.count, insert_data.index, insert_data.ref_area.count = 0;
        end;

skip_file:
      if page.image_ptr ^= null ()	/* release the output image segment */
      then
        do;
	call release_temp_segment_ ("compose", page_image.text_ptr, ercd);
	if ercd ^= 0
	then
	  do;
	    call com_err_ (ercd, "compose",
	         "Releasing the output image segment.");
	    compose_severity_ = 5;
	    goto clean_;
	  end;
        end;			/**/
				/* release the local area */
      call translator_temp_$release_all_segments (const.local_area_ptr, ercd);
      if ercd ^= 0
      then
        do;
	call com_err_ (ercd, "compose", "Releasing the local storage area.");
	compose_severity_ = 5;
	goto clean_;
        end;
      const.local_area_ptr = null;	/* assure cleanliness */

    end input_file_loop;

clean_:
    call comp_cleanup;		/* END OF COMMAND - */
    return;			/* RETURN TO COMMAND PROCESSOR */

print_pi_stuff:			/* PI display */
    on program_interrupt		/* do this only once */
      goto clean_;			/**/
				/* if this null, we havent completed */
    if shared.insert_ptr ^= null	/* initializing and there cant be */
    then				/* anything to print  */
      do;				/* show file/line at QUIT/fault */
        call ioa_ ("Input file: ^a>^a (^a)^/Line no.:   ^d",
	   rtrim (insert.dir), insert.entryname, insert.refname, ctl.lineno);

        if const.errblk_ptr ^= null ()	/* if there is an error list */
        then if error.count > 0	/* and errors havent been reported */
	        & ^option.output_file_opt & ^option.check_opt
	   then call print_errs;

        if option.number_opt & ^option.number_brief_opt
        then call print_files;
      end;

    call iox_$control (iox_$user_input, "resetread", null (), ercd);
    goto clean_;

/* this undocumented entry may be used externally
   to return to the first call state */
clean:
  entry;				/* if this flag is set, then */
    if substr (ips_mask, 36, 1)	/* ips_mask is off, turn it back on */
    then call hcs_$reset_ips_mask (ips_mask, ips_mask);
    call comp_cleanup;
    return;
%page;
/* CLEAN UP AFTER ERROR OR QUIT */

comp_cleanup:
  proc;
    re_call = "0"b;			/* reset recursive call flag; if */
				/* cleanup fails, the process is hosed anyway */


    if const.shared_ptr = null ()	/* nothing to clean up */
    then goto cln_return;		/**/
				/* clean up device writer */
    if const.outproc_ptr ^= null
    then call comp_dvt.outproc (3, ercd);
				/* dont bother me, I'm busy */
    call hcs_$set_ips_mask (""b, ips_mask);

    on cleanup call hcs_$reset_ips_mask (ips_mask, ips_mask);

    if shared.fcb_ptr ^= null ()	/* terminate input file */
    then call msf_manager_$close ((shared.fcb_ptr));
				/* terminate any insert files */
    if const.insert_data_ptr ^= null ()
    then
      do i = 1 to insert_data.count;
        if insert_data.ptr (i) -> insert.fcb_ptr ^= null ()
        then call msf_manager_$close ((insert_data.ptr (i) -> insert.fcb_ptr));
      end;

    if const.option_ptr ^= null ()
    then if option.output_file_opt	/* close the output file */
	    & shared.compout_ptr ^= null ()
         then
	 do;
	   call iox_$close ((shared.compout_ptr), ercd);
	   call iox_$detach_iocb ((shared.compout_ptr), ercd);
	 end;

    if shared.compx_ptr ^= null ()	/* and the compx file */
    then
      do;
        call iox_$close ((shared.compx_ptr), ercd);
        call iox_$detach_iocb ((shared.compx_ptr), ercd);
      end;

    if shared.aux_file_data_ptr ^= null ()
				/* close any auxiliary files */
    then if aux_file_data.count > 0
         then
	 do i = 1 to aux_file_data.count;
	   if aux_file_data.entry (i).iocb_ptr ^= null ()
	   then
	     do;
	       call iox_$close (aux_file_data.entry (i).iocb_ptr, ercd);
	       call iox_$detach_iocb (aux_file_data.entry (i).iocb_ptr, ercd)
		  ;
	     end;
	   aux_file_data.count = 0;
	 end;
    shared.aux_file_data_ptr = null (); /* keep it clean! */

    if const.errblk_ptr ^= null ()	/* if there is an error list */
    then call release_temp_segment_ ("compose", (const.errblk_ptr), ercd);

    if const.page_ptr ^= null
    then if page.image_ptr ^= null ()
         then call release_temp_segment_ ("compose", page_image.text_ptr, 0);

    if const.local_area_ptr ^= null
    then call translator_temp_$release_all_segments (const.local_area_ptr, 0);
    call translator_temp_$release_all_segments (const.global_area_ptr, 0);
    call hcs_$reset_ips_mask (ips_mask, ips_mask);

cln_return:
    return;
  end comp_cleanup;

print_errs:
  proc;				/* print the error list */

    on cleanup goto clean_;

    call ioa_ ("^/compose error list: ^d error^[s^] (Vers. ^a)", error.count,
         (error.count > 1), const.comp_version);

    if ^option.brief_opt
    then
      do;
        call iox_$put_chars (iox_$user_output, addr (error.text), error.next,
	   ercd);
      end;

    call release_temp_segment_ ("compose", const.errblk_ptr, ercd);

  end print_errs;

print_files:
  proc;

    dcl file_list_iocbp
		   ptr;
    dcl refptr	   ptr;

    dcl ioa_$ioa_switch
		   entry options (variable);

    if const.option_ptr = null () | const.insert_data_ptr = null ()
    then return;			/* no option or insert_data block */
				/* if the file list is wanted */
    if option.number_opt & ^option.number_brief_opt
    then
      do;
        if option.number_append_opt & option.output_file_opt
        then file_list_iocbp = shared.compout_ptr;
        else file_list_iocbp = iox_$user_output;
				/* show source file */
        call ioa_$ioa_switch (file_list_iocbp, "^/^-^a^[^/^]^42t^a",
	   call_box0.refname, (length (call_box0.refname) >= 32),
	   call_box0.path);

        do i = 1 to insert_data.ref_area.count;
				/* show insert files */
	refptr = insert_data.ref_area.ptr (i);
	do j = 1 to refptr -> insert_refs.count;
	  call ioa_$ioa_switch (file_list_iocbp, "^4d^-^a^42t^a",
	       60 * (i - 1) + j, rtrim (refptr -> insert_refs.name (j)),
	       insert_data.ptr (refptr -> insert_refs.index (j))
	       -> insert.path);
	end;
        end;

        if option.output_file_opt
        then call ioa_$ioa_switch (file_list_iocbp, "^|");
      end;
  end print_files;

    dcl dt_sw	   bit (1) static init ("0"b);
dtn:
  entry;
    dt_sw = "1"b;
    return;
dtf:
  entry;
    dt_sw = "0"b;
    return;
%page;
/* LOCAL STORAGE */

    dcl				/* bit index values for option flags */
        (
        arg_optndx	   init (1),	/* -arguments */
        cb_optndx	   init (2),	/* -change_bars */
        cba_optndx	   init (3),	/* -change_bars_artwork */
        db_optndx	   init (4),	/* -debug	 */
        dba_optndx	   init (5),	/* -debug_all */
        dbf_optndx	   init (6),	/* -debug_file */
        dv_optndx	   init (7),	/* -device */
        ex_optndx	   init (8),	/* -execute */
        fm_optndx	   init (9),	/* -from */
        gl_optndx	   init (10),	/* -galley */
        hyph_optndx	   init (11),	/* -hyphenate */
        ind_optndx	   init (12),	/* -indent */
        if_optndx	   init (13),	/* -input_file */
        ls_optndx	   init (14),	/* -linespace */
        of_optndx	   init (15),	/* -output_file */
        pg_optndx	   init (16),	/* -pages */
        pgc_optndx	   init (17),	/* -pages_changed */
        pm_optndx	   init (18),	/* -parameter */
        pass_optndx	   init (19),	/* -passes */
        tdir_optndx	   init (20),	/* -temp_dir - NOT IMPLEMENTED */
        to_optndx	   init (21)	/* -to */
        )		   fixed bin static options (constant);
/**** format: off */
      dcl 1 option_data  static options (constant),
	  2 opt_name   (77) char (32) unal init (
				/* option names */
				/* CONTROL ARGS WITH PARAMETERS */
	     "-arguments", "-ag",	/* -arguments */
	     "-change_bars", "-cb",	/* -change_bars {A} {m}{l}{r}{d} */
	     "-change_bars_art", "-cba", /* -change_bars_art {A} {m}{l}{r}{d} */
	     "-debug", "", "",	/* -debug {n1}{,n2} - UNDOCUMENTED */
	     "-debug_all", "",	/* -debug_all {n}{,n2} - UNDOCUMENTED */
	     "-debug_file", "",	/* -debug_file {name} - UNDOCUMENTED */
	     "-device", "-dev", "-dv",/* -device {name} */
	     "-execute", "-ex",	/* -execute */
	     "-from", "-fm",	/* -from {n} */
	     "-galley", "-gl",	/* -galley {n1}{,n2} */
	     "-hyphenate", "-hyph", "-hph", /* -hyphenate {size} */
	     "-indent", "-in", "-ind", /* -indent {n} */
	     "-input_file", "-if",	/* -input_file path */
	     "-linespace", "-ls",	/* -linespace {n} */
	     "-output_file", "-of",	/* -output_file {path} */
	     "-pages", "-pgs", "-page", "-pg", /* -pages {n,n} */
	     "-pages_changed", "-pgc",/* -pages_changed {A} */
	     "-parameter", "-pm",	/* -parameter {string} */
	     "-passes", "-pass",	/* -pass {n} */
	     "-temp_dir", "-tdir", "-td", /* -temp_dir <path> */
	     "-to",		/* -to {n} */
				/* CONTROL ARGS WITHOUT PARAMETERS */
	     "-annotate", "-ann",	/* -annotate */
	     "-brief", "-bf",	/* -brief */
	     "-check", "-ck",	/* -check */
	     "", "",		/* -cws - OBSOLETE */
	     "-debug_pause", "",	/* -debug_pause - UNDOCUMENTED See comp_read_ */
	     "-noart", "-noa",	/* -noart */
	     "-nobell", "-no_bell", "-nob", /* -nobell */
	     "-nofill", "-nof",	/* -nofill */
	     "-nohit", "-noh",	/* -nohit */
	     "-number", "-nb",	/* -number  */
	     "-number_append", "-nba",/* -number_append */
	     "-number_brief", "-nbb",	/* -number_brief */
	     "-stop", "-sp",	/* -stop */
	     "-wait", "-wt"),	/* -wait */
				/* flag bit index values */
	  2 flag_index (77) fixed bin init (1, 1
				/* -arguments {s s ...} */
		     , 2, 2	/* -change_bars {A}
				   {m}{left}{right}{delete} */
		     , 3, 3	/* -change_bars_art {A}
				   {m}{left}{right}{delete} */
		     , 4, 4, 4	/* -debug {n1}{,n2} UNDOCUMENTED */
		     , 5, 5	/* -debug_all {n1}{,n2} UNDOCUMENTED */
		     , 6, 6	/* -debug_file {name} UNDOCUMENTED */
		     , 7, 7, 7	/* -device {name} */
		     , 8, 8	/* -execute {"<ctl> <ctl> ... "} */
		     , 9, 9	/* -from {n} */
		     , 10, 10	/* -galley {n2}{,n2} */
		     , 11, 11, 11	/* -hyphenation <size> */
		     , 12, 12, 12	/* -indent <n> */
		     , 13, 13	/* -input_file path */
		     , 14, 14	/* -linespace <N> */
		     , 15, 15	/* -output_file <name> */
		     , 16, 16, 16, 16
				/* -pages {n,n} */
		     , 17, 17	/* -pages_changed {A} */
		     , 18, 18	/* -parameter <string> */
		     , 19, 19	/* -pass <n> */
		     , 20, 20, 20	/* -temp_dir <path> */
		     , 21		/* -to <n> */
		     , 22, 22	/* -annotote */
		     , 23, 23	/* -brief */
		     , 24, 24	/* -check */
		     , 25, 25	/* -compress_white_space - OBSOLETE */
		     , 26, 26	/* -debug_pause UNDOCUMENTED
				   See comp_read_ */
		     , 27, 27	/* -noart */
		     , 28, 28, 28	/* -nobell */
		     , 29, 29	/* -nofill */
		     , 30, 30	/* -nohit */
		     , 31, 31	/* -number */
		     , 32, 32	/* -number_append */
		     , 33, 33	/* -number_brief */
		     , 34, 34	/* -stop */
		     , 35, 35);	/* -wait */
/**** format: on */

    dcl argl	   fixed;		/* command line argument length */
    dcl argp	   ptr;		/* command line argument pointer */
    dcl atd	   char (256);	/* attach desc for compout file */
				/* something smelly in command line */
    dcl badcall	   bit (1) init ("0"b);
    dcl 1 bulk_file,		/* data for bulk output file */
	2 dir	   char (168) init (""),
	2 entryname  char (32) init (""),
	2 path	   char (200) var init (""),
				/* seg pointer for overwrite check */
	2 ptr	   ptr init (null);
    dcl dsm_dir	   char (168);	/* dir containing comp_dsm */
				/* path of comp_dsm */
    dcl dsm_path	   char (200) init ("");
    dcl ctltxtptr	   ptr;		/* pointer to control line structure */
				/* local name of compose's dir */
    dcl compose_dir	   char (168) aligned;
    dcl compout_name   char (32);	/* local name of compout file */
				/* path of compout file */
    dcl compout_path   char (200) var;
    dcl compout_seg_ptr		/* pointer to **.compout */
		   ptr;
    dcl dsm_baseptr	   ptr;
    dcl dsm_ercd	   fixed bin (35);	/* error code for device module */
    dcl ercd	   fixed bin (35);	/* system error code */
    dcl filndx	   fixed bin;	/* index into source file table */
    dcl hscales	   (7) fixed bin (31) static options (constant)
		   init (7200, 6000, 72000, 2834.65, 12000, 1000, 0);
    dcl (i, j)	   fixed bin;	/* working index */
    dcl iarg	   fixed bin;	/* command line argument counter */
    dcl ips_mask	   bit (36) aligned static init (""b);
    dcl local_arg	   char (200) var;	/* local copy of ctl arg for parsing */
    dcl 1 meas1	   aligned like text_entry.cur;
				/* for cbar measuring */
    dcl 1 meas2	   aligned like text_entry.cur;
				/* for cbar measuring */
    dcl nargs	   fixed init (0);	/* number of command line arguments */
    dcl 1 null_info	   aligned like text_entry.info;
    dcl option_keyword char (32);	/* option keyword for errors */
    dcl optndx	   fixed bin;	/* flag index value for options */
    dcl optnptr	   ptr;		/* pointer to option bit string */
    dcl optns	   (36) bit (1) unal based (optnptr);
				/* option flag string */
    dcl pd_used_end	   fixed (18);	/* pdir quota used at termination */
    dcl pd_used_start  fixed (18);	/* pdir quota used at invocation */
    dcl pf_end	   fixed (35);	/* page faults at termination */
    dcl pf_start	   fixed (35);	/* page faults at invocation */
				/* recursive call flag */
    dcl re_call	   bit (1) static init ("0"b);
    dcl 1 source	   aligned like insert based (source_ptr);
    dcl source_ptr	   ptr;
    dcl 1 source_file  aligned like insert.file based (source_file_ptr);
    dcl source_file_ptr
		   ptr;
    dcl 1 source_list  aligned static,	/* source file table */
	2 count	   fixed bin,	/* file count */
	2 ptr	   (200) ptr;	/* data block pointers */
    dcl vcpu_start	   fixed (71);	/* vcpu microseconds at invocation */
    dcl vcpu_end	   fixed (71);	/* vcpu microseconds at termination */
    dcl wdir	   char (168) init ("");
				/* working dir */

    dcl adjust_bit_count_
		   entry (char (168), char (32), bit (1), fixed,
		   fixed (35));
    dcl com_err_	   entry options (variable);
    dcl cpu_time_and_paging_
		   entry (fixed bin (35), fixed bin (71), fixed bin (35));
    dcl cu_$arg_count  entry (fixed bin);
    dcl cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin, fixed bin (35));
    dcl expand_pathname_
		   entry (char (*), char (*), char (*), fixed bin (35));
    dcl expand_pathname_$add_suffix
		   entry (char (*), char (*), char (*), char (*) aligned,
		   fixed bin (35));
    dcl get_pdir_	   entry returns (char (168));
    dcl get_quota	   entry options (variable);
    dcl get_wdir_	   entry returns (char (168));
    dcl hcs_$fs_get_path_name
		   entry (ptr, char (*) aligned, fixed bin (35),
		   char (*) aligned, fixed bin (35));
    dcl hcs_$initiate  entry (char (*), char (*) aligned, char (*) aligned,
		   fixed bin (1), fixed bin (2), ptr, fixed bin (35));
    dcl hcs_$make_ptr  entry (ptr, char (*) aligned, char (*) aligned, ptr,
		   fixed bin (35));
    dcl hcs_$make_seg  entry (char (*) aligned, char (*) aligned, char (*),
		   fixed bin (5), ptr, fixed bin (35));
    dcl hcs_$quota_read
		   entry (char (*), fixed bin (18), fixed bin (71),
		   bit (36) aligned, bit (36), fixed bin (1),
		   fixed bin (18), fixed bin (35));
    dcl hcs_$reset_ips_mask
		   entry (bit (36) aligned, bit (36) aligned);
    dcl hcs_$set_ips_mask
		   entry (bit (36) aligned, bit (36) aligned);
    dcl hcs_$set_max_length_seg
		   entry (ptr, fixed bin (18), fixed bin (35));
    dcl hcs_$truncate_seg
		   entry (ptr, fixed bin (19), fixed bin (35));
    dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24),
		   fixed bin (35));
    dcl iox_$attach_name
		   entry (char (*), ptr, char (*), ptr, fixed bin (35));
    dcl iox_$close	   entry (ptr, fixed bin (35));
    dcl iox_$control   entry (ptr, char (*), ptr, fixed (35));
    dcl iox_$detach_iocb
		   entry (ptr, fixed bin (35));
    dcl iox_$open	   entry (ptr, fixed bin (35), bit (1) aligned,
		   fixed bin (35));
    dcl iox_$put_chars entry (ptr, ptr, fixed bin (35), fixed bin (35));
    dcl msf_manager_$close
		   entry (ptr);
    dcl pathname_	   entry (char (*), char (*)) returns (char (168));
    dcl release_temp_segment_
		   entry (char (*), ptr, fixed bin (35));
    dcl search_paths_$find_dir
		   entry (char (*), ptr, char (*), char (*), char (*),
		   fixed bin (35));
    dcl suffixed_name_$new_suffix
		   entry (char (*), char (*), char (*), char (32),
		   fixed bin (35));
    dcl term_$seg_ptr  entry (ptr, fixed bin (35));
    dcl term_$single_refname
		   entry (char (*) aligned, fixed bin (35));
    dcl terminate_file_
		   entry (ptr, fixed bin (24), bit (*), fixed bin (35));
    dcl translator_temp_$release_all_segments
		   entry (ptr, fixed bin (35));

/* EXTERNAL STORAGE */

    dcl arg	   char (argl) based (argp);
				/* command line argument */
    dcl command_arg	   (command_arg_ct) char (1020) var
		   based (command_arg_ptr);
    dcl command_arg_ct fixed bin;
    dcl command_arg_ptr
		   ptr;		/* control arg names string */
    dcl ctlargstr	   char (32 * hbound (option_data.opt_name, 1))
		   based (addr (option_data.opt_name));

    dcl (addr, after, before, baseno, bin, char, dec, divide, empty, hbound,
        index, length, ltrim, max, min, null, pointer, rtrim, search, size,
        stackbaseptr, substr, unspec, verify)
		   builtin;

    dcl (cleanup, comp_abort, conversion, program_interrupt)
		   condition;

    dcl (
        error_table_$badopt,
        error_table_$entlong,
        error_table_$namedup,
        error_table_$noarg,
        error_table_$noentry,
        error_table_$segknown,
        error_table_$unimplemented_version
        )		   fixed (35) ext static;
%page;
%include access_mode_values;
%include comp_aux_file;
%include comp_column;
%include comp_dvid;
%include comp_dvt;
%include comp_entries;
%include comp_error;
%include comp_fntstk;
%include comp_footnotes;
%include comp_insert;
%include comp_option;
%include comp_page;
%include comp_shared;
%include comp_text;
%include compstat;
%include terminate_file;
%include translator_temp_alloc;

  end compose;




		    compstat.cds                    04/23/85  1059.2rew 04/23/85  0910.9       20412



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

/*   static data for compose */

/* format: style2,ind3,ll79,dclind4,idind15,comcol41,linecom */

compstat:
   proc;

      dcl 1 compstat     aligned static,
	  2 compconst  like const;	/* constant data structure */

%include compstat;

      dcl com_err_	     entry options (variable),
	create_data_segment_
		     entry (ptr, fixed (35)),
	ercode	     fixed (35);	/* system error code */

      dcl 1 cdsargs	     aligned like cds_args;

%include cds_args;

/* assign true constants */
      compstat.version = const_version;
      compstat.art_symbols = "[]{}()|=o/X*mct^v<>\-HhSs~""'";

/*      compstat.comp_version = "9.15c";/* FirstPass, PageCount BIFs */
/*      compstat.comp_version = "9.16d";/* .fnt -reset */
/*      compstat.comp_version = "9.17l";/* marg adjs */
/*      compstat.comp_version = "9.18g";/* full page window */
/*      compstat.comp_version = "9.19e";/* compstat V6 */
/*      compstat.comp_version = "9.20a";/* MR11 performance */
/*      compstat.comp_version = "9.21";	/* translator_temp */
      compstat.comp_version = "10.0e";	/* extensible blocks */
      compstat.max_seg_chars = 4 * sys_info$max_seg_size;

/* set up cds arg structure */
      cdsargs.p (*) = addr (compstat);
      cdsargs.len (1) = 0;
      cdsargs.len (2) = size (compstat);
      cdsargs.struct_name (1) = "";
      cdsargs.struct_name (2) = "compstat";
      cdsargs.seg_name = "compstat";
      cdsargs.num_exclude_names = 0;
      cdsargs.exclude_array_ptr = null ();
      cdsargs.defs_in_link = "0"b;
      cdsargs.separate_static = "0"b;
      cdsargs.have_text = "0"b;
      cdsargs.have_static = "1"b;

      call create_data_segment_ (addr (cdsargs), ercode);
      if ercode ^= 0
      then call com_err_ (ercode, "create_stat");

   end;

