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,