1 /* ***********************************************************
2 * *
3 * *
4 * Copyright, C Honeywell Information Systems Inc., 1981 *
5 * *
6 * *
7 *********************************************************** */
8
9 /* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom */
10
11 /*++
12 INCLUDE ERROR \
13 BEGIN
14 / / PUSH BEGIN
15 call push "BEGIN" /\
16
17 \" if "dcl" or "MediaChars" appear first, take them.
18 / dcl :
19 / if db_start = "dcl" then db_sw dt_sw = "1"b;
20 if db_sw
21 then call ioa_ "^^/^===Declare" dt_sw
22 LEX2 / dcl \
23 / MediaChars :
24 / LEX2 pop
25 mediachars_p = area_free_p
26 PUSH done_MediaChars
27 call push "done_MediaChars" / MediaChars \
28 \" any of these need a MediaChars table
29 \" which may be empty, so define
30 \" a dummy table.
31 / Media / / no_MediaChars \
32 / View / / no_MediaChars \
33 / Def / / no_MediaChars \
34 / Font / / no_MediaChars \
35 / Size / / no_MediaChars \
36 / Device / / no_MediaChars \
37 / <no-token> / / no_MediaChars \
38 \" anything else here must be a
39 \" global device value. they dont need
40 \" MediaChars.
41 / / / global_device \
42
43 no_MediaChars
44 / / pop
45 call ERROR missing_MediaChars
46 mediachars_p = area_free_p;
47 mediachars.count = 1; \" supply a dummy one
48 mediachars.name 1 = "<mediachar>";
49 mediachars.out_r 1 = "0"b /\
50 \" finish the MediaChars table
51 done_MediaChars
52 / / area_free_p = addr_inc mediachars_p size mediachars /\
53
54 Media
55 / / if db_start = "media" then db_sw dt_sw = "1"b /\
56 / / media_p = area_free_p;
57 media.count = 0 /\
58 / View / / no_Media \
59 / Def / / no_Media \
60 / Font / / no_Media \
61 / Size / / no_Media \
62 / Device / / no_Media \
63 / <no-token> / / no_Media \
64 Media_
65 / /PUSH Media_call push "Media_" /\
66 / Media :
67 /LEX2 / Mwidths \
68 / View /pop / done_Media \
69 / Def /pop / done_Media \
70 / Font /pop / done_Media \
71 / Size /pop / done_Media \
72 / Device /pop / done_Media \
73 / / / global_device \
74 no_Media
75 / /call ERROR missing_Media
76 media.count = 1; \" supply a dummy one
77 media.name 1 = "<media>";
78 media.rel_units 1 = 0;
79 media.width 1 1 = 0 /\
80 done_Media
81 / / area_free_p = addr_inc media_p size media /\
82
83 start_View
84 / / if db_start = "view" then db_sw dt_sw = "1"b /\
85 / / view_p = area_free_p;
86 view.count = 0 /\
87 / Def / / no_View \
88 / Font / / no_View \
89 / Size / / no_View \
90 / Device / / no_View \
91 / <no-token> / / no_View \
92 View_
93 / /PUSH View_call push "View_" /\
94 / View :
95 /LEX2 / Viewrest \
96 / Def /pop / done_View \
97 / Font /pop / done_View \
98 / Size /pop / done_View \
99 / Device /pop / done_View \
100 / / / global_device \
101 no_View
102 / /call ERROR missing_View
103 view.count = 1; \" supply a dummy one
104 view.name 1 = "<view>";
105 view.media 1 = 1 /\
106 done_View
107 / / area_free_p = addr_inc view_p size view /\
108
109 start_Def
110 / / if db_start = "def" then db_sw dt_sw = "1"b /\
111 / / Def_p = area_free_p;
112 Def.count = 0 /\
113 / Font / / no_Def \
114 / Size / / no_Def \
115 / Device / / no_Def \
116 / <no-token> / / no_Def \
117 Def_
118 / /PUSH Def_call push "Def_" /\
119 / Def :
120 /LEX2 / Defrest \
121 / Font /pop / done_Def \
122 / Size /pop / done_Def \
123 / Device /pop / done_Def \
124 / / / global_device \
125 no_Def
126 / / Def.count = 1;
127 Def.name 1 = "<Def>";
128 Def.pt 1 = null /\
129 done_Def
130 / / area_free_p = addr_inc Def_p size Def /\
131
132 start_Font
133 / / if db_start = "font" then db_sw dt_sw = "1"b /\
134 / Size / / no_Font \
135 / Device / / no_Font \
136 / <no-token> / / no_Font \
137 Font_
138 / /PUSH Font_call push "Font_" /\
139 / Font :
140 /LEX2 / Fontrest \
141 / Size /pop / done_Font \
142 / Device /pop / done_Font \
143 / / / global_device \
144 no_Font
145 / /call ERROR missing_Font / start_Size \
146 done_Font
147 / / area_free_p = addr_inc oput_p size oput /\
148
149 start_Size
150 / / if db_start = "size" then db_sw dt_sw = "1"b /\
151 / / size_list_p = area_free_p;
152 size_list.count = 0;
153 area_free_p sizel_p = addr size_list.start /\
154 / Device / / no_Size \
155 / <no-token> / / no_Size \
156 Size
157 / /PUSH Sizecall push "Size" /\
158 / Size :
159 /LEX2 / Sizerest \
160 / Device
161 /pop / done_Size \
162 / / / global_device \
163 no_Size
164 / /call ERROR missing_Size
165 size_list.count = 1; \" supply a dummy one
166 size_list.name 1 = "<size>";
167 size_list.pt 1 = addrsize_list.start / Device \
168 done_Size
169 / / if Sizes = 0
170 then if size_list.count > 0
171 then Sizes = 1;
172
173 tp = Ptoken;
174 do fnt_p = fntl_p 1 repeat fnt.next
175 while fnt_p ^= null ;
176 Ptoken Pthis_token = fnt.node;
177 if font.min_wsp = -1
178 then call ERROR no_wordspace_val;
179 end;
180 Ptoken Pthis_token = tp /\
181
182 Device
183 / / if db_start = "dev" then db_sw dt_sw = "1"b /\
184 / / PUSH Devicecall push "Device" /\
185 / Device :
186 / Device_Pthis_token = Pthis_token
187 LEX2
188 if db_sw then
189 call ioa_ "===Device ^a" token_value / Devicerest \
190 / <no-token>
191 / if const.devptr = null
192 then call ERROR no_Device / RETURN \
193 / / / global_device \
194 ^L
195 stack_pop
196 / /if tr_sw
197 then call ioa_" STACK_POP^a^i"StackSTACK_DEPTHSTACK_DEPTH
198 / STACK_POP \
199 / /;
200 push: proc name;
201 dcl name char *;
202
203 Stack STACK_DEPTH = name;
204 if tr_sw then call ioa_ " PUSH^a^i" nameSTACK_DEPTH;
205 end push;
206
207 pop: proc;
208 if tr_sw then call ioa_ " POP^a^i" Stack STACK_DEPTHSTACK_DEPTH;
209 STACK_DEPTH = max STACK_DEPTH - 1 0;
210 end pop; /\
211 ^L
212 \" define local named symbols for various strings
213 dcl
214 / <ident> ,
215 / dclname = token_value
216 LEX2
217 PUSH dcl_1call push "dcl_1" / output_0 \
218 dcl_1
219 / ; / dcl_p = area_free_p;
220 dcl_.leng = length part_str 1;
221 dcl_.dcl_v = part_str 1;
222 dcl_.dcl_name = dclname;
223 area_free_p = addr dcl_.dummy;
224 if dt_sw
225 then call ioa_ "^p^-dcl ^8a ""^a""" dcl_p dcl_name
226 dcl_v;
227 call link dcl_l_p dcl_p
228 LEX1 / stack_pop \
229 / /call ERROR syntax_dcl NEXT_STMT / stack_pop \
230 ^L
231 MediaChars
232 / <ident2>
233 / media1 media2=token_value / Media_3 \
234 / <input>
235 / media1 media2="" || Input || ""
236 LEX1 / Media_1 \
237 Media_err
238 / /call ERROR syntax_MediaChars /\
239 Media_skip \" scan forward looking for a "," or ";"
240 / , /LEX1 / MediaChars \
241 / ; / / Media_9 \
242 / <any-token>
243 /LEX1 / Media_skip \
244
245 Media_1
246 / : /LEX1 / Media_2 \
247 / /LEX-1 / Media_3 \
248 Media_2
249 / <input>
250 / media2="" || Input || "" / Media_3 \
251 / / / Media_err \
252 Media_3
253 / / held_Pthis_token = Pthis_token \" for error msgs
254 LEX1 PUSH Media_4call push "Media_4" / output_0 \
255 Media_4
256 / / hold_Pthis_token = Pthis_token;
257 Ptoken Pthis_token = held_Pthis_token;
258 \"in case any ERRORS
259 the_string = part_str 1;
260
261 if media1 ^= media2
262 then do;
263 if substr media1 1 1 ^= "")
264 | substr media2 1 1 ^= "")
265 then call ERROR inv_MediaChar_range;
266 else if media1 > media2
267 then call ERROR inv_Multics_char_range;
268 end;
269
270 do while media1 <= media2;
271 do i = 1 to mediachars.count;
272 if mediachars.name i = media1
273 then do;
274 call ERROR dup_MediaChars;
275 i = mediachars.count;
276 end;
277 end;
278
279 i = index the_string o777;
280 if i > 0
281 then do;
282 if substr media1 1 1 ^= "")
283 then call ERROR inv_MediaChar_SELF_ref;
284 substr the_string i 1 = substr media1 2 1;
285 end;
286 mediachars.count = mediachars.count + 1;
287 mediachars.name mediachars.count = media1;
288 mediachars.out_r mediachars.count
289 = rel find_str 1;
290 if i > 0
291 then substr the_string i 1 = o777;
292 substr media1 2 1
293 = byte rank substr media1 2 1 + 1;
294 \" media has form "x" when in a range
295 end;
296 Ptoken Pthis_token = hold_Pthis_token /\
297 / /LEX1 / MediaChars \
298 Media_9
299 / ; / LEX1 / stack_pop \
300 / / / Media_err \
301 ^L
302 Mwidths
303 / / mediact = 0;
304 mediabase = media.count /\
305 Mwidth_1
306 / <valid_Media_name>
307 / mediact = mediact + 1;
308 media.count = media.count + 1;
309 media.name media.count = token_value;
310 media.rel_units media.count = Strokes;
311 media.width media.count * = nulwidth
312 LEX1 / Mwidth_2 \
313 Mwidth_err
314 / /call ERROR syntax_Media_sec NEXT_STMT / Mwidth_3 \
315
316 Mwidth_2
317 / /LEX1 / Mwidth_1 \
318 / ; /LEX1 / Mwidth_3 \
319 / / / Mwidth_err \
320 Mwidth_3
321 / strokes :
322 /LEX2 media_i = 1 / Mwidth_s1 \
323 / / / Mwidth_4 \
324 Mwidth_s1
325 / <num>
326 / if media_i > mediact
327 then call ERROR too_many_stroke_values;
328 media.rel_units media_i+mediabase = token.Nvalue
329 LEX1 /\
330 / /LEX1 media_i = media_i + 1 / Mwidth_s1 \
331 / ; /LEX1 / Mwidth_3 \
332 / / / Mwidth_err \
333 Mwidth_4
334 / <charname>
335 / charid=token.Nvalue;
336 media1 = media2; \" charname sets media2
337 media_i = 1;
338 mediawidth = nulwidth
339 / Mwidth_A \
340 / / / stack_pop \
341 Mwidth_A
342 / <input_>
343 /LEX1 / Mwidth_B \
344 / /LEX1 / Mwidth_6 \
345 Mwidth_B
346 / : /LEX1 / Mwidth_C \
347 / / / Mwidth_6 \
348 Mwidth_C
349 / <charname>
350 / / Mwidth_D \
351 / / / Mwidth_err \
352 Mwidth_D
353 / <input_>
354 /LEX1 / Mwidth_6 \
355 / / / Mwidth_err \
356 Mwidth_6
357 / <num>
358 / / Mwidth_7 \
359 / <negnum>
360 / / Mwidth_7 \
361 / = / / Mwidth_8 \
362 / / / Mwidth_9 \
363 Mwidth_7
364 / / mediawidth = token.Nvalue /\
365 Mwidth_8
366 / /LEX1 media_ = media1;
367 charid_ = charid;
368 if mediawidth = nulwidth
369 then call ERROR no_prior_width;
370 else if media_ > media2
371 then call ERROR inv_Media_range;
372 else do while media_ <= media2;
373 if media_i > mediact
374 then do;
375 call ERROR too_many_widths;
376 media_ = "~" || rtrim media2;
377 end;
378 else do;
379 media.width media_i + mediabase charid_
380 = mediawidth;
381 if media_ < media2
382 then do;
383 substr media_ 2 1 =
384 byte rank substr media_ 2 1+1;
385 charid_ = 0;
386 do i = 1 to mediachars.count
387 while charid_ = 0;
388 if mediachars.name i = media_
389 then charid_ = i;
390 end;
391 if charid_ = 0
392 then do;
393 call ERROR inv_Media_range;
394 media_ = "~" || rtrim media2;
395 end;
396 end;
397 else media_ = "~" || rtrim media2; \" force it HI
398 end;
399 end /\
400 Mwidth_9
401 / ; /LEX1 / Mwidth_3 \
402 / / media_i = media_i + 1
403 LEX1 / Mwidth_6 \
404 / / / Mwidth_err \
405 ^L
406 Viewrest
407 / <ident>
408 / viewname=token_value
409 LEX1 / View_1 \
410 View_err
411 / /call ERROR syntax_View NEXT_STMT / stack_pop \
412
413 View_1
414 / <medianame>
415 / view.count = view.count + 1;
416 view.name view.count = viewname;
417 view.media view.count = token.Nvalue
418 LEX1 / View_2 \
419 / / / View_err \
420 View_2
421 / /LEX1 / Viewrest \
422 / ; /LEX1 / stack_pop \
423 / / / View_err \
424 ^L
425 Defrest
426 / <ident> ;
427 / Def.count = Def.count + 1;
428 Def.name Def.count = token_value
429 LEX2 Def.pt Def.count = Pthis_token;
430 vals_ct = 0 / Def_1 \
431 \" the token pointer is saved here so that at ref time parsing can be
432 \" temporarily diverted back here.
433
434 / /call ERROR no_name_Def NEXT_STMT /\
435
436
437 \" This keeps parsing until either a DEF FONT or INVALID STATEMENT occurs.
438 \" Nothing is done with the results of the parse other than invalid statements
439 \" are deleted so they will not cause further errors.
440 Def_1
441 / Def / / stack_pop \
442 / Font / / stack_pop \
443 / Size / / stack_pop \
444 / Device / / stack_pop \
445 / <no-token> / / stack_pop \
446 / / this_view = -1
447 PUSH Def_2call push "Def_2" / font_char \
448 Def_2
449 / ; /LEX1 / Def_1 \
450 / /DELETE_STMT / Def_1 \
451 \" font_char has already said why it is bad.
452 \" Deleting statement is so error won't happen again
453 \" during reparse at ref time.
454 ^L
455 font_char
456 / / vals_ct = 0 /\
457 fch_1
458 / <all_input>
459 /LEX1 vals_ct = vals_ct + 1;
460 vals vals_ct = rank Input / fch_2 \
461 / art
462 /LEX1 / fch_0 \
463 / /call ERROR inv_Mul_char_spec / fch_e \
464 fch_0
465 / <part>
466 /LEX1 vals_ct = vals_ct + 1;
467 vals vals_ct = rank Input / fch_5 \
468 / /call ERROR inv_artwork_spec / fch_e \
469 fch_2
470 / : /LEX1 / fch_3 \
471 / / / fch_5 \
472 fch_3
473 / <all_input>
474 /LEX1 i = rank Input;
475 if vals vals_ct > i
476 then do;
477 call ERROR inv_Multics_char_range;
478 call LEX -2;
479 \" ******* back up to the ":" to force error exit at fch_4
480 end;
481 else do;
482 j = vals vals_ct;
483 do while j < i;
484 j = j + 1;
485 vals_ct = vals_ct + 1;
486 vals vals_ct = j;
487 end;
488 end / fch_4 \
489 / /call ERROR syntax_after_colon / fch_e \
490 fch_4
491 / : \" ******* this catches error forced above
492 / / fch_e \
493 fch_5
494 / /LEX1 / fch_1 \
495 / <is_viewname>
496 / if this_view ^= -1
497 then this_view = token.Nvalue
498 LEX1 /\
499
500 \" MC_STRING is an alternate entry point to this routine.
501 mc_string
502 / / mediawidth self_ct = 0;
503 the_string = "" /\
504 / <quoted-string> / / fch_6 \
505 / /LEX1 / fch_A \
506 / <num> / / fch_6 \
507 / SELF / / fch_6 \
508 / <charname> / / fch_6 \
509 / /call ERROR not_charname /\
510 fch_6
511 / / part_nest = 0
512 PUSH fch_7call push "fch_7" / fch_l \
513 fch_7
514 / / the_string = part_str 1;
515 testwidth = nulwidth;
516 mediawidth = part_width 1 /\
517 / = /LEX1 / fch_9 \
518 fch_8
519 / ; / / stack_pop \
520 \" normal return is with ";" token current
521 / / / stack_pop \
522 \" but don't complain about a "" either.
523 / /call ERROR not_charname LEX 1 / fch_6 \
524 fch_9
525 / <negnum>
526 / testwidth = token.Nvalue
527 LEX1 / fch_8 \
528 / <num>
529 / testwidth = token.Nvalue
530 LEX1 / fch_8 \
531 / /call ERROR no_test_width / fch_8 \
532
533 fch_A
534 / / part_nest = 0
535 PUSH fch_Bcall push "fch_B" / fch_l \
536 fch_B
537 / =
538 /LEX 2 the_string = part_str 1;
539 testwidth = nulwidth / fch_C \
540 / /call ERROR paren_equal_expected / fch_8 \
541 fch_C
542 / <negnum>
543 / mediawidth = token.Nvalue
544 LEX1 / fch_8 \
545 / <num>
546 / mediawidth = token.Nvalue
547 LEX1 / fch_8 \
548 / /call ERROR missing_width / fch_8 \
549
550 fch_e
551 / ; /LEX-1 / stack_pop \
552 \" error return can't be with token ";" current
553 / / / stack_pop \
554 fch_l
555 / / part_nest = part_nest + 1;
556 part_str part_nest = "";
557 part_width part_nest = 0 /\
558 fch_M
559 / <num>
560 / part_repl part_nest = token.Nvalue
561 LEX2 PUSH fch_elcall push "fch_el" / fch_l \
562 / SELF
563 /LEX1 part_str part_nest = part_str part_nest || o777
564 / fch_M \
565 / <charname>
566 /PUSHfch_Mcall push"fch_M" / fch_K \
567 / <quoted-string>
568 /LEX1 list_ndx = 1 / fch_L \
569 / / part_nest = part_nest - 1 / stack_pop \
570 fch_L
571 / /LEX-1 /\
572 / <charlist> \" peel them off one char at a time
573 /PUSHfch_Lcall push"fch_L" / fch_K \
574 / /LEX1 / fch_M \
575 fch_K
576 / / str_p = ptr next_str_p mediachars.out_r token.Nvalue;
577 part_str part_nest = part_str part_nest || bstr.str;
578 if this_view > 0
579 then do;
580 if media.rel_units view.media this_view
581 ^= font.rel_units
582 then call ERROR bad_stroke_value;
583 mw = media.width view.media this_view
584 token.Nvalue;
585 if mw = nulwidth
586 then call ERROR_ no_width_specified
587 view.name this_view
588 show_name mediachars.name token.Nvalue;
589 part_width part_nest = part_width part_nest + mw;
590 end
591 LEX1 / stack_pop \
592
593 fch_el
594 / /LEX1 part_str part_nest = part_str part_nest
595 || copy part_strpart_nest+1 part_repl part_nest;
596 part_width part_nest = part_width part_nest
597 + part_width part_nest+1 * part_repl part_nest
598 / fch_M \
599 / /call ERROR unbal_parens / stack_pop \
600 ^L
601 Fontrest
602 / <ident>
603 / fnt_p = find_font "1"b;
604 if fnt.pt ^= null
605 then call ERROR dup_fontname;
606 font_ptr fnt.pt = area_free_p;
607 area_free_p = addr_inc area_free_p size font;
608 uni_p = area_free_p;
609 area_free_p = addr_inc area_free_p size uni;
610 call link unil_p uni_p;
611 uni.seqno uni.refno uni_ct = uni_ct + 1;
612 units_ptr uni.ref_p = area_free_p;
613 area_free_p = addr_inc area_free_p size units;
614 opu_p = area_free_p;
615 area_free_p = addr_inc area_free_p size opu;
616 call link opul_p opu_p;
617 opu.refno opu.seqno = uni_ct;
618 oput_p opu.ref_p = area_free_p;
619 font.units_r = rel uni_p;
620 font.oput_r = rel opu_p;
621 font.rel_units = -1;
622 font.footsep = Footsep;
623 font.min_wsp = MinWordsp;
624 font.avg_wsp = AvgWordsp;
625 font.max_wsp = MaxWordsp;
626 units * = 0;
627 oput.data_ct = 0;
628 default_view = 1
629 LEX1 / Font_1 \
630 / /call ERROR not_valid_Font_name NEXT_STMT / Font_3 \
631
632 Font_1
633 / <is_viewname>
634 / default_view = token.Nvalue;
635 font.rel_units
636 = media.rel_units view.media default_view
637 LEX1 / Font_2 \
638 / /call ERROR not_viewname NEXT_STMT / Font_3 \
639
640 Font_2
641 / ; / / Font_3 \
642 / /call ERROR syntax_Font /\
643 Font_3
644 / / if Wordspace_p = null
645 then goto RD_NEXT_REDUCTION;
646 hold_Pthis_token = Pthis_token;
647 Ptoken Pthis_token = Wordspace_p
648 PUSHFont_4call push"Font_4" / wordspace \
649 / / / Font_5 \
650 Font_4
651 / ; / Ptoken Pthis_token = hold_Pthis_token / Font_8 \
652 / /call ERROR syntax_Wordspace
653 Ptoken Pthis_token = hold_Pthis_token / Font_5 \
654
655 font_err
656 / /call ERROR syntax_Font_sec NEXT_STMT / stack_pop \
657
658 Font_5
659 / /PUSH endFontcall push"endFont" /\
660 Font_6
661 / <all_input>
662 / this_view = default_view
663 PUSH Font_8call push "Font_8" / font_char \
664 / art
665 / this_view = default_view
666 PUSH Font_8call push "Font_8" / font_char \
667 / Def \" This is here for purposes of ref closure
668 / / stack_pop \
669 / footrefseparator :
670 /LEX2 / footrefsep \
671 / wordspace :
672 /LEX2 PUSHFont_9call push"Font_9" / wordspace \
673 / ref :
674 /LEX2 / ref \
675 / Font / / stack_pop \
676 / Size / / stack_pop \
677 / Device / / stack_pop \
678 / <no-token> / / stack_pop \
679 / /PUSH Font_6call push "Font_6" / global_device \
680
681 Font_8
682 / ; / self_ct = 0;
683 j = index the_string o777;
684 if j = 0
685 then the_string_r = rel find_str 2;
686 else do;
687 do while j <= lengththe_string;
688 self_ct = self_ct + 1;
689 self_i self_ct = j;
690 j = j + 1;
691 if j < length the_string
692 then do;
693 i = index substr the_string j o777;
694 if i = 0
695 then j = length the_string+1;
696 else j = j + i - 1;
697 end;
698 end;
699 end;
700 media1 = " ";
701 jj= 0;
702 do i = 1 to vals_ct;
703 ii = vals i;
704 if self_ct > 0
705 then do;
706 substr media1 2 1 = byte ii;
707 do j = 1 to self_ct;
708 substr the_string self_i j 1 = byte ii;
709 end;
710 the_string_r = rel find_str 2;
711 charid = 0;
712 do jj = 1 to mediachars.count
713 while charid = 0;
714 if mediachars.name jj = media1
715 then charid = jj;
716 end;
717 if charid = 0 \" a MediaChar must be
718 then do; \" defined with this name
719 call ERROR inv_Font_SELF_ref;
720 jj = 0;
721 end;
722 else do;
723 jj = media.width view.media this_view
724 charid;
725 if jj = nulwidth
726 then call ERROR_ no_width_specified
727 view.name this_view
728 show_name mediachars.name charid;
729 end;
730 end;
731 units ii = mediawidth + jj * self_ct;
732 oput.data_ct = max oput.data_ct ii;
733 oput.which ii = this_view;
734 oput.what_r ii = the_string_r;
735 if testwidth ^= nulwidth
736 then if units ii ^= testwidth
737 then call ERROR_ bad_width_value
738 ltrim char units ii
739 ltrim char testwidth;
740 end
741 LEX1 / Font_6 \
742 \" the LEX1 needs to be after so error msg will display
743 \" proper statement.
744 / /NEXT_STMT / Font_6 \
745 \" font_char already told why in error
746
747
748 footrefsep
749 / <all_input> ;
750 /LEX2 font.footsep = Input / Font_6 \
751 Font_9
752 / ; /LEX1 / Font_6 \
753 / /call ERROR syntax_wordspace NEXT_STMT LEX-1 / Font_6 \
754
755
756 wordspace
757 / <num>
758 / font.min_wsp = token.Nvalue
759 LEX2 / font_s2 \
760 / / / font_se \
761 font_s2
762 / <num>
763 / font.avg_wsp = token.Nvalue
764 LEX2 / font_s3 \
765 / / / font_se \
766 font_s3
767 / <num>
768 / font.max_wsp = token.Nvalue
769 LEX2 / font_s4 \
770 / / / font_se \
771 font_s4
772 / <charname> ;
773 / this_view = default_view;
774 vals_ct = 1;
775 vals 1 = 32 / mc_string \
776 \" Consistency between AvgWordsp and mediawidth will be checked later.
777 font_se
778 / ; / LEX-1 / stack_pop \
779 \" make sure NOT pointing to ";" token when return
780
781 / / / stack_pop \
782
783 endFont
784 / / tp = unil_p 2; \" see if units is like a prior one
785 done = "0"b;
786 do uni_p = unil_p 1 repeat uni.next
787 while uni_p ^= unil_p 2 & ^done;
788 if uni.refno = uni.seqno
789 then do; \" check only "real" ones
790 if unspec uni.ref_p -> units
791 = unspec tp -> uni.ref_p -> units
792 then do;
793 tp -> uni.refno = uni.seqno; \"its a duplicate
794 done = "1"b;
795 end;
796 end;
797 end;
798 tp = opul_p 2; \" see if oput is like a prior one
799 done = "0"b;
800 do opu_p = opul_p 1 repeat opu.next
801 while opu_p ^= opul_p 2 & ^done;
802 if opu.refno = opu.seqno
803 then do; \" check only "real" ones
804 if unspec opu.ref_p -> oput
805 = unspec tp -> opu.ref_p -> oput
806 then do;
807 tp -> opu.refno = opu.seqno; \"its a duplicate
808 done = "1"b;
809 end;
810 end;
811 end / stack_pop \
812
813
814 \" ----------------------------------------------------------------------------
815 \" This routine reparses the source following the named Def and then continues
816 \" following the ref statement.
817 ref
818 / <is_Defname>
819 / i = token.Nvalue
820 LEX1 / ref__ \
821 / /call ERROR not_Defname NEXT_STMT / Font_6 \
822 ref__
823 / ; / / ref_0 \
824 / /call ERROR missing_semicolon /\
825 ref_0
826 / / hold_Pthis_token = Pthis_token;
827 Ptoken Pthis_token = Def.pt i
828 PUSH ref_1call push "ref_1" / Font_6 \
829 \" divert parsing back to the Def source
830 ref_1
831 / / Ptoken Pthis_token = hold_Pthis_token
832 NEXT_STMT / Font_6 \
833 \" have reached end of Def
834 \" continue parsing where we left off
835 \" ----------------------------------------------------------------------^L
836 Sizerest
837 / <ident>
838 / size_list.count = size_list.count + 1;
839 size_list.name size_list.count = token_value;
840 size_list.pt size_list.count = sizel_p;
841 sizel.val_ct = 0
842 LEX1 / point_1 \
843 / /call ERROR no_Size_name NEXT_STMT / stack_pop \
844
845 point_1
846 / <num>
847 /LEX1 sizel.val_ct = sizel.val_ct + 1;
848 sizel.val sizel.val_ct = scale_unit 1000
849 LEX1 / point_1 \
850 / / area_free_p sizel_p = addr_inc sizel_p size sizel/\
851 / ; /LEX1 / stack_pop \
852 / /call ERROR syntax_Size NEXT_STMT / stack_pop \
853 \"^K^K
854 global_device
855 / Units : <unitkey> ;
856 /LEX2 if db_sw then call ioa_ "^^/^===Units ^a"
857 dt_sw token_value;
858 Hscale = hscales token.Nvalue;
859 Vscale = vscales token.Nvalue
860 LEX2 / stack_pop \
861 / Artproc : <ident>
862 /LEX2 ArtProc = token_value
863 LEX1 / Artproc \
864 / Attach : <quoted-string> ;
865 /LEX2 the_string = token_value;
866 Atd_r = rel find_str 2
867 LEX2 / stack_pop \
868 / Cleanup :
869 /LEX2 part_nest = 0
870 PUSH Cleanupcall push "Cleanup" / mc_string \
871 / Font :
872 / / stack_pop \
873 / Comment : <quoted-string> ;
874 /LEX2 the_string = token_value;
875 Com_r = rel find_str 2
876 LEX2 / stack_pop \
877 / DefaultMargs : <num> <num> <num> <num> ;
878 /LEX2 DefVmt = scale_unit Vscale
879 LEX2 DefVmh = scale_unit Vscale
880 LEX2 DefVmf = scale_unit Vscale
881 LEX2 DefVmb = scale_unit Vscale
882 LEX2 / stack_pop \
883 / DevClass : <quoted-string> ;
884 /LEX2 if db_sw then call ioa_ "^^/^===DevClass" dt_sw;
885 DevClass = token_value
886 LEX2 / stack_pop \
887 / DevName : <quoted-string> ;
888 /LEX2 if db_sw then call ioa_ "^^/^===DevName" dt_sw;
889 DevName = token_value
890 LEX2 / stack_pop \
891 / Endpage : <all_input> ;
892 /LEX2 EndPage = unspec Input
893 LEX2 / stack_pop \
894 / Footproc :
895 / if db_sw
896 then call ioa_ "^^/^===Footproc" dt_sw
897 LEX2 / Footproc \
898 / Footrefseparator :
899 / if db_sw
900 then call ioa_ "^^/^===Footrefseparator" dt_sw
901 LEX2 / Footrefsep \
902 / Justify : <switch> ;
903 /LEX2 if db_sw then call ioa_ "^^/^===Justify" dt_sw;
904 Justify = token.Nvalue > 0
905 LEX2 / stack_pop \
906 / Interleave : <switch> ;
907 /LEX2 if db_sw then call ioa_ "^^/^===Interleave" dt_sw;
908 Interleave = token.Nvalue > 0
909 LEX2 / stack_pop \
910 / Letterspace : <num> ;
911 /LEX2 if db_sw then call ioa_ "^^/^===Letterspace" dt_sw;
912 Letterspace = token.Nvalue
913 LEX2 / stack_pop \
914 / MaxFiles : <limit> ;
915 /LEX2 MaxFiles = token.Nvalue
916 LEX2 / stack_pop \
917 / MaxPages : <limit> ;
918 /LEX2 MaxPages = token.Nvalue
919 LEX2 / stack_pop \
920 / MaxPageLength : <limit> ;
921 /LEX2 MaxPageLength = scale_unit Vscale
922 LEX2 / stack_pop \
923 / MaxPageWidth : <num> ;
924 /LEX2 if db_sw
925 then call ioa_ "^^/^===MaxPageWidth" dt_sw;
926 MaxPageWidth = scale_unit Hscale
927 LEX2 / stack_pop \
928 / MinBotMarg : <num> ;
929 /LEX2 MinVmb = scale_unit Vscale
930 LEX2 / stack_pop \
931 / MinLead : <num> ;
932 /LEX2 if db_sw then call ioa_ "^^/^===MinLead" dt_sw;
933 MinLead = scale_unit Vscale
934 LEX2 / stack_pop \
935 / MinSpace : <num> ;
936 /LEX2 if db_sw then call ioa_ "^^/^===MinSpace" dt_sw;
937 MinSpace = scale_unit Hscale
938 LEX2 / stack_pop \
939 / MinTopMarg : <num> ;
940 /LEX2 MinVmt = scale_unit Vscale
941 LEX2 / stack_pop \
942 / Outproc : <ident>
943 /LEX2 if db_sw then call ioa_ "^^/^===Outproc" dt_sw;
944 OutProc DisplayProc = token_value
945 LEX1 / Outproc \
946 / Strokes : <num> ;
947 /LEX2 if db_sw then call ioa_ "^^/^===Strokes" dt_sw;
948 Strokes = token.Nvalue
949 LEX2 / stack_pop \
950 / Wordspace :
951 /LEX2 if db_sw then call ioa_ "===Wordspace";
952 Wordspace_p = Pthis_token NEXT_STMT / stack_pop \
953 \" just remember where this is for later use.
954 / Sizes : <sizename> ;
955 /LEX2 Sizes = token.Nvalue
956 LEX2 / stack_pop \
957 / Stream : <switch> ;
958 /LEX2 if db_sw then call ioa_ "^^/^===Stream" dt_sw;
959 Openmode = 5 - 3 * token.Nvalue
960 LEX2 / stack_pop \
961 / TapeRec : <limit> ;
962 /LEX2 TapeRec = token.Nvalue
963 LEX2 / stack_pop \
964 / <no-token> /call ERROR end_of_source / RETURN \
965 / dcl
966 / / out_of_place \
967 / MediaChars
968 / / out_of_place \
969 / Media
970 / / out_of_place \
971 / View
972 / / out_of_place \
973 / Def
974 / / out_of_place \
975 / Font
976 / / out_of_place \
977 / Size
978 / / out_of_place \
979 / Device
980 / / out_of_place \
981 / /call ERROR inv_statement NEXT_STMT / stack_pop \
982 out_of_place
983 / /call ERROR stmt_out_of_place NEXT_STMT / stack_pop \
984
985 Artproc
986 / $ <ident> ;
987 /LEX1 ArtEntry = token_value
988 LEX2 / stack_pop \
989 / / ArtEntry = ArtProc
990 LEX1 / stack_pop \
991
992 Footrefsep
993 / <all_input> ;
994 / Footsep = Input
995 LEX2 / stack_pop \
996 / /call ERROR syntax_Footrefsep NEXT_STMT / stack_pop \
997
998 Footproc
999 / <ident>
1000 / FootProc = token_value
1001 LEX1 / Foot_1 \
1002 / /LEX1 / Foot_2 \
1003 / /call ERROR syntax_Footproc NEXT_STMT / stack_pop \
1004
1005 Foot_1
1006 / $ <ident>
1007 /LEX1 FootEntry = token_value
1008 LEX1 / Foot_2 \
1009 / / FootEntry = FootProc /\
1010
1011 Foot_2
1012 / <fam_mem>
1013 /LEX2 FootFamily = font_fam;
1014 FootMember = font_mem /\
1015 / ; /LEX1 / stack_pop \
1016 / /call ERROR syntax_Footproc NEXT_STMT / stack_pop \
1017
1018 Outproc
1019 / $ <ident> ;
1020 /LEX1 OutEntry = token_value
1021 LEX2 / stack_pop \
1022 / ; / OutEntry = OutProc
1023 LEX1 / stack_pop \
1024 / /call ERROR syntax_Outproc NEXT_STMT / stack_pop \
1025
1026 Cleanup
1027 / ; /LEX1 Clean_r = rel find_str 2 / stack_pop \
1028 / /call ERROR syntax_Cleanup NEXT_STMT / stack_pop \
1029 ^L
1030 output_0
1031 / / iii parenct part_nest = 0 /\
1032 output_1
1033 / / part_nest = part_nest + 1;
1034 part_repl part_nest = iii;
1035 part_str part_nest = "" /\
1036
1037 output_2
1038 / <octal>
1039 / part_str part_nest = part_str part_nest || Input
1040 LEX1 / output_2 \
1041 / <quoted-string>
1042 / part_str part_nest = part_str part_nest || token_value
1043 LEX1 / output_2 \
1044 / SELF
1045 / part_str part_nest = part_str part_nest || o777
1046 LEX1 / output_2 \
1047 / <num>
1048 / iii = token.Nvalue;
1049 parenct = parenct + 1
1050 LEX2 PUSH output_3call push "output_3" / output_1 \
1051 / <dcl_ed>
1052 / part_strpart_nest = part_strpart_nest||bstr.str
1053 LEX1 / output_2 \
1054 / / / stack_pop \
1055
1056 output_3
1057 / /LEX1 part_str part_nest-1 = part_str part_nest-1
1058 || copy part_str part_nest part_repl part_nest;
1059 part_nest = part_nest - 1;
1060 parenct = parenct - 1 / output_2 \
1061 / ; /call ERROR unbal_parens / stack_pop \
1062 / / / stack_pop \
1063 ^L
1064 Devicerest
1065 / / comp_dvid_ct = comp_dvid_ct+1;
1066 comp_dvid_new="1"b;
1067 like_table = -1 /\
1068 Device_0
1069 / <valid_Device_name>
1070 / if dvid_ct = 0
1071 then dvid_ct = dvid_ct + 1; \" add Device name
1072 dvid_p = area_free_p;
1073 area_free_p = addr dvid.dummy;
1074 call link dvidl_p dvid_p;
1075 dvid.ndx = comp_dvid_ct;
1076 dvid.real = comp_dvid_new;
1077 dvid.refname = token_value;
1078 dvid.devname = DevName;
1079 dvid.dvt_ndx = dvt_ct + 1;
1080 comp_dvid_new = "0"b
1081 LEX1 / Device_1 \
1082
1083 table_e
1084 / /call ERROR syntax_Device NEXT_STMT / stack_pop \
1085
1086 Device_1
1087 / /LEX1 / Device_0 \
1088 / like
1089 /LEX1 / like_table \
1090 / ; /LEX1 PUSH startDevicecall push "startDevice" / Device_I \
1091 / / / table_e \
1092
1093 like_table
1094 / <table_name> ;
1095 / like_table = token.Nvalue
1096 LEX2 / like_table2 \
1097 / / / table_e \
1098
1099 like_table3
1100 / / do dvid_p = dvidl_p 1 repeat dvid.next
1101 while dvid_p ^= null ;
1102 if dvid.dvt_ndx = dvt_ct + 1
1103 then dvid.dvt_ndx = like_table;
1104 end / stack_pop \
1105 like_table2
1106 / Device
1107 / / like_table3 \
1108 / <no-token>
1109 / / like_table3 \
1110 / / PUSH copy_tablecall push "copy_table" / Device_I \
1111
1112 Device_I
1113 / / dvt_p = area_free_p;
1114 area_free_p = addr dvt.dummy;
1115 call link dvtl_p dvt_p;
1116 dvt.ndx dvt_ct = dvt_ct + 1;
1117 dvt.med_sel = area_free_p;
1118 med_sel_tab.count = font_count;
1119 area_free_p
1120 = addr_inc area_free_p size med_sel_tab;
1121 med_sel_tab.ref_r * = "0"b;
1122
1123 dvt.prent prent_p = area_free_p;
1124 area_free_p = addr prent.dummy;
1125
1126 dvt.ref const.devptr = area_free_p;
1127 dvt_ct = dvt_ct + 1 / stack_pop \
1128
1129 copy_table
1130 / / tp = null ;
1131 do dvt_p = dvtl_p 1 repeat dvt.next
1132 while dvt_p ^= null & tp = null ;
1133 if dvt.ndx = like_table
1134 then tp = dvt_p;
1135 end;
1136
1137 dvt_p = tp;
1138 med_sel_tab = dvt.med_sel -> med_sel_tab;
1139 prent = dvt.prent -> prent;
1140 comp_dvt.family_ct = dvt.ref -> comp_dvt.family_ct;
1141 comp_dvt = dvt.ref -> comp_dvt / Device_2 \
1142
1143 startDevice
1144 / / prent.outproc = OutProc || "$" || OutEntry;
1145 prent.artproc = ArtProc || "$" || ArtEntry;
1146 prent.footproc = FootProc || "$" || FootEntry;
1147 initfamily initmember = "";
1148 footfamily = FootFamily;
1149 footmember = FootMember;
1150 hscale = Hscale;
1151 vscale = Vscale;
1152 comp_dvt.devclass = DevClass;
1153 comp_dvt.min_WS = MinSpace;
1154 comp_dvt.min_lead = MinLead;
1155 comp_dvt.vmt_min = MinVmt;
1156 comp_dvt.vmb_min = MinVmb;
1157 comp_dvt.def_vmt = DefVmt;
1158 comp_dvt.def_vmh = DefVmh;
1159 comp_dvt.def_vmf = DefVmf;
1160 comp_dvt.def_vmb = DefVmb;
1161 comp_dvt.pdw_max = MaxPageWidth;
1162 comp_dvt.pdl_max = MaxPageLength;
1163 comp_dvt.upshift = 0;
1164 comp_dvt.init_ps = 0;
1165 comp_dvt.lettersp = Letterspace;
1166 comp_dvt.max_pages = MaxPages;
1167 comp_dvt.max_files = MaxFiles;
1168 comp_dvt.init_family = "";
1169 comp_dvt.init_member = "";
1170 comp_dvt.atd_r = Atd_r;
1171 comp_dvt.dvc_r = ""b;
1172 comp_dvt.comment_r = Com_r;
1173 comp_dvt.cleanup_r = Clean_r;
1174 comp_dvt.medsel_table_r = ""b;
1175 comp_dvt.foot_family = "";
1176 comp_dvt.foot_member = "";
1177
1178 comp_dvt.sws.interleave = Interleave;
1179 comp_dvt.sws.justifying = Justify;
1180 comp_dvt.sws.mbz = "0"b;
1181 comp_dvt.sws.endpage = EndPage;
1182 comp_dvt.open_mode = Openmode;
1183 comp_dvt.recleng = TapeRec;
1184 comp_dvt.family_ct = 0 /\
1185
1186 Device_2
1187 / units : <unitkey> ;
1188 /LEX2 hscale = hscales token.Nvalue;
1189 vscale = vscales token.Nvalue
1190 LEX2 / Device_2 \
1191 / artproc : <ident>
1192 /LEX2 prent.artproc = token_value
1193 LEX1 / artproc \
1194 / attach : <quoted-string> ;
1195 /LEX2 the_string = token_value;
1196 comp_dvt.atd_r = rel find_str 2
1197 LEX2 / Device_2 \
1198 / cleanup :
1199 /LEX2 PUSH cleanupcall push "cleanup" / mc_string \
1200 / comment : <quoted-string> ;
1201 /LEX2 the_string = token_value;
1202 comp_dvt.comment_r = rel find_str 2;
1203 if length token_value > length the_string
1204 then call ERROR comment_gt_8000
1205 LEX2 / Device_2 \
1206
1207 / defaultmargs : <num> <num> <num> <num> ;
1208 /LEX2 comp_dvt.def_vmt = scale_unit vscale
1209 LEX2 comp_dvt.def_vmh = scale_unit vscale
1210 LEX2 comp_dvt.def_vmf = scale_unit vscale
1211 LEX2 comp_dvt.def_vmb = scale_unit vscale
1212 LEX2 / Device_2 \
1213 / devclass : <quoted-string> ;
1214 /LEX2 comp_dvt.devclass = token_value
1215 LEX2 / Device_2 \
1216 / devname : <quoted-string> ;
1217 /LEX2 do dvid_p = dvidl_p 1 repeat dvid.next
1218 while dvid_p ^= null ;
1219 if dvid.dvt_ndx = dvt_ct
1220 then dvid.devname = token_value;
1221 end
1222 LEX2 / Device_2 \
1223 \" / dvc : <ident>
1224 \" /LEX2 dvcname = token_value
1225 \" LEX2 dvcproc the_string = "" / dvc_1 \
1226 / endpage : <all_input> ;
1227 /LEX2 comp_dvt.endpage = unspec Input
1228 LEX2 / Device_2 \
1229 / family :
1230 / bach_sw = "0"b
1231 LEX2 PUSHfamilycall push"family" / add_family \
1232 / footproc :
1233 /LEX2 / footproc \
1234 / init :
1235 /LEX2 / init_f0 \
1236 / interleave : <switch> ;
1237 /LEX2 comp_dvt.interleave = token.Nvalue > 0 / Device_2 \
1238 / justify : <switch> ;
1239 /LEX2 comp_dvt.justifying = token.Nvalue > 0 / Device_2 \
1240 / letterspace : <num> ;
1241 /LEX2 comp_dvt.lettersp = token.Nvalue
1242 LEX2 / Device_2 \
1243 / maxfiles : <limit> ;
1244 /LEX2 comp_dvt.max_files = token.Nvalue
1245 LEX2 / Device_2 \
1246 / maxpages : <limit> ;
1247 /LEX2 comp_dvt.max_pages = token.Nvalue
1248 LEX2 / Device_2 \
1249 / maxpagelength : <limit> ;
1250 /LEX2 comp_dvt.pdl_max = scale_unit vscale
1251 LEX2 / Device_2 \
1252 / maxpagewidth : <num> ;
1253 /LEX2 comp_dvt.pdw_max = scale_unit hscale
1254 LEX2 / Device_2 \
1255 / minbotmarg : <num> ;
1256 /LEX2 comp_dvt.vmb_min = scale_unit vscale
1257 LEX2 / Device_2 \
1258 / minlead : <num> ;
1259 /LEX2 comp_dvt.min_lead = scale_unit vscale
1260 LEX2 / Device_2 \
1261 / minspace : <num> ;
1262 /LEX2 comp_dvt.min_WS = scale_unit hscale
1263 LEX2 / Device_2 \
1264 / mintopmarg : <num> ;
1265 /LEX2 comp_dvt.vmt_min = scale_unit vscale
1266 LEX2 / Device_2 \
1267 / outproc : <ident>
1268 /LEX2 prent.outproc = token_value
1269 LEX1 / outproc \
1270 / stream : <switch> ;
1271 /LEX2 comp_dvt.open_mode = 5 - 3 * token.Nvalue
1272 LEX2 / Device_2 \
1273 / taperec : <limit> ;
1274 /LEX2 comp_dvt.recleng = token.Nvalue
1275 LEX2 / Device_2 \
1276 / bachelor :
1277 / bach_sw = "1"b
1278 LEX2 PUSHbachelorcall push"bachelor" / add_family \
1279 / viewselect :
1280 /LEX2 / viewselect \
1281 / Device
1282 / / endDevice \
1283 / <no-token>
1284 / / endDevice \
1285 / / PUSH Device_2call push "Device_2" / global_device \
1286
1287 endDevice
1288 / / tp = Pthis_token;
1289 Ptoken Pthis_token = Device_Pthis_token;
1290
1291 done = "0"b;
1292 do dvid_p = dvidl_p 1 repeat dvid.next
1293 while dvid_p ^= null & ^done;
1294 if dvid.dvt_ndx = dvt_ct
1295 then if dvid.devname = ""
1296 then do;
1297 call ERROR no_devname;
1298 done = "1"b;
1299 end;
1300 end;
1301 dvid_p = dvidl_p 2;
1302 if comp_dvt.family_ct = 0
1303 then call ERROR no_fonts_selected;
1304 if initfamily = ""
1305 then call ERROR no_init_font;
1306 if footfamily = ""
1307 then do;
1308 footfamily = initfamily;
1309 footmember = initmember;
1310 end;
1311
1312 views_selected = 0;
1313 do i = 1 to view.count;
1314 if med_sel_tab.ref_r i ^= "0"b
1315 then views_selected = views_selected + 1;
1316 end;
1317
1318 do i = 1 to comp_dvt.family_ct;
1319 mem_p = ptr area1_p comp_dvt.member_r i;
1320 member_ptr = mem.ref_p;
1321 do ii = 1 to member.count;
1322 if initfamily = comp_dvt.family i.name
1323 & initmember = member.name ii
1324 then do;
1325 comp_dvt.init_fam = i;
1326 comp_dvt.init_family = initfamily;
1327 comp_dvt.init_mem = ii;
1328 comp_dvt.init_member = initmember;
1329 end;
1330 if footfamily = comp_dvt.family i.name
1331 & footmember = member.name ii
1332 then do;
1333 comp_dvt.foot_fam = i;
1334 comp_dvt.foot_family = footfamily;
1335 comp_dvt.foot_mem = ii;
1336 comp_dvt.foot_member = footmember;
1337 end;
1338
1339 if views_selected < view.count
1340 then do;
1341 fnt_p = ptr area2_p member.font_r ii;
1342 font_ptr = fnt.pt;
1343 uni_p = ptr fnt.pt font.units_r;
1344 units_ptr = uni.ref_p;
1345 opu_p = ptr fnt.pt font.oput_r;
1346 oput_p = opu.ref_p;
1347
1348 do iii = 0 to oput.data_ct;
1349 j = oput.which iii;
1350 if j > 0 \" is the char defined?
1351 then do; \" YES
1352 if med_sel_tab.ref_r j = "0"b
1353 then do; \" but you can't get at it!
1354 call ERROR_ no_viewselect
1355 view.name j dvid.refname;
1356 med_sel_tab.ref_r j = "000001"b3;
1357 \" don't want to say this again.
1358 views_selected = views_selected + 1;
1359 end;
1360 end;
1361 end;
1362 end;
1363 end;
1364 end;
1365 if comp_dvt.init_family = ""
1366 then call ERROR init_font_not_on_Device;
1367 if comp_dvt.foot_family = ""
1368 then call ERROR foot_font_not_on_Device;
1369 Ptoken Pthis_token = tp;
1370 area_free_p = addr_inc area_free_p size comp_dvt
1371 \" finish allocation
1372 / stack_pop \
1373
1374 artproc
1375 / $ <ident> ;
1376 /LEX1 prent.artproc = prent.artproc || "$";
1377 prent.artproc = prent.artproc || token_value
1378 LEX2 / Device_2 \
1379 / /LEX1 prent.artproc
1380 = prent.artproc || "$" || prent.artproc / Device_2 \
1381
1382 outproc
1383 / $ <ident> ;
1384 /LEX1 prent.outproc = prent.outproc || "$" || token_value
1385 LEX2 / Device_2 \
1386 / ; /LEX1 / Device_2 \
1387 / /call ERROR syntax_outproc NEXT_STMT / Device_2 \
1388
1389 cleanup
1390 / ; /LEX1 comp_dvt.cleanup_r = rel find_str 2 / Device_2 \
1391 / /call ERROR syntax_cleanup NEXT_STMT / Device_2 \
1392
1393 add_family
1394 / / new_family = "1"b /\
1395 family_1
1396 / <fam_bach>
1397 / if new_family
1398 then do;
1399 if member_ptr = null
1400 then mem_p = area1_p;
1401 else mem_p = addr_inc member_ptr size member;
1402 call link meml_p mem_p;
1403 mem.seqno mem.refno mem_ct = mem_ct + 1;
1404 member_ptr mem.ref_p = addr mem.dummy;
1405 member.count = 0;
1406 new_family = "0"b;
1407 end;
1408 comp_dvt.family_ct = comp_dvt.family_ct + 1;
1409 comp_dvt.member_r comp_dvt.family_ct = rel mem_p;
1410 if ^bach_sw
1411 then comp_dvt.family comp_dvt.family_ct.name
1412 = translate token_value az AZ;
1413 else comp_dvt.family comp_dvt.family_ct.name
1414 = token_value;
1415 Scale_x Scale_y = Scale_scale
1416 LEX1 / family_2 \
1417 / /call ERROR fam_bach_name_expected / stack_pop \
1418 family_2
1419 / /LEX1 / family_1 \
1420 / / / stack_pop \
1421 family
1422 / ; member
1423 /LEX1 / member \
1424 family_err
1425 / /call ERROR syntax_family NEXT_STMT / Device_2 \
1426 member
1427 / member :
1428 / new_member = member.count+1
1429 LEX2 / member_1 \
1430 / / / endmem \
1431
1432 member_1
1433 / <membername>
1434 / member.count = member.count + 1;
1435 member.font_r member.count = "0"b;
1436 member.size_r member.count = "0"b;
1437 member.name member.count
1438 = translate token_value az AZ
1439 LEX1 / member_2 \
1440 / /call ERROR syntax_member NEXT_STMT / Device_2 \
1441 member_2
1442 / /LEX1 / member_1 \
1443 / /PUSH member call push "member" /\
1444 member_3
1445 / <font_name>
1446 /LEX1 / member_4 \
1447 / /call ERROR no_fontname /\
1448 member_4
1449 / ; /LEX1 / member_6 \
1450 / /call ERROR syntax_member NEXT_STMT / stack_pop \
1451 member_6
1452 / Scale :
1453 /LEX2 / member_7 \
1454 / / / member_A \
1455 member_7
1456 / <num>
1457 / Scale_x Scale_y
1458 = convert fd12_8 token_value* Scale_scale
1459 LEX1 / member_8 \
1460 / / / Scale_err \
1461 member_8
1462 / <num>
1463 /LEX1 Scale_y = convert fd12_8 token_value * Scale_scale
1464 LEX1 / member_9 \
1465 / / / Scale_err \
1466 member_9
1467 / ; /LEX1 / member_A \
1468 Scale_err
1469 / /call ERROR syntax_Scale NEXT_STMT /\
1470 member_A
1471 / / the_string_r = rel find_str 2;
1472 do i = new_member to member.count;
1473 member.font_r i = rel the_font;
1474 member.Scalex i = Scale_x;
1475 member.Scaley i = Scale_y;
1476 addr member.size_r i -> bfb = Sizes;
1477 end / stack_pop \
1478
1479 init_f0
1480 / <fam_mem>
1481 /LEX1 initfamily = font_fam;
1482 initmember = font_mem / init_f2 \
1483 / /call ERROR missing_fontNEXT_STMT / Device_2 \
1484 init_f2
1485 / <num>
1486 / comp_dvt.init_ps = scale_unit 1000
1487 LEX1 / init_f3 \
1488 / /call ERROR no_init_psNEXT_STMT / Device_2 \
1489 init_f3
1490 / ; /LEX1 / Device_2 \
1491 / /call ERROR missing_semicolonNEXT_STMT / Device_2 \
1492
1493 bachelor
1494 / / new_member member.count = 1;
1495 member.font_r 1 = "0"b;
1496 member.size_r 1 = "0"b;
1497 member.Scalex 1 = Scale_x;
1498 member.Scaley 1 = Scale_y;
1499 member.name 1 = ""
1500 PUSH endmem call push "endmem" / member_3 \
1501 endmem
1502 / / done = "0"b; \" put into "normal" form
1503 do while ^done;
1504 done = "1"b;
1505 do i = 1 to member.count-1;
1506 call memorder;
1507 end;
1508 if ^done
1509 then do;
1510 done = "1"b;
1511 do i = member.count-1 to 1 by -1;
1512 call memorder;
1513 end;
1514 end;
1515 end;
1516 memorder: proc;
1517 if member.name i > member.name i+1
1518 then do;
1519 member_hold = member.e i;
1520 member.e i = member.e i+1;
1521 member.e i+1 = member_hold;
1522 done = "0"b;
1523 end;
1524 end memorder;
1525 tp = meml_p 2; \" see if member is like a prior one
1526 done = "0"b;
1527 do mem_p = meml_p 1 repeat mem.next
1528 while mem_p ^= meml_p 2;
1529 if mem.seqno = mem.refno
1530 then do; \" check only "real" ones
1531 if unspec mem.ref_p -> mem
1532 = unspec tp -> mem.ref_p -> mem
1533 then do;
1534 tp -> mem.refno = mem.seqno; \"its a duplicate
1535 done = "1"b;
1536 end;
1537 end;
1538 end / Device_2 \
1539
1540 \"dvc_1
1541 \" / <ident>$<ident>
1542 \" / dvcproc = token_value
1543 \" LEX2 dvcentry = token_value
1544 \" LEX1 /\
1545 \" / <quoted-string>
1546 \" / the_string = token_value
1547 \" LEX1 /\
1548 \" / ; /LEX1 the_string = "" / Device_2 \
1549
1550 footproc
1551 / <ident>
1552 / prent.footproc = token_value
1553 LEX1 / foot_1 \
1554 / /LEX1 / foot_2 \
1555 / ; /LEX1 / Device_2 \
1556 / /call ERROR syntax_footproc NEXT_STMT / Device_2 \
1557
1558 foot_1
1559 / $ <ident>
1560 /LEX1 prent.footproc = prent.footproc || "$" || token_value
1561 LEX1 /\
1562
1563 foot_2
1564 / <fam_mem>
1565 /LEX2 FootFamily = font_fam;
1566 FootMember = font_mem / foot_3 \
1567 / / / foot_e \
1568 foot_3
1569 / ; /LEX1 / Device_2 \
1570 foot_e
1571 / /call ERROR syntax_footproc NEXT_STMT / Device_2 \
1572
1573 viewselect
1574 / <is_viewname>
1575 / default_view = token.Nvalue;
1576 this_view = -1
1577 LEX1 PUSH viewsel1call push "viewsel1" / mc_string \
1578 viewselect_err
1579 / /call ERROR syntax_viewselect NEXT_STMT / Device_2 \
1580 viewsel1
1581 / / med_sel_tab.ref_r default_view = rel find_str 2 /\
1582 / ; /LEX1 / Device_2 \
1583 / /LEX1 / viewselect \
1584 / / / viewselect_err \
1585 ++*/
1586 %page;
1587 compdv:
1588 proc;
1589
1590 dcl version char 10 var static options constant init "2.0a";
1591 dcl compdv_severity_
1592 fixed bin 35 ext static;
1593
1594 compstat$compconst.ptr = addr compstat$compconst.ptr;
1595 dt_sw = "0"b;
1596
1597 /* initialize static on first call in the process */
1598 if first_time
1599 then
1600 do;
1601 breaks ignored_breaks =
1602 substr collate 1 33 || substr collate 128 1;
1603 breaks = breaks || ":$=";
1604 call lex_string_$init_lex_delims """" """" "/*" "*/" ";" "10"b
1605 /* suppress quote keep statement */
1606 breaks ignored_breaks lex_delims lex_ctl_chars;
1607 first_time = "0"b; /* static init done reset switch */
1608 end;
1609
1610 /* ******************** PROCESS COMMAND LINE******************** */
1611
1612 call cu_$arg_count nargs; /* how many given? */
1613
1614 compdv_severity_ = 5; /* preset for command parser */
1615
1616 if nargs = 0 /* if none are given ... */
1617 then
1618 do;
1619 call com_err_ 0 "compdv"
1620 "Vers. ^a Proper usage is: compdv"
1621 || " <input_pathname>.compdv^/^--check | -ck | -list | -ls"
1622 version;
1623 return;
1624 end; /**/
1625 /* fetch input pathname */
1626 call cu_$arg_ptr 1 argp argl ercd;
1627 if ercd ^= 0
1628 then
1629 do;
1630 call com_err_ ercd "compdv" "Reading input pathname.";
1631 return;
1632 end;
1633
1634 if search "<>" arg = 0 /* if a search is needed */
1635 then
1636 do; /* check entry name length */
1637 if length before arg ".compdv" > 25
1638 then
1639 do;
1640 call com_err_ 0 "compdv" "Input entryname ""^a"" is too long"
1641 rtrim arg;
1642 return;
1643 end;
1644
1645 ename = before arg ".compdv";/* strip the suffix */
1646
1647 call search_paths_$find_dir "compose"
1648 /* use compose list */
1649 null rtrim ename || ".compdv" "" dname ercd;
1650 if ercd ^= 0
1651 then
1652 do;
1653 call com_err_ ercd "compdv" "Searching for ""^a"""
1654 rtrim ename || ".compdv";
1655 return;
1656 end;
1657 end;
1658
1659 else
1660 do;
1661 call expand_pathname_$add_suffix arg "compdv" dname ename ercd;
1662 if ercd ^= 0
1663 then
1664 do;
1665 call com_err_ ercd "compdv" "Expanding path for ""^a"""
1666 rtrim arg;
1667 return;
1668 end; /**/
1669 /* trim the suffix */
1670 ename = before ename ".compdv";
1671 end;
1672
1673 check_opt list_opt = "0"b; /* reset option flags */
1674
1675 if nargs > 1 /* any control args? */
1676 then
1677 do;
1678 call cu_$arg_ptr 2 argp argl ercd;
1679 if ercd ^= 0
1680 then
1681 do;
1682 call com_err_ ercd "compdv" "Reading control argument.";
1683 return;
1684 end;
1685
1686 if arg = "-check" | arg = "-ck"
1687 then check_opt = "1"b;
1688
1689 else if arg = "-list" | arg = "-ls"
1690 then list_opt = "1"b;
1691
1692 else
1693 do;
1694 call com_err_ error_table_$badopt "compdv" """^a""" arg;
1695 return;
1696 end;
1697 end;
1698
1699 call hcs_$initiate_count dname rtrim ename || ".compdv" ""
1700 input_bitcount 0 input_ptr ercd;
1701 if input_ptr = null
1702 then
1703 do;
1704 call com_err_ ercd "compdv" "Initiating ^a>^a.compdv"
1705 rtrim dname rtrim ename;
1706 return;
1707 end;
1708
1709 on condition cleanup call cleaner;/* we now need cleaning */
1710
1711 input_charcount = divide input_bitcount 9 24 0;
1712
1713 call translator_temp_$get_segment "compdv" lex_temp_ptr ercd;
1714 if ercd ^= 0 /* get a temp seg for lex_string_ */
1715 then
1716 do;
1717 call com_err_ ercd "compdv" "Getting a translator temp seg.";
1718 call cleaner;
1719 return;
1720 end;
1721
1722 call get_temp_segments_ "compdv" temp_ptrs ercd;
1723 if ercd ^= 0
1724 then
1725 do;
1726 call com_err_ ercd "compdv" "Getting temp segments";
1727 call cleaner;
1728 return;
1729 end;
1730
1731 /* ******************** INITIALIZE FOR EXECUTION ******************** */
1732
1733 call ioa_ "COMPDV ^a-^d" version comp_dvid_version;
1734
1735 compdv_severity_ = 0; /* clear for execution */
1736 dcl_l_p * = null ;
1737 next_str_p = ptr string_area_p 1;/* next string definition */
1738 size_list_p = null ;
1739
1740 area_free_p = area2_p; /* next symbol declaration */
1741 mediachars_p = null ; /* good housekeeping */
1742 media_p = null ;
1743 view_p = null ;
1744 Def_p = null ;
1745
1746 dvid_ct = 0;
1747 dvidl_p * = null ;
1748 dvt_ct = 0;
1749 dvtl_p * = null ;
1750
1751 font_count = 0;
1752 member_ptr = null ;
1753 fntl_p * = null ;
1754 meml_p * = null ;
1755 unil_p * = null ;
1756 opul_p * = null ;
1757
1758 the_string = "";
1759 if rel find_str 1
1760 then ; /* put null string as first */
1761 if rel find_str 2
1762 then ; /* string table entries */
1763
1764 ArtProc FootProc OutProc DisplayProc OutEntry =
1765 rtrim ename || "_writer_";
1766 FootFamily FootMember = "";
1767 Com_r Clean_r = "0"b;
1768 Vscale = vscales 6; /* default to points */
1769 Hscale = hscales 6;
1770
1771 if input_charcount = 0
1772 then
1773 do;
1774 code = error_table_$zero_length_seg;
1775 goto empty_seg;
1776 end;
1777
1778 call lex_string_$lex input_ptr input_charcount 0 lex_temp_ptr "1000"b
1779 """" """" "/*" "*/" ";" breaks ignored_breaks lex_delims
1780 lex_ctl_chars null first_token_p code;
1781 if code ^= 0
1782 then
1783 do;
1784 empty_seg:
1785 if code = error_table_$zero_length_seg
1786 then call com_err_ 0 "compdv"
1787 "Source contains no statements. ^a>^a.compdv." dname ename
1788 ;
1789 else call com_err_ code "compdv"
1790 "^a does not end with a statement delimiter."
1791 pathname_ dname ename;
1792 call cleaner;
1793 return;
1794 end;
1795
1796 Ptoken Pthis_token = first_token_p;
1797 ^L
1798 /* ***************************** GO ***************************** */
1799 call SEMANTIC_ANALYSIS;
1800 compdv_severity_ = MERROR_SEVERITY;
1801
1802 if MERROR_SEVERITY < 3
1803 then
1804 do;
1805 dvid_p = dvidl_p 1;
1806 ename = rtrim dvid.refname || ".comp_dsm";
1807 call iox_$attach_name "comp_gen_" ALM
1808 "vfile_ " || rtrim ename || ".alm" null code;
1809 call iox_$open ALM 2 "0"b code;
1810 call outputter;
1811 call iox_$close ALM code;
1812 call iox_$detach_iocb ALM code;
1813
1814 if ^check_opt
1815 then
1816 do;
1817 if list_opt
1818 then call alm ename "-list";
1819 else call alm ename;
1820
1821 do dvid_p = dvidl_p 1 repeat dvid.next
1822 while dvid_p ^= null ;
1823 call hcs_$chname_file get_wdir_ ename ""
1824 rtrim dvid.refname || ".comp_dsm" code;
1825 if code = error_table_$segnamedup
1826 then code = 0;
1827 if code ^= 0
1828 then call com_err_ code "compdv"
1829 "Trying to add name ^a.comp_dsm to ^a>^a"
1830 dvid.refname get_wdir_ ename;
1831 end;
1832 end;
1833 end;
1834
1835 call cleaner;
1836 return;
1837 ^L
1838 /**** +++Syntax Function++++++++ A_DEBUG +++++++++++++++++++++++++++++++++ */
1839 /* */
1840 /* This routine helps in debugging. To use it a change must be made to the */
1841 /* output of rdc before compilation. At the label RD_MATCH this must be put: */
1842 /* if db_sw then call a_debug; */
1843
1844 a_debug:
1845 proc;
1846 call ioa_$nnl " ""^a""" token_value;
1847 if token_value = "" | token_value = ";"
1848 then call ioa_$nnl "^/";
1849 end a_debug;
1850
1851 /**** +++Function+++++++++++++++ ADDR_INC ++++++++++++++++++++++++++++++++ */
1852 /* */
1853 /* this is an addrel function which increments by double words */
1854 addr_inc:
1855 proc a_ptr an_inc returns ptr;
1856
1857 dcl a_ptr ptr
1858 an_inc fixed bin 24;
1859
1860 return addrel a_ptr divide an_inc + 1 2 17 0 * 2;
1861 end addr_inc;
1862
1863 /**** +++Syntax Function++++++++ CHARLIST ++++++++++++++++++++++++++++++++ */
1864 /* */
1865 /* Tests for the chars of a quoted string being defined charnames. Each */
1866 /* entry processes the next char in the list. */
1867 /* USES: token_value - current token */
1868 /* list_ndx - character to process this time */
1869 /* SETS: token.Nvalue - index of found charname */
1870
1871 charlist:
1872 proc returns bit 1 aligned;
1873
1874 dcl i fixed bin;
1875
1876 if list_ndx > length token_value
1877 then return "0"b;
1878 media2 = "" || substr token_value list_ndx 1 || "";
1879
1880 do i = 1 to mediachars.count; /* look thru the mediachars list */
1881 if mediachars.name i = media2
1882 then
1883 do;
1884 token.Nvalue = i;
1885 if dt_sw
1886 then call ioa_$nnl "<charlist-^i>" list_ndx;
1887 list_ndx = list_ndx + 1;
1888 return "1"b;
1889 end;
1890 end;
1891 call ERROR_ not_charname show_name media2 "";
1892 return "0"b;
1893
1894 end charlist;
1895
1896 /**** +++Syntax Function++++++++ CHARNAME ++++++++++++++++++++++++++++++++ */
1897 /* */
1898 /* Tests for the token being a defined charname. */
1899 /* USES: token_value - current token */
1900 /* SETS: token.Nvalue - index of found charname */
1901
1902 charname:
1903 proc returns bit 1 aligned;
1904
1905 dcl i fixed bin;
1906
1907 if input_ /* sets Input if true */
1908 then media2 = "" || Input || "";
1909 else if ident_
1910 then media2 = token_value;
1911 else return "0"b;
1912 do i = 1 to mediachars.count; /* look thru the mediachars list */
1913 if mediachars.name i = media2
1914 then
1915 do;
1916 token.Nvalue = i;
1917 if dt_sw
1918 then call ioa_$nnl "<charname>";
1919 return "1"b;
1920 end;
1921 end;
1922 return "0"b;
1923
1924 end charname;
1925
1926 /**** +++Procedure++++++++++++++ CLEANER +++++++++++++++++++++++++++++++++ */
1927 /* */
1928 /* Does all the needed stuff for conditioncleanup. However doesn't report */
1929 /* any errors since we may be in trouble. */
1930
1931 cleaner:
1932 proc;
1933
1934 if db_sw
1935 then call ioa_ "===cleaner";
1936
1937 call hcs_$terminate_noname input_ptr code;
1938
1939 if lex_temp_ptr ^= null
1940 then call translator_temp_$release_all_segments lex_temp_ptr code;
1941
1942 if temp_ptrs 1 ^= null
1943 then call release_temp_segments_ "compdv" temp_ptrs code;
1944
1945 if ALM ^= null
1946 then
1947 do;
1948 call iox_$close ALM code;
1949 call iox_$detach_iocb ALM code;
1950 ALM = null ;
1951 end;
1952
1953 if ^check_opt
1954 then call delete_$path get_wdir_ rtrim ename || ".alm" "100100"b
1955 "compdv" code;
1956
1957 end cleaner;
1958
1959 /**** +++Syntax Function+++++++++ DCL_ED +++++++++++++++++++++++++++++++++ */
1960
1961 dcl_ed:
1962 proc returns bit 1 aligned;
1963
1964 do dcl_p = dcl_l_p 1 repeat dcl_.next while dcl_p ^= null ;
1965 if dcl_.dcl_name = token_value
1966 then
1967 do;
1968 str_p = addr dcl_.leng;
1969 if dt_sw
1970 then call ioa_$nnl "<dcl_ed>";
1971 return "1"b;
1972 end;
1973 end;
1974 return "0"b;
1975
1976 end dcl_ed;
1977
1978 /**** +++Procedure+++++++++++++++ ERROR_ +++++++++++++++++++++++++++++++++ */
1979 /* */
1980 /* This routine prints error messages which need "non-standard" insertions. */
1981
1982 ERROR_:
1983 proc Nerror Arg1 Arg2;
1984
1985 dcl Nerror fixed bin
1986 Arg1 char * /* The need is currently for 2 */
1987 Arg2 char *; /* arguments may need expansion. */
1988
1989 dcl Pstmt ptr
1990 1 erring_token aligned based Perring_token like token
1991 Perring_token ptr
1992 erring_token_value
1993 char erring_token.Lvalue based erring_token.Pvalue;
1994 dcl lex_error_ entry options variable;
1995
1996 Perring_token = Pthis_token;
1997
1998 if error_control_table.Soutput_stmt Nerror
1999 then Pstmt = erring_token.Pstmt; /* addr statement descriptor. */
2000 else Pstmt = null ;
2001
2002 call lex_error_ Nerror SERROR_PRINTED Nerror
2003 error_control_table.severity Nerror MERROR_SEVERITY Pstmt
2004 null SERROR_CONTROL error_control_table.message Nerror
2005 error_control_table.brief_message Nerror Arg1 Arg2;
2006
2007 compdv_severity_ =
2008 max compdv_severity_ error_control_table.severity Nerror;
2009 end ERROR_;
2010
2011 /**** +++Syntax Function++++++++ FAM_MEM +++++++++++++++++++++++++++++++++ */
2012
2013 fam_mem:
2014 proc returns bit 1 aligned;
2015
2016 if token.quoted_string /* quoted string? */
2017 | token_value = "SELF" /* the reserved word? */
2018 then return "0"b; /* any of these return false */
2019 /* extract the first name */
2020 font_fam = before token_value "/";
2021 if font_fam = "" /* no family given */
2022 then return "0"b; /**/
2023 /* extract possible second name */
2024 font_mem = after token_value "/";/* invalid names? */
2025 if verify font_fam az_AZ09 ^= 0 | verify font_mem az_AZ09 ^= 0
2026 | search font_fam "0123456789_" = 1
2027 | search font_mem "0123456789_" ^= 0
2028 then return "0"b;
2029
2030 if index token_value "/" ^= 0
2031 then
2032 do;
2033 font_mem = "/" || rtrim font_mem;
2034 font_fam = translate font_fam az AZ;
2035 font_mem = translate font_mem az AZ;
2036 end;
2037
2038 if dt_sw
2039 then call ioa_$nnl "<fam_mem>";
2040
2041 return "1"b;
2042
2043 end fam_mem;
2044
2045 /**** +++Syntax Function++++++++ FAM_BACH ++++++++++++++++++++++++++++++++ */
2046
2047 fam_bach:
2048 proc returns bit 1 aligned;
2049
2050 dcl i fixed bin;
2051 dcl name char 32;
2052
2053 if token.quoted_string /* quoted string? */
2054 | token_value = "SELF" /* the reserved word? */
2055 then return "0"b; /* any of these return false */
2056 /* invalid names? */
2057 if verify token_value az_AZ09 ^= 0
2058 | search token_value "0123456789_" = 1
2059 then return "0"b;
2060
2061 if ^bach_sw
2062 then name = translate token_value az AZ;
2063 else name = token_value;
2064
2065 do i = 1 to comp_dvt.family_ct;
2066 if name = comp_dvt.family i.name
2067 then
2068 do;
2069 call ERROR duplicate_font_name;
2070 return "0"b;
2071 end;
2072 end;
2073
2074 if dt_sw
2075 then call ioa_$nnl "<fam_bach>";
2076
2077 return "1"b;
2078
2079 end fam_bach;
2080
2081 /**** +++Function++++++++++++++ FIND_FONT ++++++++++++++++++++++++++++++++ */
2082
2083 find_font:
2084 proc create returns ptr;
2085
2086 /* PARAMETERS */
2087
2088 dcl create bit 1; /* 1 = font is to be created */
2089
2090 /* LOCAL STORAGE */
2091
2092 dcl tp ptr;
2093 dcl fname char 32;
2094
2095 if db_sw
2096 then call ioa_ "===find_font";
2097
2098 fname = token_value;
2099 if token_value = "SELF" /* can't use "SELF" as a font name */
2100 | token.quoted_string /* can't be a literal */
2101 | octal_ /* or an octal value */
2102 | num /* or a numeric */
2103 then
2104 do;
2105 if create
2106 then goto bad_news;
2107 return null ;
2108 end; /* go thru all defined fonts */
2109 do tp = fntl_p 1 repeat tp -> fnt.next while tp ^= null ;
2110 if tp -> fnt.name = token_value /* is this the one we want? */
2111 then return tp; /* YES return its addr */
2112 end;
2113
2114 if ^create /* not found; if not creating */
2115 then return null; /* return a null value */
2116
2117 if ^ident_ /* but must be a legal name */
2118 then
2119 do;
2120 bad_news:
2121 call ERROR not_valid_Font_name;
2122 fname = ""; /* supply something */
2123 end;
2124
2125 if font_count > 0
2126 then area_free_p = addr_inc oput_p size oput;
2127 tp = area_free_p;
2128 area_free_p = addr tp -> fnt.dummy;
2129 font_count = font_count + 1; /* record new font info */
2130 call link fntl_p tp;
2131 tp -> fnt.name = fname; /* fill in the internal font name */
2132 tp -> fnt.refno = font_count; /* and the reference # */
2133 tp -> fnt.node = Ptoken; /* keep statement ptr for error msgs */
2134 tp -> fnt.pt = null ; /* no table started yet */
2135
2136 return tp; /* return the new addr */
2137
2138 end find_font;
2139
2140 /**** +++Function+++++++++++++++ FIND_STR ++++++++++++++++++++++++++++++++ */
2141 /* */
2142 /* Finds the location of a string in a string table. If the string is not */
2143 /* in the table then it is entered. */
2144
2145 find_str:
2146 proc which returns ptr;
2147
2148 dcl which fixed bin; /* 1- temporary string area */
2149 /* 2- DSM string area */
2150
2151 dcl i fixed bin;
2152
2153 if dt_sw
2154 then call ioa_$nnl "`^a'" the_string;
2155 if string_l which > 0 & length the_string = 0
2156 then
2157 do;
2158 if dt_sw
2159 then call ioa_ "--is ^i1" which;
2160 return strl_p which 1;
2161 end;
2162
2163
2164 do i = 1 to string_l which;
2165 str_p = strl_p which i;
2166 if length bstr.str = length the_string
2167 then if bstr.str = the_string
2168 then
2169 do;
2170 if dt_sw
2171 then call ioa_ "--found ^i^i" which i;
2172 return str_p;
2173 end;
2174 end;
2175 str_p = next_str_p;
2176 bstr.leng = length the_string;
2177 bstr.str = the_string;
2178 string_l which i = string_l which + 1;
2179 strl_p which i = str_p;
2180 next_str_p = addr bstr.dummy;
2181 if dt_sw
2182 then call ioa_ "--new ^i^i" which i;
2183 return strl_p which i;
2184
2185 end find_str;
2186
2187 /**** +++Syntax Function+++++++ FONT_NAME ++++++++++++++++++++++++++++++++ */
2188 /* */
2189 /* Test for token being a defined fontname. */
2190
2191 font_name:
2192 proc returns bit 1 aligned;
2193
2194 the_font = find_font "0"b;
2195 if the_font ^= null
2196 then
2197 do;
2198 if dt_sw
2199 then call ioa_$nnl "<font_name>";
2200 return "1"b;
2201 end;
2202 the_font = fntl_p 1; /* fill in a value so program will */
2203 /* keep running */
2204 return "0"b;
2205
2206 end font_name;
2207
2208 /**** +++Syntax Function++++++ IDENT/IDENT2 ++++++++++++++++++++++++++++++ */
2209 /* */
2210 /* check for legal <name> string */
2211
2212 ident:
2213 proc returns bit 1 aligned;
2214
2215 ldt_sw = dt_sw;
2216 goto start;
2217
2218 ident2:
2219 entry returns bit 1 aligned;
2220
2221 ldt_sw = dt_sw;
2222 if token.Lvalue = 1
2223 then return "0"b;
2224 goto start;
2225
2226 ident_:
2227 entry returns bit 1 aligned;
2228
2229 ldt_sw = "0"b; /* never db displays */
2230
2231 dcl ldt_sw bit 1;
2232
2233 start:
2234 if token.quoted_string /* quoted string? */
2235 | token_value = "SELF" /* the reserved word? */
2236 | verify token_value az_AZ09 ^= 0
2237 /* non-alphanumeric or _? */
2238 then return "0"b; /* any of these return false */
2239
2240 if index "0123456789_" substr token_value 1 1 ^= 0
2241 then return "0"b;
2242 if ldt_sw
2243 then call ioa_$nnl "<ident>";
2244 return "1"b; /* must not have leading number or _ */
2245 end ident;
2246
2247 /**** +++Syntax Function++++ INPUT/ALL_INPUT +++++++++++++++++++++++++++++ */
2248 /* */
2249 /* Tests for token being a single char in either octal or quoted form. */
2250 /* ALL_INPUT also checks for a whole slew of builtin char names. */
2251 /* SETS: Input - 9-bit char value which results */
2252
2253 input:
2254 proc returns bit 1 aligned;
2255
2256 dcl which char 12;
2257 dcl ldt_sw bit 1;
2258
2259 which = "<input>";
2260 ldt_sw = dt_sw;
2261 goto some;
2262
2263 input_:
2264 entry returns bit 1 aligned;
2265
2266 ldt_sw = "0"b; /* never db displays */
2267 goto some;
2268
2269 all_input:
2270 entry returns bit 1 aligned;
2271
2272 which = "<all_input>";
2273 ldt_sw = dt_sw;
2274
2275 if token_value = "EM"
2276 then Input = EM;
2277
2278 else if token_value = "EN"
2279 then Input = EN;
2280
2281 else if token_value = "THICK"
2282 then Input = THICK;
2283
2284 else if token_value = "MEDIUM"
2285 then Input = MEDIUM;
2286
2287 else if token_value = "THIN"
2288 then Input = THIN;
2289
2290 else if token_value = "HAIR"
2291 then Input = HAIR;
2292
2293 else if token_value = "DEVIT"
2294 then Input = DEVIT;
2295
2296 else if token_value = "STROKE"
2297 then Input = STROKE;
2298
2299 else if token_value = "EM-"
2300 then Input = EMdash;
2301
2302 else if token_value = "EN-"
2303 then Input = ENd;
2304
2305 else if token_value = "EM_"
2306 then Input = EM_;
2307 else if token_value = "EN_"
2308 then Input = EN_;
2309 else if token_value = "^0"
2310 then Input = sup0;
2311 else if token_value = "^1"
2312 then Input = sup1;
2313 else if token_value = "^2"
2314 then Input = sup2;
2315 else if token_value = "^3"
2316 then Input = sup3;
2317 else if token_value = "^4"
2318 then Input = sup4;
2319 else if token_value = "^5"
2320 then Input = sup5;
2321 else if token_value = "^6"
2322 then Input = sup6;
2323 else if token_value = "^7"
2324 then Input = sup7;
2325 else if token_value = "^8"
2326 then Input = sup8;
2327 else if token_value = "^9"
2328 then Input = sup9;
2329 else if token_value = "''"
2330 then Input = rquote;
2331 else if token_value = "``"
2332 then Input = lquote;
2333 else if token_value = "PS"
2334 then Input = PS;
2335 else if token_value = "lslnt"
2336 then Input = lslnt;
2337 else if token_value = "vrule"
2338 then Input = vrule;
2339 else if token_value = "bullet"
2340 then Input = bullet;
2341 else if token_value = "cright"
2342 then Input = cright;
2343 else if token_value = "modmark"
2344 then Input = modmark;
2345 else if token_value = "delmark"
2346 then Input = delmark;
2347 else if token_value = "multiply"
2348 then Input = multiply;
2349 else if token_value = "nabla"
2350 then Input = nabla;
2351 else if token_value = "pl_mi"
2352 then Input = pl_mi;
2353 else
2354 some:
2355 if token.quoted_string
2356 then
2357 do;
2358 if token.Lvalue ^= 1
2359 then return "0"b;
2360 Input = token_value;
2361 end;
2362 else if ^octal_
2363 then return "0"b;
2364 if ldt_sw
2365 then call ioa_$nnl "^a" which;
2366 return "1"b;
2367
2368 end input;
2369
2370 /**** +++Syntax Function+++++++ IS_DEFNAME +++++++++++++++++++++++++++++++ */
2371 /* */
2372 /* Tests for a token being a defined Defname. */
2373 /* SETS: token.Nvalue - index of the found Defname */
2374
2375 is_Defname:
2376 proc returns bit 1 aligned;
2377
2378 do i = 1 to Def.count;
2379 if Def.name i = token_value
2380 then
2381 do;
2382 token.Nvalue = i;
2383 if dt_sw
2384 then call ioa_$nnl "<is_Defname>";
2385 return "1"b;
2386 end;
2387 end;
2388 return "0"b;
2389
2390 end is_Defname;
2391
2392 /**** +++Syntax Function++++++ IS_VIEWNAME +++++++++++++++++++++++++++++++ */
2393 /* */
2394 /* Tests for token being a defined viewname. */
2395 /* SETS: token.Nvalue - index of the found viewname */
2396
2397 is_viewname:
2398 proc returns bit 1 aligned;
2399
2400 do i = 1 to view.count;
2401 if view.name i = token_value
2402 then
2403 do;
2404 token.Nvalue = i;
2405 if dt_sw
2406 then call ioa_$nnl "<is_viewname>";
2407 return "1"b;
2408 end;
2409 end;
2410 return "0"b;
2411
2412 end is_viewname;
2413
2414 /**** +++Procedure++++++++++++++++ LINK ++++++++++++++++++++++++++++++++++ */
2415 /* */
2416 /* link an element to end of a list */
2417
2418 link:
2419 proc l_p e_p;
2420 dcl l_p 2 ptr /* begin/end list ptrs */
2421 e_p ptr; /* element to be linked */
2422
2423 dcl next ptr based e_p; /* first word of element -> next */
2424
2425 if l_p 1 = null
2426 then l_p * = e_p; /* initialize list */
2427 else
2428 do;
2429 l_p 2 -> next = e_p; /* last one points to this one */
2430 l_p 2 = e_p; /* this one is now last */
2431 end;
2432 next = null ; /* this one points nowhere */
2433
2434 end link;
2435
2436 /**** +++Syntax Function+++++++ MEDIANAME ++++++++++++++++++++++++++++++++ */
2437 /* */
2438 /* Test for the token being a defined medianame */
2439 /* SETS: token.Nvalue - the index of the found medianame */
2440
2441 medianame:
2442 proc returns bit 1 aligned;
2443
2444 dcl i fixed bin;
2445
2446 if ^ident_
2447 then return "0"b;
2448 do i = 1 to media.count;
2449 if media.name i = token_value
2450 then
2451 do;
2452 token.Nvalue = i;
2453 if dt_sw
2454 then call ioa_$nnl "<medianame>";
2455 return "1"b;
2456 end;
2457 end;
2458 return "0"b;
2459
2460 end medianame;
2461
2462 /**** +++Syntax Function+++++++ MEMBERNAME +++++++++++++++++++++++++++++++ */
2463
2464 membername:
2465 proc returns bit 1 aligned;
2466
2467 dcl i fixed bin;
2468
2469 if substr token_value 1 1 ^= "/"
2470 then return "0"b;
2471 if token.Lvalue > 32
2472 then return "0"b;
2473 if token.Lvalue > 1
2474 then
2475 do;
2476 if index "0123456789" substr token_value 2 1 ^= 0
2477 then return "0"b;
2478 if verify substr token_value 2 az_AZ09 ^= 0
2479 then return "0"b;
2480 end;
2481 if dt_sw
2482 then call ioa_$nnl "<membername>";
2483 return "1"b;
2484
2485 end membername;
2486
2487 /**** +++Syntax Function+++++++++ NEGNUM +++++++++++++++++++++++++++++++++ */
2488 /* */
2489 /* Tests token for being a negative number */
2490
2491 negnum:
2492 proc returns bit 1 aligned; /* check negative decimal value */
2493
2494 if substr token_value 1 1 ^= "-"
2495 /* must start with - sign */
2496 then return "0"b;
2497 if token_value = "-." /* just in case they throw a curve */
2498 then return "0"b;
2499 if verify substr token_value 2 "0123456789." ^= 0
2500 /* and have */
2501 then return "0"b; /* only legal decimal chars & */
2502 if index after token_value "." "." ^= 0
2503 /* only 1 decimal pt */
2504 then return "0"b;
2505 if dt_sw
2506 then call ioa_$nnl "<negnum>";
2507 token.Nvalue = convert token.Nvalue token_value;
2508 return "1"b;
2509
2510 end negnum;
2511
2512 /**** +++Syntax Function+++++++ NUM/LIMIT ++++++++++++++++++++++++++++++++ */
2513 /* */
2514 /* Tests token for being UNLIMITED or being a number */
2515 /* Tests token for being a number */
2516
2517 limit:
2518 proc returns bit 1 aligned;
2519
2520 if token_value = "unlimited"
2521 then
2522 do;
2523 token.Nvalue = -1;
2524 return "1"b;
2525 end;
2526
2527 num:
2528 entry returns bit 1 aligned; /* check decimal value */
2529
2530 if token_value = "."
2531 then return "0"b;
2532 if verify token_value "0123456789." ^= 0
2533 /* legal decimal chars */
2534 then return "0"b;
2535
2536 if index after token_value "." "." ^= 0
2537 /* only 1 dec pt */
2538 then return "0"b;
2539 if dt_sw
2540 then call ioa_$nnl "<num>";
2541 token.Nvalue = convert token.Nvalue token_value;
2542 return "1"b;
2543
2544 end limit;
2545
2546 /**** +++Syntax Function+++++++++ OCTAL ++++++++++++++++++++++++++++++++++ */
2547 /* */
2548 /* Tests token for being an octal character representation */
2549 /* SETS: Input - 9-bit char gotten by converting the 3 octal digits */
2550
2551 octal:
2552 proc returns bit 1 aligned;
2553
2554 ldt_sw = dt_sw;
2555 goto start;
2556
2557 octal_:
2558 entry returns bit 1 aligned;
2559
2560 ldt_sw = "0"b; /* never db displays */
2561
2562 dcl ldt_sw bit 1;
2563 dcl 1 bits 3 unal /* copy of the 3 token chars as bits */
2564 2 f bit 6
2565 2 b bit 3;
2566
2567 start:
2568 if token.Lvalue ^= 3 /* if token is not exactly 3 chars */
2569 then return "0"b; /* it can't be octal */
2570
2571 if verify token_value "01234567" ^= 0
2572 /* it can't have any chars */
2573 then return "0"b; /* outside the octal range */
2574
2575 string bits = unspec token_value;
2576 /* copy token into structure */
2577 unspec Input = b 1 || b 2 || b 3;
2578 /* convert octal to binary */
2579 if ldt_sw
2580 then call ioa_$nnl "<octal>";
2581 return "1"b;
2582
2583 end octal;
2584
2585 /**** +++Procedure+++++++++++++ OUTPUTTER ++++++++++++++++++++++++++++++++ */
2586 /* */
2587 /* Outputs the whole schmeer to an alm source file. */
2588 /* USES: most everything of value */
2589
2590 outputter:
2591 proc;
2592
2593 dcl addname bit 1; /* 1 = table name is an addname */
2594 /**** format: off */
2595 dcl bitname 0:511 char 16 /* char names for tables */
2596 int static options constant init
2597 "000" "001" "002" "003" "004" "005" "006" "007" "010 BSP" "011 HT"
2598 "012 NL" "013 VT" "014 FF" "015 CR" "016" "017" "020" "021 ctl-str"
2599 "022" "023" "024" "025" "026" "027" "030" "031" "032" "033 ESC"
2600 "034" "035" "036" "037" "040 SP" "041 !" "042 """ "043 #" "044 $"
2601 "045 %" "046 &" "047 '" "050 Lp" "051 Rp" "052 *" "053 +" "054 "
2602 "055 -" "056 ." "057 /" "060 0" "061 1" "062 2" "063 3" "064 4"
2603 "065 5" "066 6" "067 7" "070 8" "071 9" "072 :" "073 ;" "074 <"
2604 "075 =" "076 >" "077 ?" "100 @" "101 A" "102 B" "103 C" "104 D"
2605 "105 E" "106 F" "107 G" "110 H" "111 I" "112 J" "113 K" "114 L"
2606 "115 M" "116 N" "117 O" "120 P" "121 Q" "122 R" "123 S" "124 T"
2607 "125 U" "126 V" "127 W" "130 X" "131 Y" "132 Z" "133 " "134 \"
2608 "135 " "136 ^" "137 _" "140 `" "141 a" "142 b" "143 c" "144 d"
2609 "145 e" "146 f" "147 g" "150 h" "151 i" "152 j" "153 k" "154 l"
2610 "155 m" "156 n" "157 o" "160 p" "161 q" "162 r" "163 s" "164 t"
2611 "165 u" "166 v" "167 w" "170 x" "171 y" "172 z" "173 " "174 |"
2612 "175 " "176 ~" "177 PAD" "200" "201" "202" "203" "204" "205"
2613 "206" "207" "210" "211" "212" "213" "214" "215" "216" "217"
2614 "220" "221" "222" "223" "224" "225" "226" "227" "230" "231"
2615 "232" "233" "234" "235" "236" "237" "240" "241" "242" "243"
2616 "244" "245" "246" "247" "250" "251" "252 mlpy" "253 +^H_" "254 nabla"
2617 "255 EMdash" "256" "257 slash" "260" "261 dagger" "262" "263" "264"
2618 "265" "266" "267" "270" "271" "272" "273 _^H|" "274" "275 /^H=" "276"
2619 "277" "300" "301 dbl dagger" "302" "303 copyright" "304 delta" "305"
2620 "306" "307" "310" "311" "312" "313" "314" "315 bullet" "316||"
2621 "317" "320 PI" "321" "322" "323" "324" "325" "326 therefore" "327"
2622 "330" "331" "332 =^H " "333" "334" "335" "336" "337 infinity" "340"
2623 "341" "342" "343" "344" "345" "346" "347" "350" "351" "352 theta"
2624 "353" "354" "355" "356" "357" "360 pi" "361" "362" "363" "364"
2625 "365" "366" "367" "370" "371" "372" "373" "374" "375 square"
2626 "376 overbar" "377 punct SP" "400 superior 0" "401 superior 1"
2627 "402 superior 2" "403 superior 3" "404 superior 4" "405 superior 5"
2628 "406 superior 6" "407 superior 7" "410 superior 8" "411 superior 9"
2629 "412 EM" "413 EM _dash" "414 EN" "415 EN _dash" "416 EN dash"
2630 "417 thin space" "420" "421 ``" "422 ''" "423 1hi X" "424"
2631 "425 v^H|" "426" "427 dia left" "430 delete mark" "431 dia right"
2632 "432 dia top" "433 <" "434 1hi " "435 1hi " "436 left circle" "437"
2633 "440 ->" "441 1hi }" "442 1hi " "443 right circle" "444" "445 ^^H|"
2634 "446" "447" "450" "451" "452" "453" "454" "455" "456" "457"
2635 "460" "461" "462" "463" "464" "465" "466" "467" "470" "471"
2636 "472" "473" "474" "475" "476" "477" "500" "501" "502" "503"
2637 "504" "505" "506" "507" "510" "511" "512" "513" "514" "515"
2638 "516" "517" "520" "521" "522" "523" "524" "525" "526" "527"
2639 "530" "531" "532" "533" "534" "535" "536" "537" "540" "541"
2640 "542" "543" "544" "545" "546" "547" "550" "551" "552" "553"
2641 "554" "555" "556" "557" "560" "561" "562" "563" "564" "565"
2642 "566" "567" "570" "571" "572" "573" "574" "575" "576" "577"
2643 "600" "601" "602" "603" "604" "605" "606" "607" "610" "611"
2644 "612" "613" "614" "615" "616" "617" "620" "621" "622" "623"
2645 "624" "625" "626" "627" "630" "631" "632" "633" "634" "635"
2646 "636" "637" "640" "641" "642" "643" "644" "645" "646" "647"
2647 "650" "651" "652" "653" "654" "655" "656" "657" "660" "661"
2648 "662" "663" "664" "665" "666" "667" "670" "671" "672" "673"
2649 "674" "675" "676" "677" "700" "701" "702" "703" "704" "705"
2650 "706" "707" "710" "711" "712" "713" "714" "715" "716" "717"
2651 "720" "721" "722" "723" "724" "725" "726" "727" "730" "731"
2652 "732" "733" "734" "735" "736" "737" "740" "741" "742" "743"
2653 "744" "745" "746" "747" "750" "751" "752" "753" "754" "755"
2654 "756" "757" "760" "761" "762" "763" "764" "765" "766" "767"
2655 "770" "771" "772" "773" "774" "775" "776" "777");
2656 /**** format: on */
2657
2658 dcl i j fixed bin; /* working index */
2659 dcl oct_p ptr;
2660 dcl jjj fixed bin;
2661 dcl 1 oct based
2662 2 ct fixed bin 35
2663 2 e o_s fixed bin 35;
2664 dcl o_s fixed bin;
2665 dcl out entry automatic options variable;
2666 out = ioa_$ioa_switch; /* to shrink the line size below */
2667
2668 /* This writes things in this sequence: */
2669 /* 1) "include compdv" */
2670 /* 2) comp_dvid segdef's's */
2671 /* 3) comp_dvt member's med_sel's */
2672 /* 4) font's */
2673 /* 5) sizel's */
2674 /* 6) strings ... */
2675 /* 7) "end" */
2676
2677 if db_sw
2678 then call ioa_ "===outputter";
2679
2680 call out ALM "^-include^-compdv";
2681
2682 do dvid_p = dvidl_p 1 repeat dvid.next while dvid_p ^= null ;
2683 if dvid.real
2684 then
2685 do;
2686 call out ALM "^/dvid.^i:" dvid.ndx;
2687 call out ALM "^-dvid.version^-^i" comp_dvid_version;
2688 call out ALM "^-dvid.devname^-^a^i" dvid.devname
2689 length dvid.devname;
2690 call out ALM "^-dvid.dvt_r^-dvt.^i" dvid.dvt_ndx;
2691 end;
2692 call out ALM "^/^-dvid_segdef^-^i^a" dvid.ndx dvid.refname;
2693 end;
2694
2695 do dvt_p = dvtl_p 1 repeat dvt.next while dvt_p ^= null ;
2696 prent_p = dvt.prent;
2697 const.devptr = dvt.ref;
2698 call out ALM "^-even^/dvt.^i:" dvt.ndx;
2699 call out ALM "^-dvt.devclass^-^a^i" comp_dvt.devclass
2700 length comp_dvt.devclass;
2701 call out ALM "^-dvt.outproc^-^a" prent.outproc;
2702 call out ALM "^-dvt.footproc^-^a" prent.footproc;
2703 call out ALM "^-dvt.artproc^-^a" prent.artproc;
2704 call out ALM "^-dvt.displayproc^-^a" DisplayProc || "$display";
2705 call out ALM "^-dvt.min_WS^-^i" comp_dvt.min_WS;
2706 call out ALM "^-dvt.min_lead^-^i" comp_dvt.min_lead;
2707 call out ALM "^-dvt.vmt_min^-^i" comp_dvt.vmt_min;
2708 call out ALM "^-dvt.vmb_min^-^i" comp_dvt.vmb_min;
2709 call out ALM "^-dvt.def_vmt^-^i" comp_dvt.def_vmt;
2710 call out ALM "^-dvt.def_vmh^-^i" comp_dvt.def_vmh;
2711 call out ALM "^-dvt.def_vmf^-^i" comp_dvt.def_vmf;
2712 call out ALM "^-dvt.def_vmb^-^i" comp_dvt.def_vmb;
2713 call out ALM "^-dvt.pdw_max^-^i" comp_dvt.pdw_max;
2714 call out ALM "^-dvt.pdl_max^-^i" comp_dvt.pdl_max;
2715 call out ALM "^-dvt.upshift^-^i" comp_dvt.upshift;
2716 call out ALM "^-dvt.init_ps^-^i" comp_dvt.init_ps;
2717 call out ALM "^-dvt.lettersp^-^i" comp_dvt.lettersp;
2718 call out ALM "^-dvt.max_pages^-^i" comp_dvt.max_pages;
2719 call out ALM "^-dvt.max_files^-^i" comp_dvt.max_files;
2720 call out ALM "^-dvt.init_fam^-^i" comp_dvt.init_fam;
2721 call out ALM "^-dvt.init_mem^-^i" comp_dvt.init_mem;
2722 call out ALM "^-dvt.foot_fam^-^i" comp_dvt.foot_fam;
2723 call out ALM "^-dvt.foot_mem^-^i" comp_dvt.foot_mem;
2724 call out ALM "^-dvt.init_family^-^a^i" comp_dvt.init_family
2725 length comp_dvt.init_family;
2726 call out ALM "^-dvt.init_member^-^a^i" comp_dvt.init_member
2727 length comp_dvt.init_member;
2728 call out ALM "^-dvt.atd_r^2-^a" fmt_str_r comp_dvt.atd_r;
2729 call out ALM "^-dvt.dvc_r^2-dvc^.3b" comp_dvt.dvc_r;
2730 call out ALM "^-dvt.comment_r^-^a" fmt_str_r comp_dvt.comment_r;
2731 call out ALM "^-dvt.cleanup_r^-^a" fmt_str_r comp_dvt.cleanup_r;
2732 call out ALM "^-dvt.medsel_table_r^-med_sel.^d" dvt.ndx;
2733 call out ALM "^-dvt.foot_family^-^a^i" comp_dvt.foot_family
2734 length comp_dvt.foot_family;
2735 call out ALM "^-dvt.foot_member^-^a^i" comp_dvt.foot_member
2736 length comp_dvt.foot_member;
2737 call out ALM "^-dvt.sws^2-^w" string comp_dvt.sws;
2738 call out ALM "^-dvt.open_mode^-.^str^;seq^_out."
2739 comp_dvt.open_mode = 2;
2740 call out ALM "^-dvt.recleng^-^i" comp_dvt.recleng;
2741 call out ALM "^-dvt.family_ct^-^i" comp_dvt.family_ct;
2742
2743 do family_i = 1 to comp_dvt.family_ct;
2744 mem_p = ptr area1_p comp_dvt.family family_i.member_r;
2745 call out ALM "^-dvt..member_r^-mem.^d" mem.refno;
2746 call out ALM "^-dvt..name^2-^a^i" comp_dvt.family family_i.name
2747 32;
2748 end;
2749
2750 call out ALM "^/med_sel.^i:" dvt.ndx;
2751 call out ALM "^-med_sel_tab.count^-^i" view.count;
2752 do med_sel_i = 1 to view.count;
2753 call out ALM "^-med_sel_tab..ref_r^-^a^-^i"
2754 fmt_str_r med_sel_tab.ref_r med_sel_i med_sel_i;
2755 end;
2756 end;
2757
2758 do mem_p = meml_p 1 repeat mem.next while mem_p ^= null ;
2759 if mem.refno = mem.seqno
2760 then
2761 do;
2762 member_ptr = mem.ref_p;
2763 call out ALM "mem.^d:" mem.seqno;
2764 call out ALM "^-member.count^-^i" member.count;
2765 do mem_i = 1 to member.count;
2766 fnt_p = ptr area2_p member.font_r mem_i;
2767 call out ALM "^-member..font_r^-f.^i" fnt.refno;
2768 call out ALM "^-member..size_r^-size.^i"
2769 addr member.size_r mem_i -> bfb;
2770 call out ALM "^-member..Scale^-^i^i" member.Scalex mem_i
2771 member.Scaley mem_i;
2772 call out ALM "^-member..name^-^a^i" member.name mem_i
2773 length member.name mem_i;
2774 end;
2775 end;
2776 end;
2777
2778 call out ALM "^|"; /* eject page before fonts */
2779 do fnt_p = fntl_p 1 repeat fnt.next while fnt_p ^= null ;
2780 font_ptr = fnt.pt;
2781 uni_p = ptr fnt.pt font.units_r;
2782 opu_p = ptr fnt.pt font.oput_r;
2783 call out ALM "f.^i:^2-""^a" fnt.refno fnt.name;
2784 call out ALM "^-font.oput_r^-opu.^i" opu.refno;
2785 call out ALM "^-font.units_r^-uni.^i" uni.refno;
2786 call out ALM "^-font.rel_units^-^i" font.rel_units;
2787 call out ALM "^-font.footsep^-^1a" font.footsep;
2788 call out ALM "^-font.fill^- ";
2789 call out ALM "^-font.min_wsp^-^i" font.min_wsp;
2790 call out ALM "^-font.avg_wsp^-^i" font.avg_wsp;
2791 call out ALM "^-font.max_wsp^-^i" font.max_wsp;
2792 end;
2793
2794 do uni_p = unil_p 1 repeat uni.next while uni_p ^= null ;
2795 if uni.refno = uni.seqno
2796 then
2797 do;
2798 call out ALM "uni.^i:" uni.seqno;
2799 units_ptr = uni.ref_p;
2800 mediawidth = units 0;
2801 dup_ct = 1;
2802 do i = 1 to 511;
2803 if mediawidth = units i
2804 then dup_ct = dup_ct + 1;
2805 else
2806 do;
2807 call out ALM "^-units ^i^0^;^i^" dup_ct
2808 mediawidth = nulwidth mediawidth;
2809 mediawidth = units i;
2810 dup_ct = 1;
2811 end;
2812 end;
2813 call out ALM "^-units ^i^0^;^i^" dup_ct
2814 mediawidth = nulwidth mediawidth;
2815 end;
2816 end;
2817
2818 do opu_p = opul_p 1 repeat opu.next while opu_p ^= null ;
2819 if opu.refno = opu.seqno
2820 then
2821 do;
2822 call out ALM "opu.^i:" opu.seqno;
2823 oput_p = opu.ref_p;
2824 call out ALM "^-oput.data_ct^-^i" oput.data_ct;
2825 skip_ct = 0;
2826 do i = 0 to oput.data_ct;
2827 if oput.what_r i = "0"b
2828 then skip_ct = skip_ct + 1;
2829 else
2830 do;
2831 if skip_ct > 0
2832 then call out ALM "^-no_ch ^i" skip_ct;
2833 skip_ct = 0;
2834 call out ALM "^-ch ^i^a ^null^s^;^i^^-^a"
2835 oput.which i fmt_str_r oput.what_r i
2836 units i = nulwidth units i bitname i;
2837 end;
2838 end;
2839 end;
2840 end;
2841
2842 do i = 1 to size_list.count;
2843 sizel_p = size_list.pt i;
2844 call out ALM "^/size.^i:" i;
2845 call out ALM "^-sizel.val_ct^-^i" sizel.val_ct;
2846 do j = 1 to sizel.val_ct;
2847 call out ALM "^-sizel..val^-^d" sizel.val j;
2848 end;
2849 end;
2850
2851 call out ALM "^/.nul_str.:^-zero";
2852 do j = 2 to string_l 2;
2853 oct_p = strl_p 2 j;
2854 o_s = divide oct_p -> bstr.leng + 3 4 17 0;
2855 if j = 2
2856 then call out ALM "^/str:^-dec^-^d" oct_p -> oct.ct;
2857 else call out ALM "^/^-dec^-^d^2-^a" oct_p -> oct.ct
2858 fmt_str_r rel oct_p;
2859 do jjj = 1 to o_s;
2860 call out ALM "^-oct^-^w^-^a" oct_p -> oct.e jjj
2861 fmt_str_cmt oct_p -> oct.e jjj
2862 oct_p -> oct.ct - 4 * jjj - 1;
2863 end;
2864 end;
2865
2866 call out ALM "^/^-end";
2867
2868 end outputter;
2869
2870 /**** +++ OUTPUTTER UTILITY: FMT_STR_CMT ++++++++++++++++++++++++++++++++++ */
2871
2872 fmt_str_cmt:
2873 proc Oct Len returns char 4 aligned;
2874
2875 dcl Oct fixed bin 35;
2876 dcl Len fixed bin;
2877 dcl idx fixed bin;
2878 dcl str char 4 aligned;
2879
2880 unspec str = unspec Oct;
2881 if Len < 4
2882 then substr str Len + 1 = "";
2883
2884 do idx = 1 to min 4 Len;
2885 if substr str idx 1 = ";"
2886 | rank substr str idx 1 < rank " "
2887 | rank substr str idx 1 > rank "~"
2888 then substr str idx 1 = ".";
2889 end;
2890
2891 return str;
2892
2893 end fmt_str_cmt;
2894
2895 /**** +++ OUTPUTTER UTILITY: FMT_STR_R +++++++++++++++++++++++++++++++++++++ */
2896
2897 fmt_str_r:
2898 proc Rel returns char 9;
2899
2900 dcl Rel bit 18 aligned;
2901 dcl pic picture "99999";
2902
2903 if Rel = ""b
2904 then return ".no_repl.";
2905
2906 if Rel = rel strl_p 2 1
2907 then return ".nul_str.";
2908
2909 pic = binary Rel 18 - wordno strl_p 2 2;
2910 return "str+" || pic;
2911
2912 end fmt_str_r;
2913
2914 /**** +++Syntax Function++++++++++ PART ++++++++++++++++++++++++++++++++++ */
2915
2916 part:
2917 proc returns bit 1 aligned;
2918
2919 /**** format: off */
2920 dcl art_tokens char 388 init /* token string */
2921 " | || o / X d m \ c t " ||
2922 "v ^ <- -> D^ D< D> Dv Clf Crt -str-rul-stp|rul/rul\rul" ||
2923 "tp tp tp tp lptprptp|tp ||tpht ht ht ht lphtrpht|ht ||ht" ||
2924 "md md md md lpmdrpmd|md ||mdhb hb hb hb lphbrphb|hb ||hb" ||
2925 "bt bt bt bt lpbtrpbt|bt ||btfl fl fl fl lpflrpfl|fl ||fl" ||
2926 "PI pi bxtlbxt bxtrbxl bxx bxr bxblbxb bxbrlztllztrlzl lzr lzbllzbr";
2927 dcl art_codes 97 char 1 init /* codes */
2928 art.one 1 art.one 2 art.one 3 art.one 4 art.one 5
2929 art.one 6 art.one 7 art.one 8 art.one 9 art.one 10
2930 art.one 11 art.one 12 art.one 13 art.lslnt cright tmark
2931 art.daro art.uparo art.laro art.raro art.diam.top art.diam.lvert
2932 art.diam.rvert art.diam.bottom art.lcirc art.rcirc art.horiz.start
2933 art.horiz.line art.horiz.term art.vpart art.rslnt art.lslnt
2934 art.top 1 art.top 2 art.top 3 art.top 4 art.top 5
2935 art.top 6 art.top 7 art.top 8 art.half_top 1 art.half_top 2
2936 art.half_top 3 art.half_top 4 art.half_top 5 art.half_top 6
2937 art.half_top 7 art.half_top 8 art.middle 1 art.middle 2
2938 art.middle 3 art.middle 4 art.middle 5 art.middle 6
2939 art.middle 7 art.middle 8 art.half_bottom 1 art.half_bottom 2
2940 art.half_bottom 3 art.half_bottom 4 art.half_bottom 5
2941 art.half_bottom 6 art.half_bottom 7 art.half_bottom 8
2942 art.bottom 1 art.bottom 2 art.bottom 3 art.bottom 4
2943 art.bottom 5 art.bottom 6 art.bottom 7 art.bottom 8
2944 art.other_part 1 art.other_part 2 art.other_part 3
2945 art.other_part 4 art.other_part 5 art.other_part 6
2946 art.other_part 7 art.other_part 8 art.PI art.pi
2947 art.box.tl art.box.t art.box.tr art.box.l art.box.x art.box.r
2948 art.box.bl art.box.b art.box.br art.loz.tl art.loz.tr
2949 art.loz.l art.loz.r art.loz.bl art.loz.br;
2950 /**** format: on */
2951
2952 dcl i fixed bin; /* working index */
2953 dcl part_token char 4; /* token expanded to 4 chars */
2954
2955 part_token = token_value; /* copy the token */
2956
2957 i = index art_tokens part_token; /* scan art tokens */
2958 if i > 0 /* found? */
2959 then
2960 do;
2961 i = divide i 4 17 0 + 1; /* calculate code index */
2962 Input = art_codes i; /* fetch the code */
2963 if dt_sw
2964 then call ioa_$nnl "<part>";
2965 return "1"b; /* return true */
2966 end;
2967
2968 else return "0"b;
2969 end part;
2970
2971 /**** +++Debug Routine+++++++++ PUSH/POP +++++++++++++++++++++++++++++++++ */
2972 /* */
2973
2974 dcl Stack 20 char 16;
2975
2976
2977 /**** +++Function++++++++++++++ SCALE_UNIT +++++++++++++++++++++++++++++++ */
2978 /* */
2979 /* convert units to millipoints */
2980
2981 scale_unit:
2982 proc the_scale returns fixed bin 31;
2983
2984 dcl the_scale fixed bin 31;
2985 dcl pi pt char 10;
2986
2987 if the_scale > 0 /* not pica/point form */
2988 then return the_scale * bin before token_value "."
2989 +
2990 divide the_scale
2991 * bin substr after token_value "." || "000" 1 3 1000
2992 17 0;
2993
2994 return hscales 5 * bin before token_value "."
2995 + hscales 6 * bin after token_value ".";
2996
2997 end scale_unit;
2998
2999 /**** +++Syntax Function++++++++ SIZENAME ++++++++++++++++++++++++++++++++ */
3000
3001 sizename:
3002 proc returns bit 1 aligned;
3003
3004 dcl i fixed bin;
3005
3006 do i = 1 to size_list.count; /* scan sizetable names */
3007 if size_list.name i = token_value
3008 then
3009 do;
3010 token.Nvalue = i; /* set index value */
3011 if dt_sw
3012 then call ioa_$nnl "<sizename>";
3013 return "1"b;
3014 end;
3015 end;
3016
3017 return "0"b;
3018 end sizename;
3019
3020 /**** +++Function++++++++++++++ SHOW_NAME ++++++++++++++++++++++++++++++++ */
3021 /* */
3022 /* converts a MediaChar name into display form if needed. */
3023 show_name:
3024 proc str returns char 32;
3025
3026 dcl str char *;
3027
3028 dcl bits 3 bit 3 unal;
3029 dcl bins 3 fixed bin 3 unsigned unal based addr bits;
3030
3031 if substr str 1 1 ^= "")
3032 then return str;
3033 if substr str 2 1 > " " & substr str 2 1 <= "~"
3034 then return """" || substr str 2 1 || """";
3035 string bits = unspec substr str 2 1;
3036 return substr "01234567" bins 1 + 1 1
3037 || substr "01234567" bins 2 + 1 1
3038 || substr "01234567" bins 3 + 1 1;
3039
3040 end show_name;
3041
3042 /**** +++Syntax Function+++++++++ SWITCH +++++++++++++++++++++++++++++++++ */
3043 /* */
3044 /* check for on/off */
3045 /* SETS: token.Nvalue - 0 off 1 on */
3046 switch:
3047 proc returns bit 1 aligned;
3048
3049 if token_value = "on"
3050 then token.Nvalue = 1;
3051 else if token_value = "off"
3052 then token.Nvalue = 0;
3053 else return "0"b;
3054 if dt_sw
3055 then call ioa_$nnl "<switch>";
3056 return "1"b;
3057
3058 end switch;
3059
3060 /**** +++Syntax Function+++++++ TABLE_NAME +++++++++++++++++++++++++++++++ */
3061
3062 table_name:
3063 proc returns bit 1 aligned;
3064
3065 dcl i fixed bin; /* scan dvid list names */
3066 do dvid_p = dvidl_p 1 repeat dvid.next while dvid_p ^= null ;
3067 if dvid.refname = token_value
3068 then
3069 do;
3070 if dvid.dvt_ndx = dvt_ct + 1
3071 then
3072 do;
3073 call ERROR circular_Device_def;
3074 return "0"b;
3075 end;
3076 token.Nvalue = dvid.dvt_ndx; /* set index value */
3077 if dt_sw
3078 then call ioa_$nnl "<table_name>";
3079 return "1"b;
3080 end;
3081 end;
3082 return "0"b;
3083
3084 end table_name;
3085
3086 /**** +++Syntax Function++++++++ UNITKEY +++++++++++++++++++++++++++++++++ */
3087
3088 unitkey:
3089 proc returns bit 1 aligned;
3090
3091 dcl i fixed bin; /* working index */
3092 dcl unit_key_list 7 char 2 /* list of Units keywords */
3093 static options constant
3094 init "pi" "el" "in" "mm" "pc" "pt" "pp";
3095
3096 do i = 1 to hbound unit_key_list 1
3097 while token_value ^= unit_key_list i;
3098 end;
3099
3100 if i > hbound unit_key_list 1
3101 then
3102 do;
3103 call ERROR inv_Units_keyword;
3104 return "0"b;
3105 end;
3106
3107 token.Nvalue = i;
3108 if dt_sw
3109 then call ioa_$nnl "<unitkey>";
3110 return "1"b;
3111
3112 end unitkey;
3113
3114 /**** +++Syntax Function+++ VALID_DEVICE_NAME ++++++++++++++++++++++++++++ */
3115 /* */
3116 /* Test for token being a valid Device name i.e. an <ident> which is not */
3117 /* already defined as a Device name. */
3118
3119 valid_Device_name:
3120 proc returns bit 1 aligned;
3121
3122 if ^ident_
3123 then return "0"b;
3124 do dvid_p = dvidl_p 1 repeat dvid.next while dvid_p ^= null ;
3125 if token_value = dvid.refname
3126 then
3127 do;
3128 call ERROR dup_Device;
3129 return "0"b;
3130 end;
3131 end;
3132 if dt_sw
3133 then call ioa_$nnl "<valid_Device_name>";
3134 return "1"b;
3135
3136 end valid_Device_name;
3137
3138 /**** +++Syntax Function+++ VALID_MEDIA_NAME ++++++++++++++++++++++++++++ */
3139 /* */
3140 /* Test for token being a valid Media name i.e. an <ident> which is not */
3141 /* already defined as a Media name. */
3142
3143 valid_Media_name:
3144 proc returns bit 1 aligned;
3145
3146 if ^ident_
3147 then return "0"b;
3148 do i = 1 to media.count;
3149 if media.name i = token_value
3150 then
3151 do;
3152 call ERROR dup_Media;
3153 return "0"b;
3154 end;
3155 end;
3156 if dt_sw
3157 then call ioa_$nnl "<valid_Media_name>";
3158 return "1"b;
3159
3160 end valid_Media_name;
3161
3162 save_unref:
3163 if "0"b
3164 then call a_debug;
3165 goto save_unref;
3166
3167 dbs:
3168 entry xxxx;
3169 db_start = xxxx;
3170 return;
3171 dcl xxxx char *;
3172
3173 dbn:
3174 entry;
3175 db_sw = "1"b;
3176 return;
3177 dbf:
3178 entry;
3179 db_sw = "0"b;
3180 return;
3181
3182 dtn:
3183 entry;
3184 dt_sw = "1"b;
3185 return;
3186 dtf:
3187 entry;
3188 dt_sw = "0"b;
3189 return;
3190
3191 trn:
3192 entry;
3193 tr_sw = "1"b;
3194 return;
3195 trf:
3196 entry;
3197 tr_sw = "0"b;
3198 return;
3199 %page;
3200 /* +++++++++++++++++++++++++++ LOOSE VARIABLES +++++++++++++++++++++++++++++ */
3201
3202 dcl ALM ptr init null ;
3203 /* iocb pointer for alm output file */
3204 dcl arg char argl based argp;
3205 /* a command line argument */
3206 dcl argl fixed bin; /* length of arg */
3207 dcl argp ptr; /* pointer to arg */
3208 dcl ArtEntry char 32 var init "artproc";
3209 /* artwork proc entry */
3210 dcl ArtProc char 32 varying;
3211 /* artwork procedure entryname */
3212 dcl Atd_r bit 18 init "000000"b3;
3213 /* default attach descr relp */
3214 dcl attach char 256 var;
3215 dcl AvgWordsp fixed bin init -1;
3216 /* global average wordspace */
3217 dcl az_AZ09 char 64 int static options constant
3218 init "abcdefghijklmnopqrstuvwxyz_"
3219 || "ABCDEFGHIJKLMNOPQRSTUVWXYZ 0123456789";
3220 dcl bach_sw bit 1;
3221 dcl bfb fixed bin 35 based aligned;
3222 dcl bpptr ptr based;
3223 dcl breaks char 128 var static;
3224 /* control string for lex_string_ */
3225 dcl ch1 char 1;
3226 dcl char_val fixed bin;
3227 dcl charid fixed bin;
3228 dcl charid_ fixed bin;
3229 dcl check_opt bit 1 static; /* check mode flag */
3230 dcl cleanup condition;
3231 dcl code fixed bin 35;
3232 dcl Com_r bit 18;
3233 dcl Clean_r bit 18;
3234 dcl db_start char 12 int static init "";
3235 dcl db_sw bit 1 int static init "0"b;
3236 dcl dclname char 8;
3237 dcl default_view fixed bin;
3238 dcl DefVmt fixed bin 31 init 48000;
3239 dcl DefVmh fixed bin 31 init 24000;
3240 dcl DefVmf fixed bin 31 init 24000;
3241 dcl DefVmb fixed bin 31 init 48000;
3242 dcl DevClass char 24 init "typewriter";
3243 /* default device class */
3244 dcl Device_Pthis_token
3245 ptr;
3246 dcl DevName char 24 init "ascii";
3247 /* default device name */
3248 dcl dname char 168; /* name of dir containing ename */
3249 dcl done bit 1;
3250 dcl dt_sw bit 1;
3251 dcl dup_ct fixed bin;
3252 dcl dvt_i fixed bin;
3253 dcl ename char 32; /* input entryname no suffix */
3254 dcl EndPage bit 9 init "0"b;
3255 dcl ercd fixed bin 35; /* error code */
3256 dcl family_i fixed bin;
3257 dcl fd12_8 fixed dec 12 8;
3258 dcl first_time bit 1 static init "1"b;
3259 /* initing control switch */
3260 dcl first_token_p ptr;
3261 dcl font_fam char 32;
3262 dcl font_mem char 32;
3263 dcl FootEntry char 32 varying/* footnote procedure entrypoint */
3264 init "footproc";
3265 dcl footentry char 32;
3266 dcl FootFamily char 32; /* global footnote font family name */
3267 dcl footfamily char 32;
3268 dcl FootMember char 32; /* global footnote font member name */
3269 dcl footmember char 32;
3270 dcl FootProc char 32 varying;
3271 /* footnote procedure entryname */
3272 dcl Footsep char 1 init "";
3273 dcl held_Pthis_token
3274 ptr;
3275 dcl hold_Pthis_token
3276 ptr;
3277 dcl Hscale fixed bin 31; /* global hor scale */
3278 dcl hscale fixed bin 31; /* local hor scale */
3279 dcl hscales 7 fixed bin 31
3280 /* hor scale factors */
3281 static options constant
3282 init 7200 6000 72000 2834.65 12000 1000 0;
3283 dcl i fixed bin;
3284 dcl ignored_breaks char 128 var static;
3285 /* control string for lex_string_ */
3286 dcl ii fixed bin;
3287 dcl iii fixed bin;
3288 dcl initfamily char 32;
3289 dcl initmember char 32;
3290 dcl Input char 1;
3291 dcl input_bitcount fixed bin 24; /* bit count for ename segment */
3292 dcl input_charcount
3293 fixed bin 24; /* char count for ename segment */
3294 dcl input_file char input_charcount
3295 /* source file overlay */
3296 based input_ptr;
3297 dcl input_ptr ptr; /* point to ename segment */
3298 dcl Interleave bit 1 init "0"b;
3299 dcl j fixed bin;
3300 dcl jj fixed bin;
3301 dcl Justify bit 1 init "0"b;
3302 dcl Letterspace fixed bin 31 init 0;
3303 dcl lex_ctl_chars char 128 var static;
3304 /* control string for lex_string_ */
3305 dcl lex_delims char 128 var static;
3306 /* control string for lex_string_ */
3307 dcl lex_temp_ptr ptr init null ;
3308 /* temp seg for lex_string_ */
3309 dcl like_table fixed bin;
3310 dcl list_ndx fixed bin;
3311 dcl list_opt bit 1; /* list option flag */
3312 /* font locator */
3313 dcl loc_font fixed bin 35 based;
3314 dcl
3315 MaxFiles /* global maximum file/reel */
3316 MaxWordsp /* global maximum wordspace */
3317 MaxPages /* global maximum pages/file */
3318 MaxPageLength
3319 fixed bin 31 init -1;
3320 dcl MaxPageWidth fixed bin 31 init 979200;
3321 dcl media1 char 32;
3322 dcl media2 char 32;
3323 dcl mediabase fixed bin;
3324 dcl mediact fixed bin;
3325 dcl mediawidth fixed bin;
3326 dcl media_ char 32;
3327 dcl media_i fixed bin;
3328 dcl 1 member_hold like member.e;
3329 dcl mem_i fixed bin;
3330 dcl med_sel_i fixed bin;
3331 dcl MinLead fixed bin 31 init 7200;
3332 /* global minimum lead */
3333 dcl MinSpace fixed bin 31 init 7200;
3334 dcl MinWordsp fixed bin init -1;
3335 /* global minimum wordspace */
3336 dcl MinVmb fixed bin 31 init 0;
3337 dcl MinVmt fixed bin 31 init 0;
3338 dcl mw fixed bin;
3339 dcl nargs fixed bin; /* command line arg count */
3340 dcl new_family bit 1;
3341 dcl new_member fixed bin;
3342 dcl next_dcl_p ptr;
3343 dcl next_str_p ptr;
3344 dcl nulwidth fixed bin int static options constant init -100000;
3345 dcl o777 char 1 int static options constant init "ÿ";
3346 dcl Openmode fixed bin init 5;
3347 /* opening mode for compout file */
3348 dcl OutEntry char 32 var;
3349 dcl OutProc char 32 var;
3350 dcl DisplayProc char 32 var;
3351 dcl parenct fixed bin; /* next 4 vars for "nmedchars" */
3352 /* and "noutput" */
3353 dcl part_repl 10 fixed bin; /* replication count for a part */
3354 dcl part_str 10 char 400 var;
3355 /* the string for a part */
3356 dcl part_width 10 fixed bin; /* the width of a part */
3357 dcl part_nest fixed bin; /* nesting of parts */
3358 dcl Scale_scale fixed bin 35 int static options constant
3359 init 100000000;
3360 dcl Scale_x fixed bin 35;
3361 dcl Scale_y fixed bin 35;
3362 dcl self_sw bit 1;
3363 dcl self_ct fixed bin; /* number of SELFs in mediachar list */
3364 dcl self_i 16 fixed bin; /* location of these SELFs */
3365 dcl Sizes fixed bin init 0;
3366 dcl skip_ct fixed bin;
3367 dcl string_l 2 fixed bin init 0 0;
3368 dcl Strokes fixed bin init 1;
3369 dcl TapeRec fixed bin init -1;
3370 dcl testwidth fixed bin;
3371 dcl the_font ptr;
3372 dcl the_string char 8000 var;
3373 dcl the_string_r bit 18 aligned;/* offset in string table */
3374 dcl this_view fixed bin;
3375 dcl top_dcl_p ptr init null ;
3376 dcl tp ptr;
3377 dcl tr_sw bit 1 int static init "0"b;
3378 dcl vals_ct fixed bin; /* count of entries in vals array */
3379 dcl vals 1:512 fixed bin;
3380 dcl views_selected fixed bin;
3381 dcl viewname char 32;
3382 dcl Vscale fixed bin 31; /* global vertical scale */
3383 dcl vscale fixed bin 31; /* local vertical scale */
3384 dcl vscales 7 fixed bin 31
3385 /* vertical scale factors */
3386 static options constant
3387 init 12000 9000 72000 2834.65 12000 1000 0;
3388 dcl Wordspace_p ptr init null ;
3389
3390 dcl addr addrel after before bin bit byte collate convert copy
3391 dec dimension divide fixed hbound index length ptr rel size
3392 unspec verify max null rank rtrim search string substr
3393 translate builtin;
3394 %page;
3395 /* ++++++++++++++++++ ERROR CODES & EXTERNAL PROCEDURES ++++++++++++++++++++ */
3396
3397 dcl error_table_$badopt
3398 fixed bin 35 ext static;
3399 dcl error_table_$namedup
3400 fixed bin 35 ext static;
3401 dcl error_table_$segnamedup
3402 fixed bin 35 ext static;
3403 dcl error_table_$zero_length_seg
3404 fixed bin 35 ext static;
3405
3406 dcl alm entry options variable;
3407 dcl az char 26 int static
3408 init "abcdefghijklmnopqrstuvwxyz";
3409 dcl AZ char 26 int static
3410 init "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
3411 dcl com_err_ entry options variable;
3412 dcl cu_$arg_count entry fixed bin;
3413 dcl cu_$arg_ptr entry fixed bin ptr fixed bin fixed 35;
3414 dcl delete_$path entry char * char * bit 6 aligned char *
3415 fixed bin 35;
3416 dcl expand_pathname_$add_suffix
3417 entry char * char * char * char *
3418 fixed 35;
3419 dcl get_temp_segments_
3420 entry char * * ptr fixed bin 35;
3421 dcl get_wdir_ entry returns char 168;
3422 dcl hcs_$chname_file
3423 entry char * char * char * char *
3424 fixed bin 35;
3425 dcl hcs_$initiate_count
3426 entry char * char * char * fixed bin 24
3427 fixed bin 2 ptr fixed bin 35;
3428 dcl hcs_$terminate_noname
3429 entry ptr fixed bin 35;
3430 dcl ioa_$ioa_switch
3431 entry options variable;
3432 dcl iox_$attach_name
3433 entry char * ptr char * ptr fixed bin 35;
3434 dcl iox_$close entry ptr fixed bin 35;
3435 dcl iox_$detach_iocb
3436 entry ptr fixed bin 35;
3437 dcl iox_$open entry ptr fixed bin bit 1 aligned fixed bin 35;
3438 dcl lex_string_$init_lex_delims
3439 entry char * char * char * char * char *
3440 bit * char * var char * var char * var
3441 char * var;
3442 dcl lex_string_$lex
3443 entry ptr fixed bin 24 fixed bin 24 ptr
3444 bit * char * char * char * char *
3445 char * char * var char * var char * var
3446 char * var ptr ptr fixed bin 35;
3447 dcl pathname_ entry char * char * returns char 168;
3448 dcl release_temp_segments_
3449 entry char * * ptr fixed bin 35;
3450 dcl search_paths_$find_dir
3451 entry char * ptr char * char * char *
3452 fixed 35;
3453 dcl translator_temp_$get_segment
3454 entry char * ptr fixed bin 35;
3455 dcl translator_temp_$release_all_segments
3456 entry ptr fixed bin 35;
3457 %page;
3458 /* ++++++++++++++++++++++++++++++ STRUCTURES +++++++++++++++++++++++++++++++ */
3459
3460 dcl temp_ptrs 4 ptr init 4 null ;
3461
3462 /* These 4 segments are used to hold these structures in order: */
3463 /* 1 2 3 4 */
3464 /* strl_p bstr dcl_ */
3465 /* mediachars */
3466 /* media */
3467 /* view */
3468 /* Def */
3469 /* fnt font units oput ... */
3470 /* size_list sizel... */
3471 /* mem dvid... dvt med_sel comp_dvt ... */
3472
3473 dcl strl_p 2 2000 ptr based temp_ptrs 1;
3474 /* list of strings */
3475 dcl string_area_p ptr defined temp_ptrs 2;
3476 /* place to hold strings */
3477 dcl area1_p ptr defined temp_ptrs 3;
3478 dcl area2_p ptr defined temp_ptrs 4;
3479 dcl area_free_p ptr; /* next free location in area2 */
3480
3481 dcl size_list_p ptr;
3482 dcl 1 size_list based size_list_p
3483 2 count fixed bin
3484 2 free ptr /* where to put next list */
3485 2 e 50
3486 3 name char 32 /* name of size list */
3487 3 pt ptr /* point to size list */
3488 2 start ptr; /* start of list area */
3489
3490 /* COMPDV/COMP_DSM STRUCTURE INTERCONNECTION */
3491
3492 /* TABLES USED BY compdv WHILE PARSING */
3493 /* NAMES MARKED WITH * ARE internal ONLY */
3494 /* Tables are generally shown in order generated */
3495 /* except for strings which crop up all over */
3496
3497 /*++
3498 /* dcl_l_p1>----+ */
3499 /* dcl_l_p2>-+ | dcls are made first. */
3500 /* | | dcl_* They are strings which */
3501 /* | | ________ are referenced by name */
3502 /* | +->|next >--+ as an aid to understanding */
3503 /* | |dcl_name| | the DSM definition. They */
3504 /* | |leng | | are not necessary to do */
3505 /* | |dcl_v | | the job. */
3506 /* | |________| | */
3507 /* | +--------------+ Strings used by mediachars are */
3508 /* | | dcl_* temporary i.e. only used by compdv */
3509 /* | | ________ pointers to these go in strl_p1*. */
3510 /* | +->|next >--+ */
3511 /* | |dcl_name| | Strings used by font cleanup etc. */
3512 /* | |leng | | are permanent i.e. they end up in */
3513 /* | |dcl_v | | the DSM pointers to these go in */
3514 /* | |________| | strl_p2*. */
3515 /* | +--------------+ */
3516 /* | | dcl_* strl_p* */
3517 /* | | ________ _________ bstr* */
3518 /* +--+->|next >null |11 |21 >... ____ */
3519 /* |dcl_name| |12 |22 >-------->|leng| */
3520 /* |leng | . . . |str | */
3521 /* |dcl_v | : : : |____| */
3522 /* |________| */
3523
3524 dcl str_p ptr;
3525 dcl 1 bstr based str_p /* based string used for building */
3526 2 leng fixed bin /* pseudo-char_var strings */
3527 2 str char bstr.leng
3528 2 dummy bit 36 aligned;/* where next structure will go */
3529
3530 dcl dcl_l_p 2 ptr; /* dcl_ list begin/end */
3531 dcl dcl_p ptr;
3532 dcl 1 dcl_ based dcl_p /* ** symbol declaration */
3533 2 next ptr /* linked list next element */
3534 2 dcl_name char 8 /* declared name */
3535 2 leng fixed bin /* length of definition string */
3536 2 dcl_v char dcl_.leng/* symbol definition string */
3537 2 dummy ptr; /* where next one is based */
3538 %page;
3539 /* mediachars* */
3540 /* _______ Next all mediachars are defined */
3541 /* |count=n|__ in terms of dcl'ed symbols or */
3542 /* 1|name|out_r>----------+ literals. */
3543 /* 2|name|out_r>... | bstr* */
3544 /* . . . | ____ */
3545 /* : : : +---------------------------->|leng| */
3546 /* n|name|out_r>... |str | */
3547 /* |____|_____| |____| */
3548 dcl mediachars_p ptr;
3549 dcl 1 mediachars based mediachars_p
3550 2 count fixed bin /* how many have been defined */
3551 2 e mediachars.count
3552 3 name char 32 /* name of the char */
3553 3 out_r bit 18 aligned;/* output string to get it */
3554
3555 /* media*
3556 /* _______ Then all media are */
3557 /* ______|count=m|_________ ... ______ described in terms of the */
3558 /* 1|name|rel_units|w11 |w12 |... |w1n | mediachars with the */
3559 /* 2|name|rel_units|w21 |w22 |... | @ | widths being defined for */
3560 /* . . . . . . . each. Values might not */
3561 /* : : : : : : : exist for all mediachars */
3562 /* m|name|rel_units|wm1 | @ |... |wmn | in all media shown as @. */
3563 /* |____|_________|____|____|... |____| */
3564 /* mediachar # --> 1 2 ... n */
3565 dcl media_p ptr;
3566 dcl 1 media based media_p
3567 2 count fixed bin /* how many have been defined */
3568 2 e media.count
3569 3 name char 32 /* name of the media */
3570 3 rel_units
3571 fixed bin /* its stroke value */
3572 3 width mediachars.count fixed bin;
3573 /* for each mediachar */
3574 %page;
3575 /* view* */
3576 /* _______ Views are then made up */
3577 /* |count=k|__ from the defined media. */
3578 /* 1|view1|med4| Views can share a media */
3579 /* 2|view2|med2| but will differ media */
3580 /* . . . select string. Each Device */
3581 /* : : : specifies its own set of */
3582 /* k|viewk|med4| media select strings.
3583 /* |_____|____| */
3584
3585 dcl view_p ptr;
3586 dcl 1 view based view_p
3587 2 count fixed bin /* how many defined */
3588 2 e view.count
3589 3 name char 32 /* viewname */
3590 3 media fixed bin; /* media being referenced */
3591
3592
3593 /* Def* */
3594 /* _______ Def's are a sort of macro definition. */
3595 /* |count=d|_ Whenever a set of Multics chars have the same */
3596 /* 1|name1|pt1| definition in several fonts instead of */
3597 /* 2|name2|pt2| entering the description again and again a */
3598 /* . . . Def is made containing the needed info and */
3599 /* : : : then they are ref'ed in each table as needed. */
3600 /* d|named|ptd| */
3601 /* |_____|___| */
3602
3603 dcl Def_p ptr;
3604 dcl 1 Def based Def_p
3605 2 count fixed bin /* how many Def's present */
3606 2 e Def.count
3607 3 name char 32 /* internal name of this Def */
3608 3 pt ptr; /* Points to the node in the */
3609 /* lex_string_ list at which source */
3610 /* of the Def begins. At ref time */
3611 /* this source will be be re-parsed */
3612 /* via this pointer. */
3613 %page;
3614 /* fntl_p1>----+ */
3615 /* fntl_p2>---)|---------------------+ */
3616 /* +----------+ | */
3617 /* | fnt* fnt* | fnt* */
3618 /* | _____ _____ | _____ */
3619 /* +-->|next >------------>|next >---+-------->|next >null */
3620 /* |name | |name | |name | */
3621 /* |refno| |refno| |refno| */
3622 /* |node >... |node >... |node >... */
3623 /* |pt >---+ |pt >... |pt >... */
3624 /* |_____| | |_____| |_____| */
3625 /* +-------------+ */
3626 /* | font Fonts are made up by selecting one */
3627 /* | _________ or more mediachars from a view and */
3628 /* +-->|units_r >-----+ associating them to Multics input */
3629 /* |oput_r >--+ | characters. To speed up measuring */
3630 /* |rel_units| | | the width portion of the font table */
3631 /* |footsep | | | is a fixed size. */
3632 /* |min_spb | | | To save space however the output */
3633 /* |avg_spb | | | string portion of the font is only */
3634 /* |max_spb | | | as long as the highest Multics char */
3635 /* |_________| | | defined. */
3636 /* +----------------+ | */
3637 /* | opu* | uni* The oput and units */
3638 /* | _____ | _____ units tables often end up */
3639 /* +-->|next >... +-->|next >... _____ looking like others of */
3640 /* |ref_p>---+ |ref_p>------>|0 | their kind. Thus when */
3641 /* |seqno| | |seqno| |1 | each is completed it */
3642 /* |refno| | |refno| . . is matched against all */
3643 /* |_____| | |_____| : : prior ones & logically */
3644 /* +-------------+ |511| removed if already */
3645 /* | oput |_____| there reducing DSM */
3646 /* | ____________ size. */
3647 /* +-->|data_count=k| */
3648 /* 0|which|what_r>... */
3649 /* 1|which|what_r>... From compdv's point of */
3650 /* . . . medchar_sel view medchar_sel is a */
3651 /* : : : ________..._ bstr. */
3652 /* k|which|what_r>------->|len|text... | */
3653 /* |_____|______| |___|________| */
3654 /* */
3655 /* oput.which references an entry in */
3656 /* the Device's med_sel_table. */
3657 %page;
3658 dcl font_count fixed bin; /* # font entries present */
3659 dcl fntl_p 2 ptr; /* begin/end fnt list */
3660 dcl fnt_p ptr;
3661 dcl 1 fnt based fnt_p /* === font info entry */
3662 2 next ptr /* next entry */
3663 2 name char 32 /* internal reference only */
3664 2 refno fixed bin /* internal reference # */
3665 2 node ptr /* rdc node for Font: statement */
3666 /* used for error messages */
3667 2 pt ptr /* points to the font table */
3668 2 dummy ptr; /* where next structure goes */
3669
3670 dcl uni_ct fixed bin init 0;
3671 dcl unil_p 2 ptr;
3672 dcl uni_p ptr;
3673 dcl 1 uni based uni_p /* === units entry */
3674 2 next ptr /* next entry */
3675 2 ref_p ptr /* points to units table */
3676 2 seqno fixed bin /* internal sequence # */
3677 2 refno fixed bin; /* internal reference # */
3678 /* when seqno=refno this is a "real" */
3679 /* entry otherwise it's a duplicate */
3680
3681 dcl opul_p 2 ptr;
3682 dcl opu_p ptr;
3683 dcl 1 opu based opu_p /* === oputs entry */
3684 2 next ptr /* next entry */
3685 2 ref_p ptr /* points to oput table */
3686 2 seqno fixed bin /* internal sequence # */
3687 2 refno fixed bin; /* internal reference # */
3688 /* when seqno=refno this is a "real" */
3689 /* entry otherwise it's a duplicate */
3690
3691 %page;
3692 /* dvid* */
3693 /* _______ */
3694 /* dvidl_p1>-------------->|next >------+ dvid* */
3695 /* dvidl_p2>----------+ |ndx | | _______ */
3696 /* | |real | +--->|next >null */
3697 /* | |refname| | |ndx | */
3698 /* | |devname| | |real | */
3699 /* | |dvt_ndx| | |refname| */
3700 /* | |_______| | |devname| */
3701 /* | | |dvt_ndx| */
3702 /* +-------------------+ |_______| */
3703 dcl comp_dvid_new bit 1; /* a new comp_dvid is being started */
3704 dcl comp_dvid_ct fixed bin init 0;
3705 /* how many actual comp_dvid defined */
3706 dcl dvid_ct fixed bin; /* # dvid entries present */
3707 dcl dvidl_p 2 ptr; /* begin/end of dvid list */
3708 dcl dvid_p ptr;
3709 dcl 1 dvid based dvid_p /* === comp_dvid data */
3710 2 next ptr /* link to next entry */
3711 2 ndx fixed bin /* which dvid being referenced */
3712 2 real bit 1 aligned /* 1- defines a comp_dvid */
3713 2 refname char 32 /* external reference name */
3714 2 devname char 32 /* comp_dvid.devname */
3715 2 dvt_ndx fixed bin /* comp_dvid.dvt_r derived from this */
3716 2 dummy ptr; /* place where next structure goes */
3717
3718 /* This structure contains all the info necessary to generate comp_dvid. */
3719 %page;
3720 /* dvt* */
3721 /* dvtl_p1 >------+ _______ */
3722 /* dvtl_p2 >-----|-------------------------------+---->|next >null */
3723 /* | dvt* | |ndx | */
3724 /* | _______ | |prent >-... */
3725 /* +------>|next >----------------+ |med_sel>--... */
3726 /* |ndx | |ref >-... */
3727 /* |prent >--------+ |_______| */
3728 /* |med_sel>-----+ | */
3729 /* |ref >--+ | | prent* */
3730 /* |_______| | | | __________ */
3731 /* +-------------------------+ | +------------>|outproc | */
3732 /* | | |artproc | */
3733 /* | comp_dvt | med_sel |footproc | */
3734 /* | _________ | _________ |__________| */
3735 /* +---->| details | +-->| details | */
3736 /* | below | | below | */
3737 /* |_________| |_________| */
3738
3739 dcl dvt_ct fixed bin; /* # dvt entries present */
3740 dcl dvtl_p 2 ptr; /* begin/end of dvt list */
3741
3742 dcl dvt_p ptr;
3743 dcl 1 dvt based dvt_p /* === comp_dvt reference info */
3744 2 next ptr /* link to next entry */
3745 2 ndx fixed bin /* which index this represents */
3746 2 prent ptr /* ptr to prent data */
3747 2 med_sel ptr /* ptr to associated med_sel array */
3748 2 ref ptr /* ptr to comp_dvt */
3749 2 dummy ptr; /* place where next structure goes */
3750
3751 dcl prent_p ptr;
3752 dcl 1 prent based prent_p /* === entryname strings comp_dvt */
3753 2 outproc char 68 var
3754 2 artproc char 68 var
3755 2 footproc char 68 var
3756 2 dummy ptr; /* place where next structure goes */
3757
3758 dcl 1 med_sel_tab aligned based dvt.med_sel
3759 2 count fixed bin
3760 2 ref_r med_sel_tab.count bit 18 aligned;
3761 %page;
3762 /* mem* */
3763 /* ______ */
3764 /* meml_p1 >---- +->|next >--+ */
3765 /* meml_p2 >--+ |ref_p > | */
3766 /* | |seqno | | */
3767 /* | |______| | */
3768 /* +---------------+ */
3769 /* | mem* */
3770 /* | ______ member */
3771 /* +--->|next >null _________ */
3772 /* |ref_p >-------->| details | */
3773 /* |seqno | | below | */
3774 /* |______| |_________| */
3775
3776 dcl meml_p 2 ptr; /* begin/end member list */
3777 dcl mem_ct fixed bin init 0;
3778 /* internal sequence counter */
3779 dcl mem_p ptr;
3780 dcl 1 mem based mem_p /* === member table code gen only */
3781 2 next ptr /* next entry */
3782 2 ref_p ptr /* pointer to the member table */
3783 2 seqno fixed bin /* internal sequence # */
3784 2 refno fixed bin /* internal reference # */
3785 /* when seqno=refno this is a "real" */
3786 /* entry otherwise it's a duplicate */
3787 2 dummy ptr; /* where next structure goes */
3788 ^L
3789 /* EXTERNAL INTERCONNECTION in the DSM */
3790 /* linkage */
3791 /* section comp_dvid */
3792 /* ______ +-----------------------------------------+ _______ */
3793 /* | | | +--->| | */
3794 /* |name1 >----+ |devname| */
3795 /* |name2 >---|-------------------+ comp_dvid |dvt_r >--+ */
3796 /* |name3 >----+ comp_dvid | _______ |_______| | */
3797 /* |name4 >--+ _______ +-->| | comp_dvt | */
3798 /* | etc. | +--->| | |devname| ________ | */
3799 /* |______| |devname| |dvt_r >--->| ... | */
3800 /* |dvt_r >--+ |_______| | | */
3801 /* |_______| | | */
3802 /* +-------<----------------+-----------------------------------<-------+ */
3803 /* | comp_dvt */
3804 /* | _____________ bstr */
3805 /* +-->| | ___________ */
3806 /* |atd_r >-------------------------------------->|len|str... | */
3807 /* |dvc_r >... |___|_______| */
3808 /* |med_sel_tab_r>-----------------+ med_sel_tab */
3809 /* | ... | | _______ med_sel */
3810 /* |family_ct=F | +-->|count=K| ___________ */
3811 /* 1|.member_r >--+ 1|ref_r>---------->|len|str... | */
3812 /* 1|.name | | . . |___|_______| */
3813 /* | ... | | n|ref_r>nullo */
3814 /* |_____________| | . . */
3815 /* +---------------+ K|ref_r>... sizel */
3816 /* | member |_____| ________ */
3817 /* | _______ +--------------------------->|val_ct=S| */
3818 /* +-->|count=L|_________|________________ 1|val | */
3819 /* 1|font_r> size_r> | lex|Scaley|name| . . */
3820 /* 2|font_r> size_r>--+ lex|Scaley|name| : : */
3821 /* . . . . . . S|val | */
3822 /* : : : : : : |________| */
3823 /* L|font_r>---+ > Scalex|Scaley|name| */
3824 /* |______|___|___|_______|______|____| */
3825 /* | */
3826 /* +-----------------+ */
3827 /* | font units */
3828 /* | _________ _____ */
3829 /* +-->|units_r >-------------------------------------->|0 | */
3830 /* |oput_r >---+ |1 | */
3831 /* |rel_units| | . . */
3832 /* |footsep | | oput : : */
3833 /* |min_spb | | _________ |511| */
3834 /* |avg_spb | +-->|data_ct=k|__ |_____| */
3835 /* |max_spb | 0|which|what_r>... */
3836 /* |_________| 1|which|what_r>... */
3837 /* . . . medchar_sel */
3838 /* : : : ________..._ */
3839 /* k|which|what_r>--------->|len|text... | */
3840 /* |_____|______| |___|________| */
3841 /* */
3842 /* oput.which references an entry in */
3843 /* the Device's med_sel_table. */
3844 %page;
3845 %include comp_art_parts;
3846 %include comp_metacodes;
3847 %include comp_dvid;
3848 %include comp_dvt;
3849 %include comp_fntstk;
3850 %include comp_font;
3851 %include compstat;
3852 %include compdv_msgs;