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