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 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; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved