



		    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()
