ascii.compdv 04/23/85 1256.1rew 04/23/85 0908.5 57780 /* ****************************************************** * * * * * Copyright, (C) Honeywell Information Systems * * Inc., 1980. * * * * * ****************************************************** */ Wordspace: 1,1,2,SP; Strokes: 1; Stream: on; Letterspace: 0; Units: pt; Footrefseparator: 177; dcl: BSP, 010; MediaChars: NIL "", BSP 010, 010 SELF, 014 "", 016 SELF, 017 SELF, 030 SELF, STROKE 030, 033 SELF, SP " ", "!":"~" SELF, USL "_" BSP; Media: mASC10; NIL 0; 010 -1; BSP -1; 014 0; 016 0; 017 0; 030 1; STROKE 1; 033 -1; SP 1; "!":"~" 1; USL 0; View: vASC10 mASC10; Def: text; "!":"~" SELF; 010 SELF; 422,421 """"; /* left/right quote */ 240 "v" BSP "^"; /* "printing" \040 */ EM SP SP; EN SP; THIN NIL; 277 NIL; 377 SP; DEVIT SP; STROKE SP; EM- "-" "-"; EN- "-"; Def: etc; 010 SELF; 014 ""; 016,017 SELF; /* old red/black shift chars */ 033 SELF; 177 ""; 375 "Z" BSP "N"; /* square */ EM_ "__"; EN_ "_"; art [ "["; art ] "]"; art { "{"; art } "}"; art ( "("; art ) ")"; art o "o" BSP "x"; art X "X"; art m "|"; art d "*"; art | "|"; art || "[" BSP "]"; art PI "PI"; art pi "pi"; art / "/"; art \ "\"; art c "(c)"; /* copyright */ art t "(TM)"; art ^ "^" BSP; art v "v" BSP; art <- "<" BSP; art -> "_" BSP ">"; art D^ "^"; art Dv "v"; art D< "<"; art D> ">"; art Clf "("; art Crt ")"; art -str, art -stp NIL; art -rul "_"; art |rul "|" BSP; art /rul "/"; art \rul "\"; art bxtl "_"; art bxt SP; art bxtr "_" BSP; art bxl "_" BSP "|"; art bxx "|"; art bxr "_" BSP "|" BSP; art bxbl "_" BSP "|"; art bxb "|"; art bxbr "_" BSP "|" BSP; art lztl "_"; art lztr "_" BSP; art lzl "/"; art lzr "\"; art lzbl BSP "\_"; art lzbr "_/" BSP BSP; art [tp, art [ht, art [md, art [bt, art [fl "["; art [hb NIL; art ]tp, art ]ht, art ]md, art ]bt, art ]fl "]"; art ]hb NIL; art {tp, art {ht, art {md, art {bt, art {fl "{"; art {hb NIL; art }tp, art }ht, art }md, art }bt, art }fl "}"; art }hb NIL; art lptp, art lpht, art lpmd, art lpbt, art lpfl "("; art lphb NIL; art rptp, art rpht, art rpmd, art rpbt, art rpfl ")"; art rphb NIL; art |tp, art |ht, art |md, art |bt, art |fl "|"; art |hb NIL; art ||tp, art ||ht, art ||md, art ||bt, art ||fl "[" BSP "]"; art ||hb NIL; Def: text_; "!":"~" USL SELF; 422,421 USL """"; /* right/left quote */ EM SP SP; EN SP; THIN SP; 277 NIL; 377 SP; DEVIT SP; STROKE SP; EM- USL "-" USL "-"; EN- USL "-"; Font: asc10 vASC10; ref: text; ref: etc; Font: ASC10 vASC10; ref: text; ref: etc; "a" "A"; "b" "B"; "c" "C"; "d" "D"; "e" "E"; "f" "F"; "g" "G"; "h" "H"; "i" "I"; "j" "J"; "k" "K"; "l" "L"; "m" "M"; "n" "N"; "o" "O"; "p" "P"; "q" "Q"; "r" "R"; "s" "S"; "t" "T"; "u" "U"; "v" "V"; "w" "W"; "x" "X"; "y" "Y"; "z" "Z"; Font: asc10_ vASC10; ref: text_; ref: etc; Font: ASC10_ vASC10; ref: text_; ref: etc; "a" USL "A";"b" USL "B";"c" USL "C";"d" USL "D";"e" USL "E"; "f" USL "F";"g" USL "G";"h" USL "H";"i" USL "I";"j" USL "J"; "k" USL "K";"l" USL "L";"m" USL "M";"n" USL "N";"o" USL "O"; "p" USL "P";"q" USL "Q";"r" USL "R";"s" USL "S";"t" USL "T"; "u" USL "U";"v" USL "V";"w" USL "W";"x" USL "X";"y" USL "Y"; "z" USL "Z"; Font: ASC10OS vASC10; ref: text; ref: etc; "!":"^" 2(SELF BSP) SELF; "`":"~" 2(SELF BSP) SELF; Font: ASC10_OS vASC10; ref: text; ref: etc; "!":"^" USL SELF 2(BSP SELF); "`":"~" USL SELF 2(BSP SELF); Size: onesize, 7.2; MinLead: 12; MinSpace: 7.2; MaxPageWidth: 950.4; Outproc: ascii_writer_; Interleave: on; DevClass: "printer"; DevName: "ascii"; Footproc: ascii_writer_$footproc; Sizes: onesize; Device: ascii; init: text 7.2; comment: "DB: ascii_writer_$display"; attach: "syn_ user_output"; viewselect: vASC10 NIL; family: centuryschoolbook, cs, helvetica, h; member: /medium, /m, /, /roman, /r asc10; member: /italic, /i, /mediumitalic, /mi asc10_; member: /bold, /b, /boldroman, /br ASC10; member: /bolditalic ,/bi ASC10_; family: pica10; member: /medium, /m, /, /roman, /r asc10; member: /italic, /i, /mediumitalic, /mi asc10_; member: /bold, /b, /boldroman, /br ASC10; member: /bolditalic, /bi ASC10_; member: /caps ASC10; member: /caps_ ASC10_; bachelor: ascii, l4font, l3exact, l4exact, text, roman asc10; bachelor: footnote, footref, l0exact, APL, CSR, HR, ascii9, typ asc10; bachelor: small_typ, small_ascii asc10; bachelor: l0font, l3font, ASCII, head18 ASC10; bachelor: bold, CSBR, HBR, HBBl ASC10; bachelor: italic, l2font, l1exact, l2exact, CSI, HmI, ascii_ asc10_; bachelor: l1font, ASCII_, bolditalic, head14 ASC10_; bachelor: CSBI, HBI ASC10_; Device: ascii_draft; init: text 7.2; devname: "ascii_draft"; comment: "DB: ascii_writer_$display"; attach: "syn_ user_output"; viewselect: vASC10 NIL; family: centuryschoolbook, cs, helvetica, h; member: /medium, /m, /, /roman, /r asc10; member: /italic, /i, /mediumitalic, /mi asc10_; member: /bold, /b, /boldroman, /br ASC10OS; member: /bolditalic ,/bi ASC10_OS; family: pica; member: /medium, /m, /, /roman, /r asc10; member: /italic, /i, /mediumitalic, /mi asc10_; member: /bold, /b, /boldroman, /br ASC10OS; member: /bolditalic, /bi ASC10_OS; member: /caps ASC10; member: /caps_ ASC10_; bachelor: text, roman, footnote, footref, APL, CSR, HR, ascii asc10; bachelor: l0exact, typ, small_typ, ascii9, small_ascii asc10; bachelor: l0font, ASCII, head18 ASC10; bachelor: bold, CSBR, HBR, HBBl, l4font, l4exact ASC10OS; bachelor: italic, l2font, l1exact, l2exact, CSI, HmI, ascii_ asc10_; bachelor: l1font, ASCII_, bolditalic, head14 ASC10_OS; bachelor: CSBI, HBI, l3font, l3exact ASC10_OS; Device: printer like ascii; devname: "printer"; endpage: 014; mintopmarg: 36; minbotmarg: 36; maxpagewidth: 979.2; viewselect: vASC10 NIL; Device: printer_draft like ascii_draft; devname: "printer_draft"; endpage: 014; mintopmarg: 36; minbotmarg: 36; maxpagewidth: 979.2; viewselect: vASC10 NIL; Device: led120, LED120 like ascii; devname: "led120"; devclass: "braille"; maxpagewidth: 288; maxpagelength: 300; endpage: 014; defaultmargs: 0,24,24,0; viewselect: vASC10 NIL; Device: ascii_sqo like ascii; devname: "ascii_sqo"; stream: off; viewselect: vASC10 NIL;  ascii_writer_.pl1 04/23/85 1256.1r w 04/23/85 1123.2 446436 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * Copyright, (C) Honeywell Information Systems Inc., 1980 * * * * * *********************************************************** */ /* compose support routine to write output to ascii terminals (class printer) */ /* PREFACE /* This program handles length and distance values in "picture elements" /* (pixels). These are the native units in the machine and, sooner or later, /* all internal length and distance values have to be converted to pixels to /* actually get device output. In some cases the vertical and horizontal /* pixels are not of the same size, i.e. a Diablo-type typewriter has /* 60/inch horizontally and 48/inch vertically. /* All values which are fixed bin (31) are in millipoints. /* Debugging tools--- /* There are several switches that control debugging output from a writer-- /* shared.bug_mode db_sw dt_sw lg_sw /* debug_sw detail_sw long_sw /* shared.bug_mode is set via the family of -db arguments. It means that all /* of compose is being debugged. /* db_sw, dt_sw, lg_sw (static) are set by the entries dbn, dtn, and lgn */ /* respectively. They are reset by the entries dbf, dtf, and lgf. */ /* These switches interact with each other. In order to reduce the amount of */ /* code executed when not debugging, these interactions are distilled into */ /* automatic switches, debug_sw, detail_sw, and long_sw with this logic. */ /* debug_sw = (shared.bug_mode | db_sw); */ /* detail_sw = debug_sw & dt_sw; */ /* long_sw = debug_sw & lg_sw; */ /* debug_sw controls these outputs-- */ /* -- entry and exit notification */ /* -- an interpretation of each line of the input structure before it is */ /* acted upon. */ /* -- gap count error notification */ /* detail_sw controls these outputs-- */ /* -- justification calculations */ /* -- device control (DCxx) display */ /* -- plot trace */ /* -- put_ trace */ /* -- set_font trace */ /* -- set_media trace */ /* long_sw controls these outputs-- */ /* -- shows the justified text line */ /* -- shows detailed Multics/device translation (simple) */ /* This is a 10 pitch ascii typewriter. It has no plotting capability. There */ /* is an attempt to represent artwork constructs in an understandable */ /* (if not always pretty) fashion. */ /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */ ascii_writer_: proc (func, code); /* PARAMETERS */ dcl func fixed bin; /* function code */ /* 0 = build a page */ /* 1 = initialize a page */ /* 2 = initialize a file */ /* 3 = clean up */ /* 4 = prepare epilogue */ dcl code fixed bin (35); /* error code */ /* LOCAL STORAGE */ dcl auto_lead fixed bin (31); /* automatic baseline advance */ dcl BAD_CHAR char (1) static options (constant) init ("ÿ"); /* list of bad font chars */ dcl bad_chrs char (128) var static; dcl char_ndx fixed bin; /* index into font table */ dcl col_width fixed bin (31); /* calculated column width */ dcl debug_str char (1020) var; dcl debug_sw bit (1); dcl detail_sw bit (1); dcl dev_stat_ptr ptr static init (null ()); dcl EM_width fixed bin (31); /* width of EM */ dcl EN_width fixed bin (31); /* width of EN */ dcl fcdevfnt fixed bin; /* device font needed by a char */ dcl fcwidth fixed bin (31); /* font char width */ dcl first_line bit (1) static; dcl first_page bit (1) aligned static init ("0"b); dcl font_in fixed bin; /* current font */ dcl font_size fixed bin (31); /* point size in current font */ dcl fonts_done bit (36); /* which fonts have been processed */ dcl fonts_needed bit (36); /* which fonts have been requested */ dcl hot_chars char (35) static options (constant) init (" þÿ"); dcl (i, j, jj, k, ll) fixed bin; dcl ichr fixed bin; /* index to current text character */ dcl ilin fixed bin static;/* page image line counter */ dcl just_line char (1020) var; /* the justified line */ dcl lineinfoptr ptr; /* -> info structure for image line */ dcl line_window_size /* # of window lines per output line */ fixed bin; dcl Lmarg fixed bin (31); /* left margin */ dcl loctxt char (1020) var; /* max rev leading allowed */ dcl long_sw bit (1); dcl max_level fixed bin; dcl max_revlead fixed bin (31) static; dcl font_media (36) fixed bin; /* media needed by the fonts */ dcl media_size fixed bin (31); /* point size in media */ dcl medselstr char (32) var; /* emitted medsel string */ dcl need_font fixed bin; /* needed font */ dcl need_devfnt fixed bin; /* device font for needed font */ dcl need_size fixed bin (31); /* needed size */ dcl NULs char (4) var static options (constant) init (""); dcl pref_sw bit (1); /* effective preface switch */ dcl quad bit (6); /* alignment flags */ dcl runout fixed bin; /* # NLs for page runout */ dcl SHIFT_OP bit (1) static options (constant) init ("0"b); /* device status info */ dcl stat_blk (100) fixed bin (35) static init ((100) 0); /* The developer of a device writer */ /* may use this block (by defining a */ /* based overlay) to hold any */ /* necessary device status info. */ /* Note that the first word is */ /* initialized to -1 for each page, */ /* thus any overlay should keep it */ /* fixed bin (35) and assure that */ /* all special device modes are */ /* reset at the end of each page. */ dcl text_sw bit (1); dcl text_width fixed bin (31); /* local text width */ dcl tchr char (1); /* local text char */ dcl THIN_width fixed bin (31); /* width of THIN */ dcl tstr_ptr ptr; /* text string */ dcl 1 tstr aligned based (tstr_ptr), 2 open bit (1) unal, /* line has something */ 2 white bit (1) unal, /* line is white */ 2 MBZ bit (16) unal, 2 devfnt fixed bin unal, /* starting device font for line */ 2 last_cr fixed bin unal, /* position of last CR or NL */ 2 font fixed bin unal, /* font being processed */ 2 xpos fixed bin (31), /* X position */ 2 ypos fixed bin (31), /* Y position */ 2 w fixed bin (31), /* width of str */ 2 str_ptr ptr; dcl tstr_line char (2048) var based (tstr.str_ptr); dcl txtlen fixed bin; /* length of txtstr */ dcl unstart fixed bin (31); /* start of underscore */ dcl unstring bit (1) static; /* underscoring is active */ dcl VECTOR_OP bit (1) static options (constant) init ("1"b); dcl window_area_ptr /* points to current window area seg */ ptr static init (null); dcl window_bottom fixed bin static init (0); dcl window_level fixed bin; dcl window_ptr ptr static init (null); dcl 1 window (window_top:window_bottom) aligned like tstr based (window_ptr); dcl window_top fixed bin static init (0); dcl word char (4090) var; /* word accumulator */ dcl wrdwidth fixed bin (31); /* word width in MPTS */ dcl Xmov fixed bin (31); /* horizontal CTL movement */ dcl Xmptstrk fixed bin (31); /* horizontal mpt -> stroke conv */ dcl Xpixel fixed bin (31); /* horizontal pixel size */ dcl Xpos fixed bin (31); /* current horizontal position */ dcl Xspc fixed bin (31); /* horizontal movement */ dcl Xmpts fixed bin (31); /* temp horiz value */ dcl Yinit fixed bin (31); /* initial page depth */ dcl Ymov fixed bin (31); /* vertical CTL movement */ dcl Ypixel fixed bin (31); /* vertical pixel size */ dcl Ypos fixed bin (31); /* current vertical position */ dcl Yspc fixed bin (31); /* vertical movement */ dcl Ympts fixed bin (31); /* temp vert value */ dcl (addr, bin, divide, fixed, index, length, max, min, mod, null, pointer, size, string, substr, unspec) builtin; dcl (cleanup, comp_abort, null_font_char, overlength_line, zero_font_index) condition; dcl error_table_$fatal_error fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl comp_error_table_$limitation fixed bin (35) ext static; dcl comp_error_table_$program_error fixed bin (35) ext static; dcl ioa_$rs entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); /**** &dcls FOR ascii */ dcl 1 bead (8192) aligned, /* bead structure for canonizing */ 2 loc fixed bin, /* column position */ 2 char char (1); /* the character */ dcl beadct fixed bin; /* count of beads */ /* bead array for debug */ dcl 1 beads (beadct) aligned based (beadp), 2 loc fixed bin, 2 char char (1); dcl beadp ptr; dcl BSCR char (2) static options (constant) init (" "); dcl d fixed bin; /* bead separation for sorting */ dcl icol fixed bin; /* working column position */ dcl ii fixed bin; /* working index */ dcl MAX_STR fixed bin static options (constant) init (1024); dcl ocol fixed bin; /* working column position */ dcl PENDOWN char (1) init ("_") static options (constant); dcl PENUP char (1) init (" ") static options (constant); dcl scndx fixed bin (21); /* output scanning index */ dcl space fixed bin; /* bead separation space */ dcl swps fixed bin; /* # of swaps in a sort pass */ /* temp for sorting beads */ dcl tbead bit (72) aligned; dcl (char, copy, search, rank) builtin; /**** END ascii */ %page; code = 0; /* clear error code */ if func = 3 /* clean up */ then do; /**** &cleanup FOR ascii */ /**** NO CODE *//**** END ascii */ return; end; if func = 1 /* new page */ then do; init: entry; /* called by pco */ stat_blk (*) = 0; stat_blk (1) = -1; dev_stat_ptr = addr (stat_blk); return; end; if func = 2 /* new input file */ then do; myself: /* check structure versions */ const.outproc_ptr = codeptr (myself); if shared.version ^= shared_version | option.version ^= option_version | page.version ^= page_version | comp_dvid.version ^= comp_dvid_version then do; code = error_table_$unimplemented_version; if db_sw then do; call ioa_ (" shared.version=^i", shared.version); call ioa_ (" shared_version=^i", shared_version); call ioa_ (" option.version=^i", option.version); call ioa_ (" option_version=^i", option_version); call ioa_ (" page.version=^i", page.version); call ioa_ (" page_version=^i", page_version); call ioa_ (" dvid.version=^i", comp_dvid.version); call ioa_ (" dvid_version=^i", comp_dvid_version); end; return; end; bad_chrs = ""; unstring = "0"b; first_page = "1"b; /**** &file_init FOR ascii */ max_revlead = 0; /* ascii cant back up *//**** END ascii */ return; end; /**/ /* set debug switches */ debug_sw, detail_sw, long_sw, pref_sw, text_sw = "0"b; debug_sw = (shared.bug_mode | db_sw); detail_sw = debug_sw & dt_sw; long_sw = debug_sw & lg_sw; text_sw = debug_sw & tx_sw; pref_sw = debug_sw & pf_sw; if func = 4 /* prepare epilogue */ then do; page_record_ptr = addr (page_image.text_ptr -> record.page_record); unspec (page_record) = "0"b; /**** &epilogue FOR ascii */ /**** NO CODE *//**** END ascii */ return; end; /* func = 0 build page */ line_window_size = divide (12000, comp_dvt.min_lead, 17, 0); window_top = -line_window_size; window_bottom = divide (page.parms.length, comp_dvt.min_lead, 17, 0); if debug_sw then call ioa_ ("ascii_writer_(^a): (pag=^a lct=^d lvl=^d:^d)", option.device, page.hdr.pageno, page_image.count, window_top, window_bottom); if page_image.count = 0 then do; call comp_report_ (4, 0, "No output lines on page " || page.hdr.pageno, addr (ctl.info), ""); return; end; on cleanup call release_window; /**/ /* preset local stuff */ auto_lead, font_in, need_devfnt, media_size, font_size, Xpos, Ypos, Yinit, font_media (*) = 0; Xpixel = comp_dvt.min_WS; Ypixel = comp_dvt.min_lead; page_record_ptr = addr (page_image.text_ptr -> record.page_record); /**** &page_init FOR ascii */ beadp = addr (bead); /**** END DEVICE ascii */ rescan_page: /* (re)starting page */ /* get storage for output image */ call translator_temp_$get_segment ("compose", window_area_ptr, ercd); if ercd ^= 0 then do; call com_err_ (ercd, "compose", "Defining an output window area."); signal cleanup; return; end; Xspc, Yspc = 0; window_ptr = allocate (window_area_ptr, (window_bottom - window_top + 1) * size (tstr)); unspec (window) = "0"b; window.str_ptr = null; unspec (page_record) = "0"b; first_line = "1"b; window_level, max_level = 0; tstr_ptr = addr (window (0)); if tstr.str_ptr = null then tstr.str_ptr = allocate (window_area_ptr, 1024); tstr_line = ""; tstr.devfnt = 0; /**** &image_init FOR ascii */ /**** NO CODE */ /**** END ascii */ if debug_sw then call ioa_ (":iln fn/ln ch/gp lmarg rmarg width depth" || " lead s med fnt sz"); %page; image_loop: do ilin = 1 to page_image.count; /* for all given image lines */ debug_sw, detail_sw, long_sw, text_sw = "0"b; fonts_done, fonts_needed ="0"b; Lmarg, col_width, text_width = 0; if (shared.bug_mode | db_sw) then if ilin >= db_line then do; debug_sw = "1"b; if dt_sw then detail_sw = "1"b; else detail_sw = "0"b; if lg_sw then long_sw = "1"b; else long_sw = "0"b; if tx_sw then text_sw = "1"b; else text_sw = "0"b; end; /**/ /* set text pointer */ txtstrptr = page_image.line (ilin).ptr; loctxt = txtstr; /* copy txtstr */ txtlen = length (txtstr); /* and record length */ trim_font: /* trim trailing font change */ if txtlen > 7 then if substr (loctxt, txtlen - 7, 2) = "À" then do; txtlen = txtlen - 8; goto trim_font; end; lineinfoptr = addr (page_image.line (ilin).info); quad = page_image.line (ilin).quad; if debug_sw then call blat; Yspc = divide (page_image.line (ilin).depth, Ypixel, 31, 0) - Ypos - Yinit; if ilin > 1 then Yspc = Yspc - auto_lead; /* account for the "free" amount */ need_font = page_image.line (ilin).lfnt; need_size = page_image.line (ilin).lsize; if txtlen > 0 then do; if font_in ^= need_font then call set_font (need_font, need_size); if page_image.line (ilin).lmarg > 0 then Lmarg = divide (page_image.line (ilin).lmarg, Xmptstrk, 31, 0); if page_image.line (ilin).net > 0 then col_width = divide (page_image.line (ilin).net, Xmptstrk, 31, 0); if page_image.line (ilin).width > 0 then text_width = divide (page_image.line (ilin).width, Xmptstrk, 31, 0); /**** &line_init FOR ascii */ /**** NO CODE *//**** END ascii */ if quad = quadr | quad = quadc then /* if setting right */ do; /* or center */ Xspc = col_width - text_width; if quad = quadc /* if centering, take half */ then Xspc = round (divide (max (Xspc, 0), 2, 31, 1), 0); Lmarg = Lmarg + Xspc; end; /**/ /* if justifying and device doesnt */ if quad = just & ^comp_dvt.justifying /* and there are some gaps */ & page_image.line (ilin).gaps > 0 then call pad_block; rescan_line: if detail_sw then call ioa_ ("^5x(rescan_line: Lmarg=^f lvl=^d)", show (Lmarg * Xmptstrk, 12000), window_level); word = ""; /* clear word accumulator */ wrdwidth = 0; if Yspc ^= 0 then call plot (SHIFT_OP, 0, Ypos + Yspc); Yspc = 0; /* initial movement */ Xspc = Lmarg - Xpos; if font_in ^= page_image.line (ilin).lfnt | font_size ^= page_image.line (ilin).lsize then call set_font (page_image.line (ilin).lfnt, page_image.line (ilin).lsize); char_loop: /* process each character */ do ichr = 1 to txtlen; tchr = substr (loctxt, ichr, 1); if tchr ^= DC1 /* do any font chars */ then font_char: do; char_ndx = rank (tchr); /* fnttbl index for text char */ /* -> replacement */ repl_str_ptr = fnttbl.replptr (char_ndx); /* if there's no replacement */ if repl_str_ptr = null () then do; /* if not already reported */ if index (bad_chrs, tchr) = 0 then do; /* add to bad chars and report */ bad_chrs = bad_chrs || tchr; call comp_report_$ctlstr (2, comp_error_table_$program_error, lineinfoptr, loctxt, "Font ^a, no replacement for ""^a"" (\^.3b)", fnttbl.entry.name, tchr, unspec (tchr)); if abrt_sw /* abort if desired */ then signal null_font_char; end; goto end_chars; /* skip rest of line */ end; /**/ /* copy fnttbl data */ fcdevfnt = fnttbl.devfnt (char_ndx); /* white space? */ if fnttbl.white (char_ndx) then do; if word ^= "" /* flush current word */ then do; call put_str (word, wrdwidth); wrdwidth = 0; tstr.white = "0"b; end; fcwidth = fnttbl.units (char_ndx); Xspc = Xspc + fcwidth; if text_sw & ^pref_sw then call ioa_ ("^5x(text: ^d ^i ^f ^f ""^1a"" WS)", fcdevfnt, fcwidth, show (fcwidth * Xmptstrk, 12000), show ((Xpos + Xspc) * Xmptstrk, 12000), comp_util_$display ((tchr), 0, "0"b)); end; /**/ else /* not white space */ do; /* emit any accumulated motion */ if Yspc ^= 0 | (Xspc ^= 0 & txtlen ^= 0) then call plot (SHIFT_OP, Xpos + Xspc, Ypos + Yspc); Xspc, Yspc = 0; if tstr.devfnt = 0 then call set_media (font_in, fcdevfnt); /**** &process_text FOR ascii */ /**** NO CODE */ /**** END ascii */ word = word || replstr; fcwidth = fnttbl.units (char_ndx); wrdwidth = wrdwidth + fcwidth; if text_sw & ^pref_sw then call ioa_ ("^5x(text: ^d ^i ^f ^f ""^a"" -> ""^a^va"")", fcdevfnt, fcwidth, show (fcwidth * Xmptstrk, 12000), show ((Xpos + Xspc + wrdwidth) * Xmptstrk, 12000), comp_util_$display ((tchr), 0, "0"b), comp_util_$display (replstr, 0, "0"b), repl_str.len - length (rtrim (replstr)), " "); end; end font_char; else ctl_char: do; /* its a DC1 control string */ if word ^= "" /* flush current word */ then do; call put_str (word, wrdwidth); wrdwidth = 0; tstr.white = "0"b; end; DCxx_p = /* set control string overlay ptr */ addr (substr (loctxt, ichr, 1)); /* for device/writer controls */ if dcxx.ctl.type = "000"b then do; (nostrg): if long_sw then call ioa_ ("^5x(CTL: ^[wait^]^[unstrt^]^[unstop^]" || " ^a^[ Xpos=^f^;^s^])", (dcfs.type = type_wait), (dcfs.type = type_unstart), (dcfs.type = type_unstop), comp_util_$display ((substr (loctxt, ichr, dcxx.leng + 3)), 0, "0"b), (dcfs.type = type_unstart) | (dcfs.type = type_unstop), show ((Xpos + Xspc) * Xmptstrk, 12000)); /* a midpage wait? */ if dcfs.type = type_wait then do; /* any accumulated motion? */ if Xspc ^= 0 then call plot (SHIFT_OP, Xpos + Xspc, Ypos); Xspc = 0; /**/ /* user will give NL */ Yspc = Yspc - divide (12000, Ypixel, 31, 0); page_record.halt4 = "1"b; page_record.nextref = "0"b; page_record_ptr = addr (page_record.nextref); page_record.leng, tstr.last_cr = 0; unspec (page_record.sws) = "0"b; page_record.in_use = "1"b; end; /**/ /* start underscore? */ if dcfs.type = type_unstart then do; unstart = max (Xpos + Xspc, Lmarg); unstring = "1"b; end; /**/ /* stop underscore? */ if dcfs.type = type_unstop then do; /* underscoring active? */ if unstring & tstr_line ^= "" & ^(page_image.line (ilin).cbar | page_image.line (ilin).mrgtxt) then do; call put_uns; unstring = "0"b; end; end; end; /**/ /* a font change? */ else if dcfs.type = type_font then do; if long_sw then do; (nostrg): debug_str = substr (loctxt, ichr, dcxx.leng + 3); call ioa_ ("^5x(CTL: font ^a)", comp_util_$display (debug_str, 0, "0"b)); end; need_font = dcfs.f; need_size = dcfs.p; call set_font (need_font, need_size); end; /**/ /* a literal? */ else if dcfs.type = type_lit then do; call put_str (substr (loctxt, ichr + 3, dcxx.leng), 0); if long_sw then do; (nostrg): debug_str = substr (loctxt, ichr, dcxx.leng + 3); call ioa_ ("^5x(CTL: literal ^a)", comp_util_$display (debug_str, 0, "0"b)); end; end; else /* its either a shift or a vector */ do; /* fetch a short X */ if (dcxx.Xctl = "01"b) then Xmpts = dcshort_val.v1; /* fetch a long X */ else if (dcxx.Xctl = "10"b) then Xmpts = dclong_val.v1; else Xmpts = 0; /* no X movement */ if (dcxx.Xctl ^= "00"b) then /* if X is given */ do; /* then Y is in v2 */ /* fetch a short Y */ if (dcxx.Yctl = "01"b) then Ympts = dcshort_val.v2; /* fetch a long Y */ else if (dcxx.Yctl = "10"b) then Ympts = dclong_val.v2; else Ympts = 0; end; else /* no X was given */ do; /* fetch a short Y */ if (dcxx.Yctl = "01"b) then Ympts = dcshort_val.v1; /* fetch a long Y */ else if (dcxx.Yctl = "10"b) then Ympts = dclong_val.v1; else Ympts = 0; end; /**/ /* shift */ if dcxx.type = "100"b then do; if font_in = 0 then call set_font (need_font, need_size); Xmov = sign (Xmpts) * round (divide (abs (Xmpts) - 4, Xmptstrk, 31, 1), 0); Xspc = Xspc + Xmov; Ymov = sign (Ympts) * divide (abs (Ympts), Ypixel, 17, 0); Yspc = Yspc + Ymov; if long_sw then do; (nostrg): debug_str = substr (loctxt, ichr, dcxx.leng + 3); call ioa_ ("^5x(CTL: shift ^f ^f (^f ^f) ^a)", show (Xmpts, 12000), show (Ympts, 12000), show (Xspc * Xmptstrk, 12000), show (Yspc,12000), comp_util_$display (debug_str, 0, "0"b)); end; end; else do; /* not shift, it must be vector */ if Xspc ^= 0 | Xmpts > 0 then if font_in ^= need_font | font_size ^= need_size then call set_font (need_font, need_size); /* need to position first? */ if Xspc ^= 0 | Yspc ^= 0 then call plot (SHIFT_OP, Xpos + Xspc, Ypos + Yspc); Xspc, Yspc = 0; Xspc = divide (Xmpts, Xmptstrk, 31, 0); Yspc = divide (Ympts, Ypixel, 31, 0); if long_sw then do; (nostrg): debug_str = substr (loctxt, ichr, dcxx.leng + 3); call ioa_ ("^5x(CTL: vector ^f ^f ^a)", show (Xmpts, 12000), show (Ympts, 12000), comp_util_$display (debug_str, 0, "0"b)); end; call plot (VECTOR_OP, Xpos + Xspc, Ypos + Yspc); Xspc, Yspc = 0; end; end; /**/ /* move to last ctl char */ ichr = ichr + dcxx.leng + 2; end ctl_char; /* end of control sequence loop */ end_chars: end char_loop; if word ^= "" /* flush last word */ then do; call put_str (word, wrdwidth); wrdwidth = 0; tstr.white = "0"b; end; if unstring /* underscoring active? */ & ^(page_image.line (ilin).cbar | page_image.line (ilin).mrgtxt) then call put_uns; /**** &line_finish FOR ascii */ /**** NO CODE */ /**** END ascii */ if detail_sw then do; call ioa_ ("^5x(line_finish: tstr lvl=^d ^[^^^]opn Y=^f X=^f ln=^d)", window_level, ^(tstr.open), show (Ypos * Ypixel, 12000), show (Xpos * Xmptstrk, 12000), length (tstr_line)); if tstr.open then call ioa_ ("""^a^va""", comp_util_$display (rtrim (tstr_line), 0, "0"b), length (tstr_line) - length (rtrim (tstr_line)), " "); end; end; end image_loop; finish_page: if detail_sw then call ioa_ ("^5x(finish_page:)"); /* add any trailing lead */ if page_image.line (page_image.count).white then call plot (SHIFT_OP, 0, Ypos + divide (page_image.line (page_image.count).lead, Ypixel, 31, 0)); call put_; /* flush output image */ call release_window; /* discard image just put */ if ^option.galley_opt then do; if comp_dvt.endpage ^= "0"b /* if FF is defined, then */ then /* replace last NL with it */ substr (page_record.text, page_record.leng, 1) = byte (bin (comp_dvt.endpage)); /* else run out the page with NLs */ else if Ypos < divide (page.parms.length, Ypixel, 31, 0) then do; runout = divide (page.parms.length, 12000, 31, 0) - 1 - divide (Ypos, line_window_size, 31, 0) - bin (option.stop_opt); page_record.leng = page_record.leng + runout; substr (page_record.text, page_record.leng - runout + 1, runout) = copy (NL, runout); end; /**/ /**** &page_finish FOR ascii */ /**** NO CODE */ /**** END ascii */ end; page_record.nextref = "0"b; /* show nothing follows */ return_: if debug_sw then call ioa_ (" (ascii_writer_)"); return; %page; footproc: entry (footref, ptr); /* PARAMETERS */ /* actual reference string */ dcl footref (3) char (*) var; dcl ptr ptr; /* -> comp_dvt */ /* &foot_proc for ascii */ footref (1) = "("; footref (3) = ")"; if (shared.bug_mode | db_sw) then do; call ioa_ ("ascii_writer_$footproc: ^a", comp_util_$display (footref (1) || footref (2) || footref (3), 0, "0"b)); end; return; %page; /* This routine returns a printable interpretation of a native device string */ dcl ascii_writer_$display entry (char (*) var, fixed bin (24), bit (1)) returns (char (*) var); display: entry (dtext, dlen, noerr) returns (char (*) var); /* PARAMETERS */ dcl dtext char (*) var; /* string to be displayed */ dcl dlen fixed bin (24); /* chars scanned by this call */ dcl noerr bit (1); /* 1= dont print error messages */ /* LOCAL STORAGE */ dcl ch char (1); /* extracted text char */ dcl ct fixed bin; /* number of duplicate chars */ dcl dstr char (1020) var; /* working string */ dcl rtn_str char (16384) var;/* return string */ if dev_stat_ptr = null () then dev_stat_ptr = addr (stat_blk); if stat_blk (1) ^= -1 /* check status block */ then do; stat_blk (*) = 0; stat_blk (1) = -1; end; rtn_str = ""; /* clear return string */ ct = 0; ch = substr (dtext, 1, 1); /* extract a char */ if ch = THIN then do; ct = verify (dtext, THIN); /* how many? */ if ct = 0 /* all the rest */ then ct = length (dtext); else ct = ct - 1; if ct > 1 /* if more than one */ then call ioa_$rsnnl ("<THN*^d>", dstr, 0, ct); else dstr = "<THN>"; rtn_str = rtn_str || dstr; end; else if ch = DEVIT then do; ct = verify (dtext, DEVIT); /* how many? */ if ct = 0 /* all the rest */ then ct = length (dtext); else ct = ct - 1; if ct > 1 /* if more than one */ then call ioa_$rsnnl ("<DVT*^d>", dstr, 0, ct); else dstr = "<DVT>"; rtn_str = rtn_str || dstr; end; else do; device_display: /* &display FOR DEVICE ascii */ /**** NO CODE */ /**/ /* END DEVICE ascii */ end; disp_ret: dlen = ct; return (rtn_str); /* end of display */ %page; artproc: entry (); /**/ /* &art_proc for ascii */ /**** NO CODE */return; %page; blat: proc; dcl blatstr char (1020) var; call ioa_$nnl (":^3d^3d/^d^12t^4d/^i^18t^5(^8f^)" || " ^[I^]^[O^]^[L^]^[C^]^[R^]^[J^]^[L^]^60t^3i ^6a ^f^/^4x", ilin, page_image.line (ilin).fileno, page_image.line (ilin).lineno, txtlen, page_image.line (ilin).gaps, show (page_image.line (ilin).lmarg, 12000), show (page_image.line (ilin).rmarg, 12000), show (page_image.line (ilin).width, 12000), show (page_image.line (ilin).depth, 12000), show (page_image.line (ilin).lead, 12000), quad & quadi, quad & quado, quad & quadl, quad & quadc, quad & quadr, quad & just, (quad = "0"b), page_image.line (ilin).lfnt, fnttbldata.ptr (page_image.line (ilin).lfnt) -> fnttbl.entry.name, show (fnttbldata.ptr (page_image.line (ilin).lfnt) -> fnttbl.entry.size, 1000), txtlen); blatstr = comp_util_$display (substr (loctxt, 1, txtlen), 0, "0"b); call ioa_ ("""^a^va""", blatstr, length (blatstr) - length (rtrim (blatstr)), " "); end blat; %page; release_window: proc; call translator_temp_$release_all_segments (window_area_ptr, 0); end release_window; %page; move_tstr: /* move tstr ptr to new window level */ proc (incr); /* PARAMETERS */ dcl incr fixed bin (31); /* amount to move */ if detail_sw then call ioa_ ("^-(move_tstr: ^d -> ^d)", window_level, window_level + incr); window_level = window_level + incr; max_level = max (max_level, window_level); tstr_ptr = addr (window (window_level)); tstr.ypos, Ypos = Ypos + incr; Xpos = tstr.xpos; tstr.open = "1"b; if tstr.str_ptr = null then tstr.str_ptr = allocate (window_area_ptr, 1024); end move_tstr; %page; show: proc (datum, scale) returns (fixed dec (11, 3)); dcl datum fixed bin (31); dcl scale fixed bin (31); return (round (dec (round (divide (datum, scale, 31, 11), 10), 11, 4), 3)); end show; %page; plot: proc (PLOT_OP, new_xpos, new_ypos); /* This routine moves the current position to (new_xpos,new_ypos), */ /* plotting or shifting according to the value of PLOT_OP. */ /* PARAMETERS */ dcl PLOT_OP bit (1); /* 0-shift; 1-vector */ dcl new_xpos fixed bin (31); /* needed horizontal position */ dcl new_ypos fixed bin (31); /* needed vertical position */ /* LOCAL STORAGE */ dcl copystr char (2048) var; dcl exit_str char (32) var; dcl old_xpos fixed bin (31); dcl old_ypos fixed bin (31); dcl penctl char (6) var; /* pen control string */ dcl pltstr char (4090) var; dcl pltwidth fixed bin (31); dcl xii fixed bin; /* working value */ dcl xmove fixed bin (31); /* X movement */ dcl ymove fixed bin (31); /* Y movement */ if new_xpos = Xpos & new_ypos = Ypos then return; xmove, ymove, pltwidth = 0; pltstr = ""; old_xpos = Xpos; /* case a VSFT changes Xpos */ old_ypos = Ypos; xmove = new_xpos - Xpos; ymove = new_ypos - Ypos; if detail_sw then call ioa_ ("^5xplot: (^[V^;S^] ^f/^f -> ^f/^f = ^f/^f)", PLOT_OP, show (Xpos * Xmptstrk, 12000), show (Ypos * Ypixel, 12000), show (new_xpos * Xmptstrk, 12000), show (new_ypos * Ypixel, 12000), show (xmove * Xmptstrk, 12000), show (ymove * Ypixel, 12000)); if ^PLOT_OP /* if a SHIFT is wanted */ then do; if ymove ^= 0 /* any Y movement? */ then do; if window_level + ymove < window_top | window_level + ymove > window_bottom then do; call comp_report_$ctlstr (2, comp_error_table_$program_error, lineinfoptr, loctxt, "Attempt to place a line off page ^a at line ^d.", page.hdr.pageno, window_level); signal comp_abort; end; call move_tstr (ymove); ymove = 0; xmove = new_xpos - Xpos; end; penctl = PENUP; /* init for pen up */ end; /**/ /* else a VECTOR is wanted */ else penctl = PENDOWN; /* init for pen down */ /**** &plot FOR ascii */ if ^PLOT_OP then do; if xmove ^= 0 /* any X movement? */ then do; if xmove > 0 then copystr = copy (" ", xmove); else copystr = copy (BSP, -xmove); pltstr = pltstr || copystr; pltwidth = pltwidth + xmove; xmove = 0; end; end; else do; if ymove ^= 0 /* no vertical vectors allowed */ then call comp_report_$exact ("Vertical vectors not allowed " || "for the printer device.", lineinfoptr); if xmove < 0 /* no rev horiz vectors allowed */ then call comp_report_$exact ("Reverse horizontal vectors not " || "allowed for ascii device.", lineinfoptr); else if xmove > 0 /* forward horizontal vector */ then do; pltstr = pltstr || copy ("_", xmove); pltwidth = pltwidth + xmove; xmove = 0; end; end; /**** END ascii */ plot_return: if length (pltstr) > 0 then call put_str (pltstr, pltwidth); /* Xpos, tstr.xpos = new_xpos;*/ if detail_sw then call ioa_ ("^-(plot: ^f/^f lvl=^d ^[^^^]opn^[ W^])", show (Xpos * Xmptstrk, 12000), show (Ypos * Ypixel, 12000), window_level, ^tstr.open, tstr.white); /* Xplt, Yplt = 0; /* motion used */ end plot; %page; pad_block: proc; /**/ /* these two values in fixed dec so round off doesnt affect pad placement. */ /* dcl /* ( igap, /* gap counter for padding */ /* padeach /* padding interval */ /* ) fixed dec (11, 3);*/ dcl ( igap, /* gap counter for padding */ padeach /* padding interval */ ) fixed bin; dcl gaps fixed bin; /* gap count for line */ dcl jl_ptr ptr; /* pointer to the justified line */ dcl just_line char (1020) var; /* pads per gap */ dcl pads (page_image.line (ilin).gaps) fixed bin; dcl padsize fixed bin; /* pad space in pixels */ dcl 1 pad_ctl like dclong_val; /* for inserting pads */ dcl pad_ctl_ptr ptr; dcl pad_string char (7) based (pad_ctl_ptr); dcl SP_DC1 char (2) int static options (constant) init (" "); just_line = ""; /* clear the justified line */ jl_ptr = addr (just_line); /* and set pointer for the overlay */ if font_in ^= need_font then call set_font (need_font, need_size); if col_width < 0 then col_width = divide (page_image.line (ilin).net, Xmptstrk, 31, 0); if text_width > 0 then text_width = divide (page_image.line (ilin).width, Xmptstrk, 31, 0); if Xpixel ^= EN_width /* set up pad_ctl string */ then do; pad_ctl.mark = DC1; pad_ctl.type = type_slx; pad_ctl.leng = dclong1_len; pad_ctl.v2 = 0; pad_ctl_ptr = addr (pad_ctl); end; gaps = page_image.line (ilin).gaps; padsize = max (0, col_width - text_width); /* fill in common amount */ pads = fnttbl.units (rank (STROKE)) * divide ( divide (padsize, gaps, 17, 0), fnttbl.units (rank (STROKE)), 17, 0); /* then get the leftover amount */ padsize = padsize - pads (1) * gaps; if long_sw then call ioa_$nnl ("^5x(pad_block: l/w/r=^f/^f/^f gp=^i pd=^i+^i", show (Lmarg * Xmptstrk, 12000), show (text_width * Xmptstrk, 12000), show (page_image.line (ilin).rmarg, 12000), gaps, pads (1), padsize); do while (padsize > 0); /* use up any leftovers */ padeach = /* pad interval */ max (round (divide (gaps * fnttbl.units (rank (STROKE)), padsize, 17, 1), 0), 1); igap = max (round (divide (gaps * fnttbl.units (rank (STROKE)), 2 * padsize, 17, 1), 0), 1); do igap = igap to gaps by padeach while (padsize > 0); pads (igap) = pads (igap) + fnttbl.units (rank (STROKE)); padsize = padsize - fnttbl.units (rank (STROKE)); end; end; if long_sw then call ioa_ ("^(,^i^))", pads); ichr = verify (loctxt, " "); /* start at front of text */ if ichr > 1 then just_line = just_line || copy (EN, ichr - 1); do j = 1 to gaps; try_again: /* find word boundary */ k = search (substr (loctxt, ichr, txtlen - ichr + 1), SP_DC1) - 1; if k < 0 /* MGOD! gap count is too large */ then do; if detail_sw then do; call ioa_$nnl ("gap=^i ", gaps); call blat; end; goto gap_exit; end; /**/ /* copy word */ just_line = just_line || substr (loctxt, ichr, k); ichr = ichr + k; /* step over "word" */ /* did we find a control? */ if substr (loctxt, ichr, 1) = DC1 then do; /* set pointer */ DCxx_p = addr (substr (loctxt, ichr)); k = dcxx.leng + 3; /* and control string length */ /* copy ctl str */ just_line = just_line || substr (loctxt, ichr, k); ichr = ichr + k; goto try_again; end; ichr = ichr + 1; /* skip the wordspace */ if Xpixel = EN_width /* now, any excess count */ then just_line = just_line || copy (" ", pads (j)); else do; pad_ctl.v1 = pads (j) * Xmptstrk; just_line = just_line || pad_string; end; end; gap_exit: k = txtlen - ichr + 1; /* length of the last word */ /* move the last word */ just_line = just_line || substr (loctxt, ichr, k); loctxt = just_line; /* switch to the justified line */ txtlen = length (just_line); if long_sw then call ioa_ ("^a", comp_util_$display (just_line, 0, "0"b)); end pad_block; %page; put_: proc; dcl level fixed bin; dcl level_skip fixed bin; if detail_sw then call ioa_ ("^5x(put: maxlvl=^d)", max_level); level_skip = 0; if first_line then do level = window_top to -1 /* discard leading null lines */ while (^window (level).open); end; else level = window_top; do level = level to max_level; tstr_ptr = addr (window (level)); /**/ if tstr.str_ptr = null then do; tstr.str_ptr = allocate (window_area_ptr, 1024); tstr_line = ""; end; /**/ /* &put FOR DEVICE ascii */ if tstr.open /* is this line open? */ then do; /* see if canonizing is needed */ if search (tstr_line, BSCR) > 0/* any overprinting? */ then do; scndx = 1; beadct, icol = 0; /* clear counters */ /* scan the input line */ do j = 1 to length (tstr_line); /* extract next char */ tchr = substr (tstr_line, j, 1); /* all printing chars are 1 */ if (rank (tchr) > 32 & rank (tchr) <= 126) then do; beadct = beadct + 1;/* count a bead */ bead (beadct).char = tchr; /* note (apparent) position */ bead (beadct).loc = icol; icol = icol + 1; /* and advance */ end; else if tchr = " " /* a space? */ then do; /* how many? */ i = verify (substr (tstr_line, j), " ") - 1; if i < 0 /* trailing ws */ then i = length (tstr_line) - j + 1; icol = icol + i; j = j + i - 1; /* advance scan index */ end; else if tchr = BSP /* a backspace? */ then do; /* how many? */ i = verify (substr (tstr_line, j), BSP) - 1; if i < 0 /* trailing BSPs */ then i = length (tstr_line) - j + 1; /* dont back off end */ icol = max (icol - i, 0); j = j + i - 1; /* advance scan index */ end; else if tchr = CR /* a carriage return? */ then icol = 0; /* go back to square 1! */ else if tchr = HT /* may be HTs from SHIFTs */ then icol = 10 * divide (icol, 10, 17, 0) + 10; end; /* end of scan loop */ /* sort the beads */ if long_sw then call ioa_ ("^5x(beads=(^d) ^v(^a^))", beadct, beadct, beads.char); d = beadct; sort: d = divide (d + 1, 2, 17, 0); swps = 0; do i = 1 to beadct - d; /* sort columns only */ (nosubrg): if bead (i).loc > bead (i + d).loc then goto swap; else /* make _'s first */ (nosubrg): if bead (i).loc = bead (i + d).loc then if bead (i + d).char = "_" & bead (i).char ^= "_" then do; swap: tbead = unspec (bead (i)); bead (i) = bead (i + d); unspec (bead (i + d)) = tbead; swps = swps + 1; end; end; if long_sw then call ioa_ ("^5x(swaps=^d@^d, beads ^v(^a^))", swps, d, beadct, beads.char); if swps > 0 | d > 1 then goto sort; ocol = 0; /* set up for bead stringing */ tstr_line = ""; do j = 1 to beadct; /* put sorted beads back into line */ /* bead separation */ space = bead (j).loc - ocol; if space > 0 /* any needed? */ then tstr_line = tstr_line || copy (" ", space); if space < 0 /* overstrike? */ then tstr_line = tstr_line || BSP; /* finally, the character */ tstr_line = tstr_line || bead (j).char; ocol = bead (j).loc + 1; /* next column */ end; /* end of bead stringing loop */ if long_sw then call ioa_ ("^7x(canon: ^d ^f ""^a"")", length (tstr_line), show (Xpos, 12000), comp_util_$display (tstr_line, 0, "0"b)); end; /* end of overprint loop */ /* trim trailing WS */ tstr_line = rtrim (tstr_line); tstr.last_cr = page_record.leng; end; tstr_line = tstr_line || NL; /**/ /* END DEVICE ascii */ if detail_sw then call ioa_ ("^7x(lvl=^d ^d+^d=^d ""^a"")", level, page_record.leng, length (tstr_line), page_record.leng + length (tstr_line), comp_util_$display (tstr_line, 0, "0"b)); level = level + level_skip; tstr.last_cr = 0; page_record.leng = page_record.leng + length (tstr_line); substr (page_record.text, page_record.leng - length (tstr_line) + 1, length (tstr_line)) = tstr_line; end; if page_record.leng > 0 then page_record.in_use = "1"b; Ypos = tstr.ypos; end put_; %page; put_str: proc (string, width); dcl string char (4090) var; /* string to put */ dcl width fixed bin (31); /* string width */ dcl (i, j) fixed bin; dcl new_len fixed bin; dcl old_len fixed bin; dcl pos fixed bin (31); /* current position */ if tstr.devfnt ^= need_devfnt then call set_media (font_in, need_devfnt); old_len = length (tstr_line) - tstr.last_cr; new_len = old_len + length (string); if new_len > MAX_STR then do; end; if detail_sw then do; debug_str = comp_util_$display (string, 0, "0"b); call ioa_ ( "^5x(put_str: lvl=^d X=^f+^f=^f ^d+^d=^d^[(^d)^;^s^] ""^a^va"")", window_level, show (Xpos * Xmptstrk, 12000), show (width * Xmptstrk, 12000), show ((Xpos + width) * Xmptstrk, 12000), old_len, length (string), new_len, (tstr.last_cr > 0), length (tstr_line) + length (string), debug_str, length (debug_str) - length (rtrim (debug_str)), " "); end; tstr_line = tstr_line || string; Xpos, tstr.xpos = Xpos + width; string = ""; width = 0; tstr.open = "1"b; end put_str; %page; put_uns: proc; dcl Y_offs fixed bin (31); /* baseline offset */ dcl unslen fixed bin (31);/* length of underscore */ Y_offs = 0; unslen = Xpos + Xspc - unstart; if unslen > 0 then do; if detail_sw then call ioa_ ("^5x(put_uns: ^f)", show (unslen * Xmptstrk, 12000)); Xspc = Xspc - unslen; /* go to start */ call plot (SHIFT_OP, Xpos + Xspc, Ypos + Y_offs); Xspc, Yspc = 0; /**/ /* put the underscore */ call plot (VECTOR_OP, Xpos + unslen, Ypos); unstart = Lmarg; if detail_sw then call ioa_ ("^-(put_uns)"); end; end put_uns; %page; set_font: proc (new_font, new_size); /* PARAMETERS */ dcl new_font fixed bin; /* desired font index */ dcl new_size fixed bin (31); /* desired pointsize */ dcl chng bit (1); chng = (font_in ^= new_font | font_size ^= new_size); if chng then do; if detail_sw then do; if font_in = 0 then call ioa_$nnl ("^5x(set_font: 0 - 0. -->"); else call ioa_$nnl ("^5x(set_font: ^i ^a ^f -->", font_in, fnttbldata.ptr (font_in) -> fnttbl.entry.name, show (font_size, 1000)); end; font_in = new_font; end; fnttbl_ptr = fnttbldata.ptr (font_in); substr (fonts_needed, font_in, 1) = "1"b; need_devfnt = fnttbl.devfnt (32); /**** &set_font FOR ascii */ /**** NO CODE */ /**** END ascii */ if siztbl.ct = 1 then font_size, new_size = siztbl.size (1); else font_size = new_size; Xmptstrk = divide (font_size, fnttbl.rel_units, 31, 0); EM_width = divide (font_size * fnttbl.units (rank (EM)), fnttbl.rel_units, 31, 10); EN_width = divide (font_size * fnttbl.units (rank (EN)), fnttbl.rel_units, 31, 10); THIN_width = divide (font_size * fnttbl.units (rank (THIN)), fnttbl.rel_units, 31, 10); if (detail_sw | long_sw) & chng then do; call ioa_ (" ^i ^a ^f Xscl=^d)", new_font, fnttbldata.ptr (new_font) -> fnttbl.entry.name, show (font_size, 1000), Xmptstrk); if long_sw then call ioa_ ("^-(HUGE=^d EM=^d EN=^d THK=^d MED=^d " || "THN=^d HAIR=^d STRK=^d)", fnttbl.units (rank (HUGE)), fnttbl.units (rank (EM)),fnttbl.units (rank (EN)), fnttbl.units (rank (THICK)),fnttbl.units (rank (MEDIUM)), fnttbl.units (rank (THIN)),fnttbl.units (rank (DEVIT)), fnttbl.units (rank (STROKE))); end; end set_font; %page; set_media: proc (media_font, new_devfnt); /* PARAMETERS */ dcl media_font fixed bin; /* font needing the media */ dcl new_devfnt fixed bin; /* wanted device font */ /* LOCAL STORAGE */ dcl chng bit (1); /* 1= media or size has to change */ dcl med_chng bit (1); /* 1= media has to change */ dcl size_chng bit (1); /* 1= size has to change */ dcl temp_r bit (18); med_chng = tstr.devfnt ^= new_devfnt; size_chng = media_size ^= font_size; chng = med_chng | size_chng; if detail_sw & chng then call ioa_$nnl ("^5x(set_media: siz=^f med=^d --> siz=^f med=^d ", show (media_size, 1000), tstr.devfnt, show (font_size, 1000), new_devfnt); /**** &set_media FOR ascii */ medselstr = ""; /**** END ascii */ /**** &set_ps FOR ascii */ media_size = 7200; font_media (font_in) = 1; /* ascii has only one */ /**** END ascii */ if detail_sw & chng then call ioa_ ("sel=""^a"")", comp_util_$display ((medsel (new_devfnt)), 0, "0"b)); /* if not in media needed */ if med_chng /* ...change to it */ then do; tstr.devfnt = new_devfnt; tstr.font = media_font; end; end set_media; /* device ascii "other_procs" */ /**** NO CODE */dcl db_sw bit (1) aligned static init ("0"b); dbn: entry;db_sw = "1"b;goto db_join; dbf: entry;db_sw = "0"b;return; dcl tx_sw bit (1) aligned static init ("0"b); txn: entry; tx_sw = "1"b; goto db_join; txf: entry; tx_sw = "0"b; return; dcl lg_sw bit (1) aligned static init ("0"b); lgn: entry; lg_sw = "1"b; goto db_join; lgf: entry; lg_sw = "0"b; return; dcl pf_sw bit (1) aligned static init ("0"b); pfn: entry; pf_sw = "1"b; return; pff: entry; pf_sw = "0"b; return; dcl abrt_sw bit (1) aligned static init ("0"b); abrtn: entry; abrt_sw = "1"b; return; abrtf: entry; abrt_sw = "0"b; return; dcl dt_sw bit (1) aligned static init ("0"b); dtn: entry;dt_sw = "1"b;goto db_join; dtf: entry;dt_sw = "0"b;return; alln: entry; db_sw, dt_sw, lg_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, "ascii_writer_"); return; end; db_line = convert (db_line, arg); return; allf: entry; db_sw, lg_sw, tx_sw, pf_sw, dt_sw, abrt_sw = "0"b; return; %page; /* This one include file contains all the compose includes necessary for an */ /* output writer */ % include comp_outproc; end ascii_writer_;  ascii_writer_.pl1.xdw 04/23/85 1256.1rew 04/23/85 0908.5 60300 /* *********************************************************** * * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * Copyright, (C) Honeywell Information Systems Inc., 1980 * * * * * *********************************************************** */ &ext device=ascii&; &ext notes= /* This is a 10 pitch ascii typewriter. It has no plotting capability. There */ /* is an attempt to represent artwork constructs in an understandable */ /* (if not always pretty) fashion. */ &; &ext devclass=printer&; &ext dcls= &. dcl 1 bead (8192) aligned, /* bead structure for canonizing */ 2 loc fixed bin, /* column position */ 2 char char (1); /* the character */ dcl beadct fixed bin; /* count of beads */ /* bead array for debug */ dcl 1 beads (beadct) aligned based (beadp), 2 loc fixed bin, 2 char char (1); dcl beadp ptr; dcl BSCR char (2) static options (constant) init (" "); dcl d fixed bin; /* bead separation for sorting */ dcl icol fixed bin; /* working column position */ dcl ii fixed bin; /* working index */ dcl MAX_STR fixed bin static options (constant) init (1024); dcl ocol fixed bin; /* working column position */ dcl PENDOWN char (1) init ("_") static options (constant); dcl PENUP char (1) init (" ") static options (constant); dcl scndx fixed bin (21); /* output scanning index */ dcl space fixed bin; /* bead separation space */ dcl swps fixed bin; /* # of swaps in a sort pass */ /* temp for sorting beads */ dcl tbead bit (72) aligned; dcl (char, copy, search, rank) builtin; &; &ext page_init= beadp = addr (bead); &; &ext file_init= &. max_revlead = 0; /* ascii cant back up */&+ &; &ext put=&+ if tstr.open /* is this line open? */ then do; /* see if canonizing is needed */ if search (tstr_line, BSCR) > 0/* any overprinting? */ then do; scndx = 1; beadct, icol = 0; /* clear counters */ /* scan the input line */ do j = 1 to length (tstr_line); /* extract next char */ tchr = substr (tstr_line, j, 1); /* all printing chars are 1 */ if (rank (tchr) > 32 && rank (tchr) <= 126) then do; beadct = beadct + 1;/* count a bead */ bead (beadct).char = tchr; /* note (apparent) position */ bead (beadct).loc = icol; icol = icol + 1; /* and advance */ end; else if tchr = " " /* a space? */ then do; /* how many? */ i = verify (substr (tstr_line, j), " ") - 1; if i < 0 /* trailing ws */ then i = length (tstr_line) - j + 1; icol = icol + i; j = j + i - 1; /* advance scan index */ end; else if tchr = BSP /* a backspace? */ then do; /* how many? */ i = verify (substr (tstr_line, j), BSP) - 1; if i < 0 /* trailing BSPs */ then i = length (tstr_line) - j + 1; /* dont back off end */ icol = max (icol - i, 0); j = j + i - 1; /* advance scan index */ end; else if tchr = CR /* a carriage return? */ then icol = 0; /* go back to square 1! */ else if tchr = HT /* may be HTs from SHIFTs */ then icol = 10 * divide (icol, 10, 17, 0) + 10; end; /* end of scan loop */ /* sort the beads */ if long_sw then call ioa_ ("^5x(beads=(^d) ^v(^a^))", beadct, beadct, beads.char); d = beadct; sort: d = divide (d + 1, 2, 17, 0); swps = 0; do i = 1 to beadct - d; /* sort columns only */ (nosubrg): if bead (i).loc > bead (i + d).loc then goto swap; else /* make _'s first */ (nosubrg): if bead (i).loc = bead (i + d).loc then if bead (i + d).char = "_" && bead (i).char ^= "_" then do; swap: tbead = unspec (bead (i)); bead (i) = bead (i + d); unspec (bead (i + d)) = tbead; swps = swps + 1; end; end; if long_sw then call ioa_ ("^5x(swaps=^d@^d, beads ^v(^a^))", swps, d, beadct, beads.char); if swps > 0 | d > 1 then goto sort; ocol = 0; /* set up for bead stringing */ tstr_line = ""; do j = 1 to beadct; /* put sorted beads back into line */ /* bead separation */ space = bead (j).loc - ocol; if space > 0 /* any needed? */ then tstr_line = tstr_line || copy (" ", space); if space < 0 /* overstrike? */ then tstr_line = tstr_line || BSP; /* finally, the character */ tstr_line = tstr_line || bead (j).char; ocol = bead (j).loc + 1; /* next column */ end; /* end of bead stringing loop */ if long_sw then call ioa_ ("^7x(canon: ^d ^f ""^a"")", length (tstr_line), show (Xpos, 12000), comp_util_$display (tstr_line, 0, "0"b)); end; /* end of overprint loop */ /* trim trailing WS */ tstr_line = rtrim (tstr_line); tstr.last_cr = page_record.leng; end; tstr_line = tstr_line || NL; &;&+ &ext plot=&+ if ^PLOT_OP then do; if xmove ^= 0 /* any X movement? */ then do; if xmove > 0 then copystr = copy (" ", xmove); else copystr = copy (BSP, -xmove); pltstr = pltstr || copystr; pltwidth = pltwidth + xmove; xmove = 0; end; end; else do; if ymove ^= 0 /* no vertical vectors allowed */ then call comp_report_$exact ("Vertical vectors not allowed " || "for the printer device.", lineinfoptr); if xmove < 0 /* no rev horiz vectors allowed */ then call comp_report_$exact ("Reverse horizontal vectors not " || "allowed for ascii device.", lineinfoptr); else if xmove > 0 /* forward horizontal vector */ then do; pltstr = pltstr || copy ("_", xmove); pltwidth = pltwidth + xmove; xmove = 0; end; end; &;&+ &ext set_media= medselstr = ""; &;&+ &ext set_ps= media_size = 7200; font_media (font_in) = 1; /* ascii has only one */ &;&+ &ext foot_proc= footref (1) = "("; footref (3) = ")"; &; &comp_dev_writer()