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; /*