1 /* *****************************************************************
2 * *
3 * *
4 * Copyright, C Honeywell Information Systems Inc., 1980. *
5 * *
6 * *
7 ***************************************************************** */
8
9 &expand comp_dev_writer
10 &+
11 &comment Check for a valid device class &;&+
12 &ext devclass=undefined&;
13 &if &index -printer-diablo-video-bitmap- "-&devclass-"=0&then
14 &error 3,device class must be printer|diablo|video|bitmap, not "&devclass"&;
15 &fi&+
16
17 &comment
18 Preset all externals so that *.pl1.xdw doesnt need to specify
19 all the ones it doesnt need
20 &;&+
21 &int no_code=/**** NO CODE */&;
22 &ext art_proc=&no_code&;
23 &ext cleanup=&no_code&;
24 &ext dcls=&no_code&;
25 &ext display=&no_code&;
26 &ext epilogue=&no_code&;
27 &ext file_init=&no_code&;
28 &ext foot_proc=&no_code&;
29 &ext image_init=&no_code&;
30 &ext justifying=no&;
31 &ext line_finish=&no_code&;
32 &ext line_init=&no_code&+&;
33 &ext machines=terminals&;
34 &ext notes&;
35 &ext other_procs=&no_code&;
36 &ext page_finish=&no_code&;
37 &ext put=&no_code&;
38 &ext page_init=&no_code&;
39 &ext PLOT&;
40 &ext unPLTcr&;
41 &ext plot=&no_code&;
42 &ext tab_x=&no_code&;
43 &ext process_text=&no_code&;
44 &ext set_font=&no_code&;
45 &ext SET_HMI&;
46 &ext set_media=&no_code&;
47 &ext set_ps=&no_code&;
48 &ext unPLOT&;
49 /* compose support routine to write output to &device &machines class &devclass */
50
51 /* PREFACE
52 /* This program handles length and distance values in "picture elements"
53 /* pixels. These are the native units in the machine and, sooner or later,
54 /* all internal length and distance values have to be converted to pixels to
55 /* actually get device output. In some cases the vertical and horizontal
56 /* pixels are not of the same size, i.e. a Diablo-type typewriter has
57 /* 60/inch horizontally and 48/inch vertically.
58
59 /* All values which are fixed bin 31 are in millipoints.
60
61 /* Debugging tools---
62 /* There are several switches that control debugging output from a writer--
63 /* shared.bug_mode db_sw dt_sw lg_sw
64 /* debug_sw detail_sw long_sw
65 /* shared.bug_mode is set via the family of -db arguments. It means that all
66 /* of compose is being debugged.
67 /* db_sw, dt_sw, lg_sw static are set by the entries dbn, dtn, and lgn */
68 /* respectively. They are reset by the entries dbf, dtf, and lgf. */
69
70 /* These switches interact with each other. In order to reduce the amount of */
71 /* code executed when not debugging, these interactions are distilled into */
72 /* automatic switches, debug_sw, detail_sw, and long_sw with this logic. */
73 /* debug_sw = shared.bug_mode | db_sw; */
74 /* detail_sw = debug_sw && dt_sw; */
75 /* long_sw = debug_sw && lg_sw; */
76 /* debug_sw controls these outputs-- */
77 /* -- entry and exit notification */
78 /* -- an interpretation of each line of the input structure before it is */
79 /* acted upon. */
80 /* -- gap count error notification */
81 /* detail_sw controls these outputs-- */
82 &if &devclass=diablo &then
83 /* -- preface indication */
84 &fi
85 /* -- justification calculations */
86 /* -- device control DCxx display */
87 /* -- plot trace */
88 /* -- put_ trace */
89 /* -- set_font trace */
90 /* -- set_media trace */
91 &if &devclass=diablo &then
92 /* -- overstrike processing notification */
93 &fi
94 /* long_sw controls these outputs-- */
95 /* -- shows the justified text line */
96 /* -- shows detailed Multics/device translation simple */
97
98 ¬es
99
100 /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */
101
102 &device&._writer_:
103 proc func code;
104
105 /* PARAMETERS */
106
107 dcl func fixed bin; /* function code */
108 /* 0 = build a page */
109 /* 1 = initialize a page */
110 /* 2 = initialize a file */
111 /* 3 = clean up */
112 /* 4 = prepare epilogue */
113 dcl code fixed bin 35; /* error code */
114
115 /* LOCAL STORAGE */
116
117 dcl auto_lead fixed bin 31; /* automatic baseline advance */
118 dcl BAD_CHAR char 1 static options constant init "ÿ";
119 /* list of bad font chars */
120 dcl bad_chrs char 128 var static;
121 dcl char_ndx fixed bin; /* index into font table */
122 dcl col_width fixed bin 31; /* calculated column width */
123 dcl debug_str char 1020 var;
124 dcl debug_sw bit 1;
125 dcl detail_sw bit 1;
126 dcl dev_stat_ptr ptr static init null ;
127 dcl EM_width fixed bin 31; /* width of EM */
128 dcl EN_width fixed bin 31; /* width of EN */
129 dcl fcdevfnt fixed bin; /* device font needed by a char */
130 dcl fcwidth fixed bin 31; /* font char width */
131 dcl first_line bit 1 static;
132 dcl first_page bit 1 aligned static init "0"b;
133 dcl font_in fixed bin; /* current font */
134 dcl font_size fixed bin 31; /* point size in current font */
135 dcl fonts_done bit 36; /* which fonts have been processed */
136 dcl fonts_needed bit 36; /* which fonts have been requested */
137 &if &index -bitmap- "-&devclass-" = 0 &then
138 &. dcl hot_chars char 35 static options constant
139 init "^@^A^B^C^D^E^F^G^H
140 ^K^L^M^N^O^P^Q^R^S^T^U^V^W^X^Y^Z^[^\^]^^^_^?þÿ";
141 &fi
142 &. dcl i j jj k ll
143 fixed bin;
144 dcl ichr fixed bin; /* index to current text character */
145 dcl ilin fixed bin static;/* page image line counter */
146 dcl just_line char 1020 var; /* the justified line */
147 dcl lineinfoptr ptr; /* -> info structure for image line */
148 dcl line_window_size /* # of window lines per output line */
149 fixed bin;
150 dcl Lmarg fixed bin 31; /* left margin */
151 dcl loctxt char 1020 var; /* max rev leading allowed */
152 dcl long_sw bit 1;
153 dcl max_level fixed bin;
154 dcl max_revlead fixed bin 31 static;
155 dcl font_media 36 fixed bin; /* media needed by the fonts */
156 dcl media_size fixed bin 31; /* point size in media */
157 dcl medselstr char 32 var; /* emitted medsel string */
158 dcl need_font fixed bin; /* needed font */
159 dcl need_devfnt fixed bin; /* device font for needed font */
160 dcl need_size fixed bin 31; /* needed size */
161 dcl NULs char 4 var static options constant init "^@^@^@^@";
162 dcl pref_sw bit 1; /* effective preface switch */
163 dcl quad bit 6; /* alignment flags */
164 dcl runout fixed bin; /* # NLs for page runout */
165 dcl SHIFT_OP bit 1 static options constant init "0"b;
166 /* device status info */
167 dcl stat_blk 100 fixed bin 35 static init 100 0;
168 /* The developer of a device writer */
169 /* may use this block by defining a */
170 /* based overlay to hold any */
171 /* necessary device status info. */
172 /* Note that the first word is */
173 /* initialized to -1 for each page, */
174 /* thus any overlay should keep it */
175 /* fixed bin 35 and assure that */
176 /* all special device modes are */
177 /* reset at the end of each page. */
178 dcl text_sw bit 1;
179 dcl text_width fixed bin 31; /* local text width */
180 dcl tchr char 1; /* local text char */
181 dcl THIN_width fixed bin 31; /* width of THIN */
182 dcl tstr_ptr ptr; /* text string */
183 dcl 1 tstr aligned based tstr_ptr,
184 2 open bit 1 unal, /* line has something */
185 2 white bit 1 unal, /* line is white */
186 2 MBZ bit 16 unal,
187 2 devfnt fixed bin unal, /* starting device font for line */
188 2 last_cr fixed bin unal, /* position of last CR or NL */
189 2 font fixed bin unal, /* font being processed */
190 2 xpos fixed bin 31, /* X position */
191 2 ypos fixed bin 31, /* Y position */
192 2 w fixed bin 31, /* width of str */
193 2 str_ptr ptr;
194 dcl tstr_line char 2048 var based tstr.str_ptr;
195 dcl txtlen fixed bin; /* length of txtstr */
196 dcl unstart fixed bin 31; /* start of underscore */
197 dcl unstring bit 1 static; /* underscoring is active */
198 dcl VECTOR_OP bit 1 static options constant init "1"b;
199 dcl window_area_ptr /* points to current window area seg */
200 ptr static init null;
201 dcl window_bottom fixed bin static init 0;
202 dcl window_level fixed bin;
203 dcl window_ptr ptr static init null;
204 dcl 1 window window_top:window_bottom aligned like tstr
205 based window_ptr;
206 dcl window_top fixed bin static init 0;
207 dcl word char 4090 var; /* word accumulator */
208 dcl wrdwidth fixed bin 31; /* word width in MPTS */
209 dcl Xmov fixed bin 31; /* horizontal CTL movement */
210 dcl Xmptstrk fixed bin 31; /* horizontal mpt -> stroke conv */
211 dcl Xpixel fixed bin 31; /* horizontal pixel size */
212 dcl Xpos fixed bin 31; /* current horizontal position */
213 dcl Xspc fixed bin 31; /* horizontal movement */
214 dcl Xmpts fixed bin 31; /* temp horiz value */
215 dcl Yinit fixed bin 31; /* initial page depth */
216 dcl Ymov fixed bin 31; /* vertical CTL movement */
217 dcl Ypixel fixed bin 31; /* vertical pixel size */
218 dcl Ypos fixed bin 31; /* current vertical position */
219 dcl Yspc fixed bin 31; /* vertical movement */
220 dcl Ympts fixed bin 31; /* temp vert value */
221
222 dcl addr bin divide fixed index length max min mod null pointer
223 size string substr unspec
224 builtin;
225 dcl cleanup comp_abort null_font_char overlength_line zero_font_index
226 condition;
227
228 dcl error_table_$fatal_error
229 fixed bin 35 ext static;
230 dcl error_table_$unimplemented_version
231 fixed bin 35 ext static;
232 dcl comp_error_table_$limitation
233 fixed bin 35 ext static;
234 dcl comp_error_table_$program_error
235 fixed bin 35 ext static;
236
237 dcl ioa_$rs entry options variable;
238 dcl ioa_$rsnnl entry options variable;
239 dcl translator_temp_$get_segment
240 entry char * aligned ptr fixed bin 35;
241 dcl translator_temp_$release_all_segments
242 entry ptr fixed bin 35;
243 /**** &&dcls FOR &device */
244 &dcls&+
245 /**** END &device */
246 %page;
247 code = 0; /* clear error code */
248
249 if func = 3 /* clean up */
250 then
251 do;
252 /**** &&cleanup FOR &device */
253 &cleanup&+
254 /**** END &device */
255 return;
256 end;
257
258 if func = 1 /* new page */
259 then
260 do;
261 init:
262 entry; /* called by pco */
263 stat_blk * = 0;
264 stat_blk 1 = -1;
265 dev_stat_ptr = addr stat_blk;
266 return;
267 end;
268
269 if func = 2 /* new input file */
270 then
271 do;
272 myself: /* check structure versions */
273 const.outproc_ptr = codeptr myself;
274 if shared.version ^= shared_version
275 | option.version ^= option_version | page.version ^= page_version
276 | comp_dvid.version ^= comp_dvid_version
277 then
278 do;
279 code = error_table_$unimplemented_version;
280 if db_sw
281 then
282 do;
283 call ioa_ " shared.version=^i" shared.version;
284 call ioa_ " shared_version=^i" shared_version;
285 call ioa_ " option.version=^i" option.version;
286 call ioa_ " option_version=^i" option_version;
287 call ioa_ " page.version=^i" page.version;
288 call ioa_ " page_version=^i" page_version;
289 call ioa_ " dvid.version=^i" comp_dvid.version;
290 call ioa_ " dvid_version=^i" comp_dvid_version;
291 end;
292 return;
293 end;
294
295 bad_chrs = "";
296 unstring = "0"b;
297 first_page = "1"b;
298 /**** &&file_init FOR &device */
299 &file_init&+
300 /**** END &device */
301 return;
302 end; /**/
303 /* set debug switches */
304 debug_sw, detail_sw, long_sw, pref_sw, text_sw = "0"b;
305 debug_sw = shared.bug_mode | db_sw;
306 detail_sw = debug_sw && dt_sw;
307 long_sw = debug_sw && lg_sw;
308 text_sw = debug_sw && tx_sw;
309 pref_sw = debug_sw && pf_sw;
310
311 if func = 4 /* prepare epilogue */
312 then
313 do;
314 page_record_ptr = addr page_image.text_ptr -> record.page_record;
315 unspec page_record = "0"b;
316 /**** &&epilogue FOR &device */
317 &epilogue&+
318 /**** END &device */
319 return;
320 end;
321
322 /* func = 0 build page */
323 line_window_size = divide 12000 comp_dvt.min_lead 17 0;
324 window_top = -line_window_size;
325 window_bottom = divide page.parms.length comp_dvt.min_lead 17 0;
326
327 if debug_sw
328 then call
329 ioa_ "&device&._writer_^a: pag=^a lct=^d lvl=^d:^d"
330 option.device page.hdr.pageno page_image.count window_top
331 window_bottom;
332
333 if page_image.count = 0
334 then
335 do;
336 call
337 comp_report_ 4 0 "No output lines on page " || page.hdr.pageno
338 addr ctl.info "";
339 return;
340 end;
341
342 on cleanup call release_window; /**/
343 /* preset local stuff */
344 auto_lead, font_in, need_devfnt, media_size, font_size, Xpos, Ypos, Yinit,
345 font_media * = 0;
346 Xpixel = comp_dvt.min_WS;
347 Ypixel = comp_dvt.min_lead;
348 page_record_ptr = addr page_image.text_ptr -> record.page_record;
349 /**** &&page_init FOR &device */
350 &page_init&+
351 /**** END DEVICE &device */
352 rescan_page: /* restarting page */
353 /* get storage for output image */
354 call translator_temp_$get_segment "compose" window_area_ptr ercd;
355 if ercd ^= 0
356 then
357 do;
358 call com_err_ ercd "compose" "Defining an output window area.";
359 signal cleanup;
360 return;
361 end;
362
363 Xspc, Yspc = 0;
364
365 window_ptr = allocate window_area_ptr
366 window_bottom - window_top + 1 * size tstr;
367 unspec window = "0"b;
368 window.str_ptr = null;
369 unspec page_record = "0"b;
370 first_line = "1"b;
371 window_level, max_level = 0;
372 tstr_ptr = addr window 0;
373 if tstr.str_ptr = null
374 then tstr.str_ptr = allocate window_area_ptr 1024;
375 tstr_line = "";
376 tstr.devfnt = 0;
377 &if &index -diablo- "-&devclass-" ^= 0 &then&.
378 if pref_sw
379 then call ioa_ "^5xpreface";
380 &fi&.
381 /**** &&image_init FOR &device */
382 &image_init
383 /**** END &device */
384 if debug_sw
385 then call
386 ioa_ ":iln fn/ln ch/gp lmarg rmarg width depth"
387 || " lead s med fnt sz";
388 %page;
389 image_loop:
390 do ilin = 1 to page_image.count; /* for all given image lines */
391 debug_sw, detail_sw, long_sw, text_sw = "0"b;
392 fonts_done, fonts_needed ="0"b;
393 Lmarg, col_width, text_width = 0;
394
395 if shared.bug_mode | db_sw
396 then if ilin >= db_line
397 then
398 do;
399 debug_sw = "1"b;
400 if dt_sw
401 then detail_sw = "1"b;
402 else detail_sw = "0"b;
403 if lg_sw
404 then long_sw = "1"b;
405 else long_sw = "0"b;
406 if tx_sw
407 then text_sw = "1"b;
408 else text_sw = "0"b;
409 end; /**/
410 /* set text pointer */
411 txtstrptr = page_image.line ilin.ptr;
412 loctxt = txtstr; /* copy txtstr */
413 txtlen = length txtstr; /* and record length */
414
415 trim_font: /* trim trailing font change */
416 if txtlen > 7
417 then if substr loctxt txtlen - 7 2 = "^QÀ"
418 then
419 do;
420 txtlen = txtlen - 8;
421 goto trim_font;
422 end;
423
424 lineinfoptr = addr page_image.line ilin.info;
425 quad = page_image.line ilin.quad;
426
427 if debug_sw
428 then call blat;
429
430 Yspc = divide page_image.line ilin.depth Ypixel 31 0 - Ypos - Yinit;
431 if ilin > 1
432 then Yspc = Yspc - auto_lead; /* account for the "free" amount */
433
434 need_font = page_image.line ilin.lfnt;
435 need_size = page_image.line ilin.lsize;
436
437 if txtlen > 0
438 then
439 do;
440
441 if font_in ^= need_font
442 then call set_font need_font need_size;
443
444 if page_image.line ilin.lmarg > 0
445 then Lmarg = divide page_image.line ilin.lmarg Xmptstrk 31 0;
446 if page_image.line ilin.net > 0
447 then col_width = divide page_image.line ilin.net Xmptstrk 31 0;
448 if page_image.line ilin.width > 0
449 then text_width = divide page_image.line ilin.width Xmptstrk 31 0;
450 /**** &&line_init FOR &device */
451 &line_init&+
452 /**** END &device */
453 if quad = quadr | quad = quadc
454 then /* if setting right */
455 do; /* or center */
456 Xspc = col_width - text_width;
457 if quad = quadc /* if centering, take half */
458 then Xspc = round divide max Xspc 0 2 31 1 0;
459 Lmarg = Lmarg + Xspc;
460 end; /**/
461 /* if justifying and device doesnt */
462 if quad = just && ^comp_dvt.justifying
463 /* and there are some gaps */
464 && page_image.line ilin.gaps > 0
465 then call pad_block;
466
467 rescan_line:
468 if detail_sw
469 then call
470 ioa_ "^5xrescan_line: Lmarg=^f lvl=^d"
471 show Lmarg * Xmptstrk 12000 window_level;
472
473 word = ""; /* clear word accumulator */
474 wrdwidth = 0;
475
476 if Yspc ^= 0
477 then call plot SHIFT_OP 0 Ypos + Yspc;
478 Yspc = 0; /* initial movement */
479 Xspc = Lmarg - Xpos;
480
481 if font_in ^= page_image.line ilin.lfnt
482 | font_size ^= page_image.line ilin.lsize
483 then call set_font page_image.line ilin.lfnt
484 page_image.line ilin.lsize;
485
486 char_loop: /* process each character */
487 do ichr = 1 to txtlen;
488 tchr = substr loctxt ichr 1;
489
490 if tchr ^= DC1 /* do any font chars */
491 then
492 font_char:
493 do;
494 char_ndx = rank tchr; /* fnttbl index for text char */
495 /* -> replacement */
496 repl_str_ptr = fnttbl.replptr char_ndx;
497 /* if there's no replacement */
498 if repl_str_ptr = null
499 then
500 do; /* if not already reported */
501 if index bad_chrs tchr = 0
502 then
503 do; /* add to bad chars and report */
504 bad_chrs = bad_chrs || tchr;
505 call
506 comp_report_$ctlstr 2
507 comp_error_table_$program_error lineinfoptr loctxt
508 "Font ^a no replacement for ""^a"" \^.3b"
509 fnttbl.entry.name tchr unspec tchr;
510
511 if abrt_sw /* abort if desired */
512 then signal null_font_char;
513 end;
514 goto end_chars; /* skip rest of line */
515 end; /**/
516 /* copy fnttbl data */
517 fcdevfnt = fnttbl.devfnt char_ndx;
518 /* white space? */
519 if fnttbl.white char_ndx
520 then
521 do;
522 if word ^= "" /* flush current word */
523 then
524 do;
525 call put_str word wrdwidth;
526 wrdwidth = 0;
527 tstr.white = "0"b;
528 end;
529
530 fcwidth = fnttbl.units char_ndx;
531 Xspc = Xspc + fcwidth;
532
533 if text_sw && ^pref_sw
534 then call ioa_ "^5xtext: ^d ^i ^f ^f ""^1a"" WS"
535 fcdevfnt fcwidth
536 show fcwidth * Xmptstrk 12000
537 show Xpos + Xspc * Xmptstrk 12000
538 comp_util_$display tchr 0 "0"b;
539 end; /**/
540 &if &index -diablo-bitmap- "-&devclass-" ^= 0 &then
541 &. /* if cant put char */
542 else if fcdevfnt ^= tstr.devfnt && tstr.devfnt ^= 0
543 then
544 do;
545 if word ^= "" /* flush current word */
546 then
547 do;
548 call put_str word wrdwidth;
549 wrdwidth = 0;
550 tstr.white = "0"b;
551 end; /**/
552 /* ..treat like whitespace */
553 fcwidth = fnttbl.units char_ndx;
554 Xspc = Xspc + fcwidth;
555
556 if text_sw && ^pref_sw
557 then call ioa_ "^5xtext: ^d ^i ^f ^f ""^a"" ^^font"
558 fcdevfnt fcwidth
559 show fcwidth * Xmptstrk 12000
560 show Xpos + Xspc + wrdwidth * Xmptstrk
561 12000 comp_util_$display tchr 0 "0"b;
562 end;
563 &fi&.
564 else /* not white space */
565 do; /* emit any accumulated motion */
566 if Yspc ^= 0 | Xspc ^= 0 && txtlen ^= 0
567 then call plot SHIFT_OP Xpos + Xspc Ypos + Yspc;
568 Xspc, Yspc = 0;
569 &if &devclass = diablo &then&+
570 &. /* any PLOTs or unPLOTs? */
571 if index replstr PLOT > 0
572 | index replstr unPLOT > 0
573 then
574 do;
575 i = 1; /* beginning of repl string */
576 /* if it doesnt start with unPLOT */
577
578 /* if index replstr unPLOT ^= 1
579 /* then if dev_stat.plotting
580 /* then
581 /* do;
582 /* call put_str unPLOT 0;
583 /* dev_stat.plotting = "0"b;
584 /* end;
585 /* else; /**/
586 /* /* scan the replstr */
587 do while i <= repl_str.len;
588 j = index substr replstr i PLOT;
589 if j > 0 /* found a PLOT */
590 then
591 do; /* enter PLOT mode */
592 dev_stat.plotting = "1"b;
593 i = i + j + PLOTlen - 1;
594 j = 0;
595 end;
596
597 else /* no PLOT, look for unPLOT */
598 do;
599 j = index substr replstr i unPLOT;
600 if j > 0 /* found an unPLOT */
601 then
602 do; /* leave PLOT mode */
603 dev_stat.plotting = "0"b;
604 i = i + j + unPLOTlen - 1;
605 j = 0;
606 end; /**/
607 /* neither, exit loop */
608 else i = repl_str.len + 1;
609 end;
610 end;
611 end;
612 &fi
613 if tstr.devfnt = 0
614 then call set_media font_in fcdevfnt;
615 /**** &&process_text FOR &device */
616 &process_text
617 /**** END &device */
618 word = word || replstr;
619 fcwidth = fnttbl.units char_ndx;
620 wrdwidth = wrdwidth + fcwidth;
621
622 if text_sw && ^pref_sw
623 then call ioa_ "^5xtext: ^d ^i ^f ^f ""^a"" -> ""^a^va"""
624 fcdevfnt fcwidth
625 show fcwidth * Xmptstrk 12000
626 show Xpos + Xspc + wrdwidth * Xmptstrk
627 12000 comp_util_$display tchr 0 "0"b
628 comp_util_$display replstr 0 "0"b
629 repl_str.len - length rtrim replstr
630 " ";
631 end;
632 end font_char;
633
634 else
635 ctl_char:
636 do; /* its a DC1 control string */
637 if word ^= "" /* flush current word */
638 then
639 do;
640 call put_str word wrdwidth;
641 wrdwidth = 0;
642 tstr.white = "0"b;
643 end;
644
645 DCxx_p = /* set control string overlay ptr */
646 addr substr loctxt ichr 1;
647 /* for device/writer controls */
648 if dcxx.ctl.type = "000"b
649 then
650 do;
651 nostrg: if long_sw
652 then call
653 ioa_ "^5xCTL: ^wait^^unstrt^^unstop^"
654 || " ^a^ Xpos=^f^;^s^" dcfs.type = type_wait
655 dcfs.type = type_unstart
656 dcfs.type = type_unstop
657 comp_util_$display
658 substr loctxt ichr dcxx.leng + 3 0 "0"b
659 dcfs.type = type_unstart
660 | dcfs.type = type_unstop
661 show Xpos + Xspc * Xmptstrk 12000;
662 &if &index -bitmap- "-&devclass-" = 0 &then
663 /* a midpage wait? */
664 if dcfs.type = type_wait
665 then
666 do; /* any accumulated motion? */
667 if Xspc ^= 0
668 then call plot SHIFT_OP Xpos + Xspc Ypos;
669 Xspc = 0; /**/
670 /* user will give NL */
671 Yspc = Yspc - divide 12000 Ypixel 31 0;
672 page_record.halt4 = "1"b;
673 page_record.nextref = "0"b;
674 page_record_ptr = addr page_record.nextref;
675 page_record.leng, tstr.last_cr = 0;
676 unspec page_record.sws = "0"b;
677 page_record.in_use = "1"b;
678 &if &devclass = diablo &then
679 page_record.pwheel = need_wheel;
680 &fi&+
681 end; /**/
682 &fi&+
683 /* start underscore? */
684 if dcfs.type = type_unstart
685 then
686 do;
687 unstart = max Xpos + Xspc Lmarg;
688 unstring = "1"b;
689 end; /**/
690 /* stop underscore? */
691 if dcfs.type = type_unstop
692 then
693 do; /* underscoring active? */
694 if unstring && tstr_line ^= ""
695 &&
696 ^page_image.line ilin.cbar
697 | page_image.line ilin.mrgtxt
698 then
699 do;
700 call put_uns;
701 unstring = "0"b;
702 end;
703 end;
704 end; /**/
705 /* a font change? */
706 else if dcfs.type = type_font
707 then
708 do;
709 if long_sw
710 then
711 do;
712 nostrg: debug_str = substr loctxt ichr dcxx.leng + 3;
713 call ioa_ "^5xCTL: font ^a"
714 comp_util_$display debug_str 0 "0"b;
715 end;
716
717 need_font = dcfs.f;
718 need_size = dcfs.p;
719 call set_font need_font need_size;
720 end; /**/
721 /* a literal? */
722 else if dcfs.type = type_lit
723 then
724 do;
725 call put_str substr loctxt ichr + 3 dcxx.leng 0;
726
727 if long_sw
728 then
729 do;
730 nostrg: debug_str = substr loctxt ichr dcxx.leng + 3;
731 call ioa_ "^5xCTL: literal ^a"
732 comp_util_$display debug_str 0 "0"b;
733 end;
734 end;
735
736 else /* its either a shift or a vector */
737 do; /* fetch a short X */
738 if dcxx.Xctl = "01"b
739 then Xmpts = dcshort_val.v1;
740 /* fetch a long X */
741 else if dcxx.Xctl = "10"b
742 then Xmpts = dclong_val.v1;
743 else Xmpts = 0; /* no X movement */
744
745 if dcxx.Xctl ^= "00"b
746 then /* if X is given */
747 do; /* then Y is in v2 */
748 /* fetch a short Y */
749 if dcxx.Yctl = "01"b
750 then Ympts = dcshort_val.v2;
751 /* fetch a long Y */
752 else if dcxx.Yctl = "10"b
753 then Ympts = dclong_val.v2;
754 else Ympts = 0;
755 end;
756
757 else /* no X was given */
758 do; /* fetch a short Y */
759 if dcxx.Yctl = "01"b
760 then Ympts = dcshort_val.v1;
761 /* fetch a long Y */
762 else if dcxx.Yctl = "10"b
763 then Ympts = dclong_val.v1;
764 else Ympts = 0;
765 end; /**/
766 /* shift */
767 if dcxx.type = "100"b
768 then
769 do;
770 if font_in = 0
771 then call set_font need_font need_size;
772
773 Xmov = sign Xmpts
774 *
775 round divide abs Xmpts - 4 Xmptstrk 31 1 0;
776 Xspc = Xspc + Xmov;
777
778 Ymov = sign Ympts
779 *
780 divide abs Ympts Ypixel 17 0;
781 Yspc = Yspc + Ymov;
782
783 if long_sw
784 then
785 do;
786 nostrg: debug_str = substr loctxt ichr dcxx.leng + 3;
787 call ioa_ "^5xCTL: shift ^f ^f ^f ^f ^a"
788 show Xmpts 12000 show Ympts 12000
789 show Xspc * Xmptstrk 12000 show Yspc12000
790 comp_util_$display debug_str 0 "0"b;
791 end;
792 end;
793
794 else
795 do; /* not shift, it must be vector */
796 if Xspc ^= 0 | Xmpts > 0
797 then if font_in ^= need_font | font_size ^= need_size
798 then call set_font need_font need_size;
799 /* need to position first? */
800 if Xspc ^= 0 | Yspc ^= 0
801 then call plot SHIFT_OP Xpos + Xspc Ypos + Yspc;
802 Xspc, Yspc = 0;
803
804 Xspc = divide Xmpts Xmptstrk 31 0;
805 Yspc = divide Ympts Ypixel 31 0;
806
807 if long_sw
808 then
809 do;
810 nostrg: debug_str = substr loctxt ichr dcxx.leng + 3;
811 call ioa_ "^5xCTL: vector ^f ^f ^a"
812 show Xmpts 12000 show Ympts 12000
813 comp_util_$display debug_str 0 "0"b;
814 end;
815 call plot VECTOR_OP Xpos + Xspc Ypos + Yspc;
816 Xspc, Yspc = 0;
817 end;
818 end; /**/
819 /* move to last ctl char */
820 ichr = ichr + dcxx.leng + 2;
821 end ctl_char; /* end of control sequence loop */
822 end_chars:
823 end char_loop;
824
825 if word ^= "" /* flush last word */
826 then
827 do;
828 call put_str word wrdwidth;
829 wrdwidth = 0;
830 tstr.white = "0"b;
831 end;
832
833 if unstring /* underscoring active? */
834 && ^page_image.line ilin.cbar | page_image.line ilin.mrgtxt
835 then call put_uns;
836 /**** &&line_finish FOR &device */
837 &line_finish
838 /**** END &device */
839 if detail_sw
840 then
841 do;
842 call ioa_ "^5xline_finish: tstr lvl=^d ^^^^opn Y=^f X=^f ln=^d"
843 window_level ^tstr.open show Ypos * Ypixel 12000
844 show Xpos * Xmptstrk 12000 length tstr_line;
845 if tstr.open
846 then call ioa_ """^a^va"""
847 comp_util_$display rtrim tstr_line 0 "0"b
848 length tstr_line - length rtrim tstr_line " ";
849 end;
850 end;
851
852 end image_loop;
853
854 finish_page:
855 if detail_sw
856 then call ioa_ "^5xfinish_page:";
857 /* add any trailing lead */
858 if page_image.line page_image.count.white
859 then call plot SHIFT_OP 0 Ypos +
860 divide page_image.line page_image.count.lead Ypixel 31 0;
861 call put_; /* flush output image */
862
863 call release_window; /* discard image just put */
864
865 if ^option.galley_opt
866 then
867 do;
868 if comp_dvt.endpage ^= "0"b /* if FF is defined, then */
869 then /* replace last NL with it */
870 substr page_record.text page_record.leng 1 =
871 byte bin comp_dvt.endpage;
872 /* else run out the page with NLs */
873 else if Ypos < divide page.parms.length Ypixel 31 0
874 then
875 do;
876 runout = divide page.parms.length 12000 31 0 - 1 -
877 divide Ypos line_window_size 31 0 - bin option.stop_opt;
878 page_record.leng = page_record.leng + runout;
879 substr page_record.text page_record.leng - runout + 1
880 runout = copy NL runout;
881 end; /**/
882 /**** &&page_finish FOR &device */
883 &page_finish
884 /**** END &device */
885 end;
886
887 page_record.nextref = "0"b; /* show nothing follows */
888
889 return_:
890 if debug_sw
891 then call ioa_ " &device&._writer_";
892 return;
893 %page;
894 footproc:
895 entry footref ptr;
896
897 /* PARAMETERS */
898 /* actual reference string */
899 dcl footref 3 char * var;
900 dcl ptr ptr; /* -> comp_dvt */
901 /* &&foot_proc for &device */
902 &foot_proc&+
903
904 if shared.bug_mode | db_sw
905 then do;
906 call ioa_ "&device&._writer_$footproc: ^a"
907 comp_util_$display footref 1 || footref 2 || footref 3 0
908 "0"b;
909 end;
910 return;
911
912 %page;
913 /* This routine returns a printable interpretation of a native device string */
914
915 dcl &device&._writer_$display entry char * var fixed bin 24
916 bit 1 returns char * var;
917
918 display:
919 entry dtext dlen noerr returns char * var;
920
921 /* PARAMETERS */
922
923 dcl dtext char * var; /* string to be displayed */
924 dcl dlen fixed bin 24; /* chars scanned by this call */
925 dcl noerr bit 1; /* 1= dont print error messages */
926
927 /* LOCAL STORAGE */
928
929 dcl ch char 1; /* extracted text char */
930 dcl ct fixed bin; /* number of duplicate chars */
931 dcl dstr char 1020 var; /* working string */
932 dcl rtn_str char 16384 var;/* return string */
933
934 if dev_stat_ptr = null
935 then dev_stat_ptr = addr stat_blk;
936
937 if stat_blk 1 ^= -1 /* check status block */
938 then
939 do;
940 stat_blk * = 0;
941 stat_blk 1 = -1;
942 end;
943
944 rtn_str = ""; /* clear return string */
945 ct = 0;
946 &if &devclass = diablo &then&.
947 if dev_stat.plotting
948 then goto device_display;
949 &fi&.
950 ch = substr dtext 1 1; /* extract a char */
951
952 if ch = THIN
953 then
954 do;
955 ct = verify dtext THIN; /* how many? */
956 if ct = 0 /* all the rest */
957 then ct = length dtext;
958 else ct = ct - 1;
959
960 if ct > 1 /* if more than one */
961 then call ioa_$rsnnl "<THN*^d>" dstr 0 ct;
962 else dstr = "<THN>";
963
964 rtn_str = rtn_str || dstr;
965 end;
966
967 else if ch = DEVIT
968 then do;
969 ct = verify dtext DEVIT; /* how many? */
970 if ct = 0 /* all the rest */
971 then ct = length dtext;
972 else ct = ct - 1;
973
974 if ct > 1 /* if more than one */
975 then call ioa_$rsnnl "<DVT*^d>" dstr 0 ct;
976 else dstr = "<DVT>";
977
978 rtn_str = rtn_str || dstr;
979 end;
980
981 else
982 do;
983 device_display: /* &&display FOR DEVICE &device */
984 &display /**/
985 /* END DEVICE &device */
986 end;
987
988 disp_ret:
989 dlen = ct;
990
991 return rtn_str; /* end of display */
992 %page;
993 artproc: entry ; /**/
994 /* &&art_proc for &device */
995 &art_proc&+
996 return;
997 %page;
998 blat: proc;
999
1000 dcl blatstr char 1020 var;
1001
1002 call ioa_$nnl ":^3d^3d/^d^12t^4d/^i^18t^5^8f^" ||
1003 " ^I^^O^^L^^C^^R^^J^^L^^60t^3i ^6a ^f^/^4x" ilin
1004 page_image.line ilin.fileno page_image.line ilin.lineno
1005 txtlen page_image.line ilin.gaps
1006 show page_image.line ilin.lmarg 12000
1007 show page_image.line ilin.rmarg 12000
1008 show page_image.line ilin.width 12000
1009 show page_image.line ilin.depth 12000
1010 show page_image.line ilin.lead 12000
1011 quad && quadi quad && quado quad && quadl
1012 quad && quadc quad && quadr quad && just quad = "0"b
1013 page_image.line ilin.lfnt
1014 fnttbldata.ptr page_image.line ilin.lfnt -> fnttbl.entry.name
1015 show fnttbldata.ptr page_image.line ilin.lfnt -> fnttbl.entry.size 1000
1016 txtlen;
1017
1018 blatstr = comp_util_$display substr loctxt 1 txtlen 0 "0"b;
1019 call ioa_ """^a^va""" blatstr
1020 length blatstr - length rtrim blatstr " ";
1021 end blat;
1022 %page;
1023 release_window:
1024 proc;
1025
1026 call translator_temp_$release_all_segments window_area_ptr 0;
1027
1028 end release_window;
1029 %page;
1030 move_tstr: /* move tstr ptr to new window level */
1031 proc incr;
1032
1033 /* PARAMETERS */
1034
1035 dcl incr fixed bin 31; /* amount to move */
1036
1037 if detail_sw
1038 then call ioa_ "^-move_tstr: ^d -> ^d" window_level
1039 window_level + incr;
1040
1041 window_level = window_level + incr;
1042
1043 max_level = max max_level window_level;
1044 tstr_ptr = addr window window_level;
1045
1046 tstr.ypos, Ypos = Ypos + incr;
1047 Xpos = tstr.xpos;
1048 tstr.open = "1"b;
1049
1050 if tstr.str_ptr = null
1051 then tstr.str_ptr = allocate window_area_ptr 1024;
1052
1053 end move_tstr;
1054 %page;
1055 show:
1056 proc datum scale returns fixed dec 11 3;
1057 dcl datum fixed bin 31;
1058 dcl scale fixed bin 31;
1059
1060 return round dec round divide datum scale 31 11 10 11 4 3;
1061 end show;
1062 %page;
1063 plot:
1064 proc PLOT_OP new_xpos new_ypos;
1065
1066 /* This routine moves the current position to new_xposnew_ypos, */
1067 /* plotting or shifting according to the value of PLOT_OP. */
1068
1069 /* PARAMETERS */
1070
1071 dcl PLOT_OP bit 1; /* 0-shift; 1-vector */
1072 dcl new_xpos fixed bin 31; /* needed horizontal position */
1073 dcl new_ypos fixed bin 31; /* needed vertical position */
1074
1075 /* LOCAL STORAGE */
1076
1077 dcl copystr char 2048 var;
1078 dcl exit_str char 32 var;
1079 dcl old_xpos fixed bin 31;
1080 dcl old_ypos fixed bin 31;
1081 dcl penctl char 6 var; /* pen control string */
1082 dcl pltstr char 4090 var;
1083 dcl pltwidth fixed bin 31;
1084 dcl xii fixed bin; /* working value */
1085 dcl xmove fixed bin 31; /* X movement */
1086 dcl ymove fixed bin 31; /* Y movement */
1087
1088 if new_xpos = Xpos && new_ypos = Ypos
1089 then return;
1090
1091 xmove, ymove, pltwidth = 0;
1092 pltstr = "";
1093
1094 old_xpos = Xpos; /* case a VSFT changes Xpos */
1095 old_ypos = Ypos;
1096 xmove = new_xpos - Xpos;
1097 ymove = new_ypos - Ypos;
1098
1099 if detail_sw
1100 then call
1101 ioa_ "^5xplot: ^V^;S^ ^f/^f -> ^f/^f = ^f/^f" PLOT_OP
1102 show Xpos * Xmptstrk 12000 show Ypos * Ypixel 12000
1103 show new_xpos * Xmptstrk 12000 show new_ypos * Ypixel 12000
1104 show xmove * Xmptstrk 12000 show ymove * Ypixel 12000;
1105
1106 if ^PLOT_OP /* if a SHIFT is wanted */
1107 then
1108 do;
1109 if ymove ^= 0 /* any Y movement? */
1110 then
1111 do;
1112 if window_level + ymove < window_top |
1113 window_level + ymove > window_bottom
1114 then
1115 do;
1116 call comp_report_$ctlstr 2 comp_error_table_$program_error
1117 lineinfoptr loctxt
1118 "Attempt to place a line off page ^a at line ^d."
1119 page.hdr.pageno window_level;
1120 signal comp_abort;
1121 end;
1122
1123 call move_tstr ymove;
1124 ymove = 0;
1125 xmove = new_xpos - Xpos;
1126 end;
1127
1128 penctl = PENUP; /* init for pen up */
1129 end; /**/
1130 /* else a VECTOR is wanted */
1131 else penctl = PENDOWN; /* init for pen down */
1132 /**** &&plot FOR &device */
1133 &plot&+
1134 /**** END &device */
1135
1136 plot_return:
1137 if length pltstr > 0
1138 then call put_str pltstr pltwidth;
1139
1140 /* Xpos, tstr.xpos = new_xpos;*/
1141
1142 if detail_sw
1143 then call
1144 ioa_ "^-plot: ^f/^f lvl=^d ^^^^opn^ W^"
1145 show Xpos * Xmptstrk 12000 show Ypos * Ypixel 12000
1146 window_level ^tstr.open tstr.white;
1147
1148 /* Xplt, Yplt = 0; /* motion used */
1149 end plot;
1150 &if &justifying = no &then
1151 %page;
1152 pad_block:
1153 proc; /**/
1154
1155 /* these two values in fixed dec so round off doesnt affect pad placement. */
1156 /* dcl
1157 /* igap /* gap counter for padding */
1158 /* padeach /* padding interval */
1159 /* fixed dec 11 3;*/
1160
1161 dcl
1162 igap /* gap counter for padding */
1163 padeach /* padding interval */
1164 fixed bin;
1165
1166 dcl gaps fixed bin; /* gap count for line */
1167 dcl jl_ptr ptr; /* pointer to the justified line */
1168 dcl just_line char 1020 var;
1169 /* pads per gap */
1170 dcl pads page_image.line ilin.gaps fixed bin;
1171 dcl padsize fixed bin; /* pad space in pixels */
1172 dcl 1 pad_ctl like dclong_val; /* for inserting pads */
1173 dcl pad_ctl_ptr ptr;
1174 dcl pad_string char 7 based pad_ctl_ptr;
1175 dcl SP_DC1 char 2 int static options constant init " ^Q";
1176
1177 just_line = ""; /* clear the justified line */
1178 jl_ptr = addr just_line; /* and set pointer for the overlay */
1179
1180 if font_in ^= need_font
1181 then call set_font need_font need_size;
1182
1183 if col_width < 0
1184 then col_width = divide page_image.line ilin.net Xmptstrk 31 0;
1185 if text_width > 0
1186 then text_width = divide page_image.line ilin.width Xmptstrk 31 0;
1187
1188 if Xpixel ^= EN_width /* set up pad_ctl string */
1189 then
1190 do;
1191 pad_ctl.mark = DC1;
1192 pad_ctl.type = type_slx;
1193 pad_ctl.leng = dclong1_len;
1194 pad_ctl.v2 = 0;
1195 pad_ctl_ptr = addr pad_ctl;
1196 end;
1197
1198 gaps = page_image.line ilin.gaps;
1199 padsize = max 0 col_width - text_width;
1200 /* fill in common amount */
1201 pads = fnttbl.units rank STROKE * divide
1202 divide padsize gaps 17 0 fnttbl.units rank STROKE 17 0;
1203 /* then get the leftover amount */
1204 padsize = padsize - pads 1 * gaps;
1205
1206 if long_sw
1207 then call
1208 ioa_$nnl "^5xpad_block: l/w/r=^f/^f/^f gp=^i pd=^i+^i"
1209 show Lmarg * Xmptstrk 12000
1210 show text_width * Xmptstrk 12000
1211 show page_image.line ilin.rmarg 12000 gaps
1212 pads 1 padsize;
1213
1214 do while padsize > 0; /* use up any leftovers */
1215 padeach = /* pad interval */
1216 max round divide gaps * fnttbl.units rank STROKE padsize 17 1 0 1;
1217 igap = max round divide gaps * fnttbl.units rank STROKE 2 * padsize 17 1 0 1;
1218
1219 do igap = igap to gaps by padeach while padsize > 0;
1220 pads igap = pads igap + fnttbl.units rank STROKE;
1221 padsize = padsize - fnttbl.units rank STROKE;
1222 end;
1223 end;
1224
1225 if long_sw
1226 then call ioa_ "^^i^" pads;
1227
1228 ichr = verify loctxt " "; /* start at front of text */
1229 if ichr > 1
1230 then just_line = just_line || copy EN ichr - 1;
1231
1232 do j = 1 to gaps;
1233 try_again: /* find word boundary */
1234 k = search substr loctxt ichr txtlen - ichr + 1 SP_DC1 - 1;
1235
1236 if k < 0 /* MGOD! gap count is too large */
1237 then
1238 do;
1239 if detail_sw
1240 then
1241 do;
1242 call ioa_$nnl "gap=^i " gaps;
1243 call blat;
1244 end;
1245 goto gap_exit;
1246 end; /**/
1247 /* copy word */
1248 just_line = just_line || substr loctxt ichr k;
1249 ichr = ichr + k; /* step over "word" */
1250 /* did we find a control? */
1251 if substr loctxt ichr 1 = DC1
1252 then
1253 do; /* set pointer */
1254 DCxx_p = addr substr loctxt ichr;
1255 k = dcxx.leng + 3; /* and control string length */
1256 /* copy ctl str */
1257 just_line = just_line || substr loctxt ichr k;
1258 ichr = ichr + k;
1259 goto try_again;
1260 end;
1261
1262 ichr = ichr + 1; /* skip the wordspace */
1263
1264 if Xpixel = EN_width /* now, any excess count */
1265 then just_line = just_line || copy " " pads j;
1266 else
1267 do;
1268 pad_ctl.v1 = pads j * Xmptstrk;
1269 just_line = just_line || pad_string;
1270 end;
1271 end;
1272
1273 gap_exit:
1274 k = txtlen - ichr + 1; /* length of the last word */
1275 /* move the last word */
1276 just_line = just_line || substr loctxt ichr k;
1277 loctxt = just_line; /* switch to the justified line */
1278 txtlen = length just_line;
1279
1280 if long_sw
1281 then call ioa_ "^a" comp_util_$display just_line 0 "0"b;
1282
1283 end pad_block;
1284 &fi
1285 %page;
1286 put_:
1287 proc;
1288
1289 dcl level fixed bin;
1290 dcl level_skip fixed bin;
1291
1292 if detail_sw
1293 then call
1294 ioa_ "^5xput: maxlvl=^d" max_level;
1295
1296 level_skip = 0;
1297
1298 if first_line
1299 then
1300 do level = window_top to -1 /* discard leading null lines */
1301 while ^window level.open;
1302 end;
1303 else level = window_top;
1304 &if &devclass = diablo &then
1305
1306 dev_stat.plotting = "0"b;
1307 &fi&.
1308 do level = level to max_level;
1309 tstr_ptr = addr window level; /**/
1310
1311 if tstr.str_ptr = null
1312 then
1313 do;
1314 tstr.str_ptr = allocate window_area_ptr 1024;
1315 tstr_line = "";
1316 end; /**/
1317 /* &&put FOR DEVICE &device */
1318 &put /**/
1319 /* END DEVICE &device */
1320 if detail_sw
1321 then call
1322 ioa_ "^7xlvl=^d ^d+^d=^d ""^a""" level page_record.leng
1323 length tstr_line page_record.leng + length tstr_line
1324 comp_util_$display tstr_line 0 "0"b;
1325
1326 level = level + level_skip;
1327 tstr.last_cr = 0;
1328 page_record.leng = page_record.leng + length tstr_line;
1329 substr page_record.text page_record.leng - length tstr_line + 1
1330 length tstr_line = tstr_line;
1331 end;
1332
1333 if page_record.leng > 0
1334 then page_record.in_use = "1"b;
1335 Ypos = tstr.ypos;
1336
1337 end put_;
1338 %page;
1339 put_str:
1340 proc string width;
1341
1342 dcl string char 4090 var; /* string to put */
1343 dcl width fixed bin 31; /* string width */
1344
1345 dcl i j fixed bin;
1346 dcl new_len fixed bin;
1347 dcl old_len fixed bin;
1348 dcl pos fixed bin 31; /* current position */
1349
1350 if tstr.devfnt ^= need_devfnt
1351 then call set_media font_in need_devfnt;
1352
1353 old_len = length tstr_line - tstr.last_cr;
1354 new_len = old_len + length string;
1355
1356 &if &devclass = bitmap &then
1357 if new_len > MAX_STR && substr string length string 1 ^= NL
1358 &else
1359 if new_len > MAX_STR
1360 &fi&+
1361 then
1362 do;
1363 &if &devclass = bitmap &then
1364 if long_sw
1365 then
1366 do;
1367 debug_str = comp_util_$display CR || medselstr 0 "0"b;
1368 call ioa_ "^-overlay: lvl=^d X=^f^f=0 ^d+^d=^d ""^a^va"""
1369 window_level show Xpos * Xmptstrk 12000
1370 show -Xpos * Xmptstrk 12000
1371 old_len length CR || medselstr
1372 old_len + length CR || medselstr debug_str
1373 length debug_str - length rtrim debug_str " ";
1374 end;
1375
1376 tstr_line = tstr_line || CR || medselstr;
1377 tstr.last_cr = length tstr_line;
1378 Xpos = 0;
1379 call plot SHIFT_OP tstr.xpos Ypos;
1380 old_len = length tstr_line - tstr.last_cr;
1381 new_len = old_len + length string;
1382 &fi&+
1383 end;
1384 &comment &if &devclass = bitmap &then&.
1385 else if substr string length string 1 = NL
1386 then tstr.last_cr = length tstr_line;
1387
1388 &fi&+&;
1389 if detail_sw
1390 then
1391 do;
1392 debug_str = comp_util_$display string 0 "0"b;
1393 call ioa_
1394 "^5xput_str: lvl=^d X=^f+^f=^f ^d+^d=^d^^d^;^s^ ""^a^va"""
1395 window_level show Xpos * Xmptstrk 12000 show width * Xmptstrk 12000
1396 show Xpos + width * Xmptstrk 12000 old_len length string new_len
1397 tstr.last_cr > 0 length tstr_line + length string
1398 debug_str length debug_str - length rtrim debug_str " ";
1399 end;
1400
1401 tstr_line = tstr_line || string;
1402 Xpos, tstr.xpos = Xpos + width;
1403
1404 string = "";
1405 width = 0;
1406 tstr.open = "1"b;
1407 end put_str;
1408 %page;
1409 put_uns:
1410 proc;
1411 dcl Y_offs fixed bin 31; /* baseline offset */
1412 dcl unslen fixed bin 31;/* length of underscore */
1413
1414 Y_offs = 0;
1415 unslen = Xpos + Xspc - unstart;
1416
1417 if unslen > 0
1418 then
1419 do;
1420 if detail_sw
1421 then call
1422 ioa_ "^5xput_uns: ^f"
1423 show unslen * Xmptstrk 12000;
1424
1425 &if &devclass = bitmap &then&+
1426 Xspc = unstart;
1427 call put_str CR || medselstr -tstr.xpos;
1428 Xpos, tstr.xpos = 0;
1429 &else
1430 Xspc = Xspc - unslen; /* go to start */
1431 &fi&+
1432 &if &devclass = diablo &then&+
1433 Xspc = max Xspc - 3 -Xpos + Xspc;
1434 Y_offs = 3;
1435 &fi&+
1436 call plot SHIFT_OP Xpos + Xspc Ypos + Y_offs;
1437 Xspc, Yspc = 0; /**/
1438 /* put the underscore */
1439 call plot VECTOR_OP Xpos + unslen Ypos;
1440 &if &devclass = diablo &then&+
1441 call plot SHIFT_OP Xpos + 3600 Ypos - 3000;
1442 &fi&+
1443 unstart = Lmarg;
1444
1445 if detail_sw
1446 then call ioa_ "^-put_uns";
1447 end;
1448 end put_uns;
1449 %page;
1450 set_font:
1451 proc new_font new_size;
1452
1453 /* PARAMETERS */
1454
1455 dcl new_font fixed bin; /* desired font index */
1456 dcl new_size fixed bin 31; /* desired pointsize */
1457
1458 dcl chng bit 1;
1459
1460 chng = font_in ^= new_font | font_size ^= new_size;
1461
1462 if chng
1463 then
1464 do;
1465 if detail_sw
1466 then
1467 do;
1468 if font_in = 0
1469 then call ioa_$nnl "^5xset_font: 0 - 0. -->";
1470 else call
1471 ioa_$nnl "^5xset_font: ^i ^a ^f -->" font_in
1472 fnttbldata.ptr font_in -> fnttbl.entry.name
1473 show font_size 1000;
1474 end;
1475
1476 font_in = new_font;
1477 end;
1478
1479 fnttbl_ptr = fnttbldata.ptr font_in;
1480 substr fonts_needed font_in 1 = "1"b;
1481 need_devfnt = fnttbl.devfnt 32;
1482 /**** &&set_font FOR &device */
1483 &set_font
1484 /**** END &device */
1485 if siztbl.ct = 1
1486 then font_size new_size = siztbl.size 1;
1487 else font_size = new_size;
1488
1489 Xmptstrk = divide font_size fnttbl.rel_units 31 0;
1490 EM_width =
1491 divide font_size * fnttbl.units rank EM fnttbl.rel_units 31 10;
1492 EN_width =
1493 divide font_size * fnttbl.units rank EN fnttbl.rel_units 31 10;
1494 THIN_width =
1495 divide font_size * fnttbl.units rank THIN fnttbl.rel_units 31 10;
1496
1497 if detail_sw | long_sw && chng
1498 then
1499 do;
1500 call ioa_ " ^i ^a ^f Xscl=^d" new_font
1501 fnttbldata.ptr new_font -> fnttbl.entry.name
1502 show font_size 1000 Xmptstrk;
1503 if long_sw
1504 then call ioa_ "^-HUGE=^d EM=^d EN=^d THK=^d MED=^d "
1505 || "THN=^d HAIR=^d STRK=^d" fnttbl.units rank HUGE
1506 fnttbl.units rank EMfnttbl.units rank EN
1507 fnttbl.units rank THICKfnttbl.units rank MEDIUM
1508 fnttbl.units rank THINfnttbl.units rank DEVIT
1509 fnttbl.units rank STROKE;
1510 end;
1511 end set_font;
1512 %page;
1513 set_media:
1514 proc media_font new_devfnt;
1515
1516 /* PARAMETERS */
1517
1518 dcl media_font fixed bin; /* font needing the media */
1519 dcl new_devfnt fixed bin; /* wanted device font */
1520
1521 /* LOCAL STORAGE */
1522
1523 dcl chng bit 1; /* 1= media or size has to change */
1524 dcl med_chng bit 1; /* 1= media has to change */
1525 dcl size_chng bit 1; /* 1= size has to change */
1526 dcl temp_r bit 18;
1527
1528 med_chng = tstr.devfnt ^= new_devfnt;
1529 size_chng = media_size ^= font_size;
1530 chng = med_chng | size_chng;
1531
1532 if detail_sw && chng
1533 then call ioa_$nnl "^5xset_media: siz=^f med=^d --> siz=^f med=^d "
1534 show media_size 1000 tstr.devfnt show font_size 1000
1535 new_devfnt;
1536 /**** &&set_media FOR &device */
1537 &set_media
1538 /**** END &device */
1539 /**** &&set_ps FOR &device */
1540 &set_ps
1541 /**** END &device */
1542 if detail_sw && chng
1543 then call ioa_ "sel=""^a"""
1544 comp_util_$display medsel new_devfnt 0 "0"b;
1545 &if &devclass = bitmap &then&+
1546 /* is it a superior font? */
1547 if substr sup_media media_font 1
1548 then call move_tstr -1; /**/
1549 /* is it a inferior font? */
1550 else if substr inf_media media_font 1
1551 then call move_tstr 1;
1552 &fi&.
1553 /* if not in media needed */
1554 if med_chng /* ...change to it */
1555 then
1556 do;
1557 tstr.devfnt = new_devfnt;
1558 tstr.font = media_font;
1559 end;
1560 &if &devclass = bitmap &then&.
1561 if length tstr_line > 2 && med_chng
1562 then do;
1563 tstr.last_cr = length tstr_line;
1564 call put_str CR || medselstr -Xpos;
1565 end;
1566
1567 else if length tstr_line <= 2
1568 then do;
1569 tstr_line = "";
1570 tstr.last_cr = 0;
1571 call put_str medselstr 0;
1572 end;
1573
1574 if chng
1575 then Xpos tstr.xpos = 0;
1576 &fi
1577 end set_media;
1578
1579 /* device &device "other_procs" */
1580 &other_procs&+
1581
1582 dcl db_sw bit 1 aligned static init "0"b;
1583
1584 dbn: entry;db_sw = "1"b;goto db_join;
1585 dbf: entry;db_sw = "0"b;return;
1586
1587 dcl tx_sw bit 1 aligned static init "0"b;
1588 txn: entry; tx_sw = "1"b; goto db_join;
1589 txf: entry; tx_sw = "0"b; return;
1590
1591 dcl lg_sw bit 1 aligned static init "0"b;
1592 lgn: entry; lg_sw = "1"b; goto db_join;
1593 lgf: entry; lg_sw = "0"b; return;
1594
1595 dcl pf_sw bit 1 aligned static init "0"b;
1596 pfn: entry; pf_sw = "1"b; return;
1597 pff: entry; pf_sw = "0"b; return;
1598
1599 dcl abrt_sw bit 1 aligned static init "0"b;
1600 abrtn: entry; abrt_sw = "1"b; return;
1601 abrtf: entry; abrt_sw = "0"b; return;
1602
1603 dcl dt_sw bit 1 aligned static init "0"b;
1604 dtn: entry;dt_sw = "1"b;goto db_join;
1605 dtf: entry;dt_sw = "0"b;return;
1606
1607 alln: entry; db_sw dt_sw lg_sw = "1"b;
1608 db_join:
1609 dcl db_line fixed bin static init 0;
1610 dcl com_err_ entry options variable;
1611 dcl cu_$arg_ptr entry fixed bin ptr fixed bin fixed bin 35;
1612 dcl arg char argl based argp;
1613 dcl argl fixed bin;
1614 dcl argp ptr;
1615 dcl ercd fixed bin 35;
1616 dcl error_table_$noarg fixed bin 35 ext static;
1617
1618 db_line = 0;
1619 call cu_$arg_ptr 1 argp argl ercd;
1620 if ercd ^= 0
1621 then do;
1622 if ercd ^= error_table_$noarg
1623 then call com_err_ ercd "&device&._writer_";
1624 return;
1625 end;
1626 db_line = convert db_line arg;
1627 return;
1628
1629 allf: entry; db_sw lg_sw tx_sw pf_sw dt_sw abrt_sw = "0"b;
1630 return;
1631 %page;
1632 /* This one include file contains all the compose includes necessary for an */
1633 /* output writer */
1634 % include comp_outproc;
1635
1636 end &device&._writer_;
1637 &expend