summaryrefslogtreecommitdiff
path: root/Build/source/texk/web2c/omegaware
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2006-01-17 21:41:51 +0000
committerKarl Berry <karl@freefriends.org>2006-01-17 21:41:51 +0000
commit487ca4806cc046076293cf6cc5fbba0db282bac7 (patch)
tree847b412ab5158dd7bdd7ed7e5a4cc3fbca94be32 /Build/source/texk/web2c/omegaware
parenta3d3111bfe26b8e5f5bc6049dfb2a4ca2edc7881 (diff)
texk 1
git-svn-id: svn://tug.org/texlive/trunk@1485 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Build/source/texk/web2c/omegaware')
-rw-r--r--Build/source/texk/web2c/omegaware/ChangeLog0
-rw-r--r--Build/source/texk/web2c/omegaware/odvicopy.ch710
-rw-r--r--Build/source/texk/web2c/omegaware/odvicopy.web4688
-rw-r--r--Build/source/texk/web2c/omegaware/odvitype.ch767
-rw-r--r--Build/source/texk/web2c/omegaware/odvitype.web2594
-rw-r--r--Build/source/texk/web2c/omegaware/ofm2opl.ch461
-rw-r--r--Build/source/texk/web2c/omegaware/ofm2opl.web2322
-rw-r--r--Build/source/texk/web2c/omegaware/opl2ofm.ch337
-rw-r--r--Build/source/texk/web2c/omegaware/opl2ofm.web4363
-rw-r--r--Build/source/texk/web2c/omegaware/otangle.ch474
-rw-r--r--Build/source/texk/web2c/omegaware/otangle.web3328
-rw-r--r--Build/source/texk/web2c/omegaware/ovf2ovp.ch610
-rw-r--r--Build/source/texk/web2c/omegaware/ovf2ovp.web3138
-rw-r--r--Build/source/texk/web2c/omegaware/ovp2ovf.ch320
-rw-r--r--Build/source/texk/web2c/omegaware/ovp2ovf.web5071
15 files changed, 29183 insertions, 0 deletions
diff --git a/Build/source/texk/web2c/omegaware/ChangeLog b/Build/source/texk/web2c/omegaware/ChangeLog
new file mode 100644
index 00000000000..e69de29bb2d
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ChangeLog
diff --git a/Build/source/texk/web2c/omegaware/odvicopy.ch b/Build/source/texk/web2c/omegaware/odvicopy.ch
new file mode 100644
index 00000000000..fa490c7b857
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/odvicopy.ch
@@ -0,0 +1,710 @@
+% odvicopy.ch: web2c changes for odvicopy.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original dvicopy.ch.
+%
+% dvicopy.ch for C compilation with web2c.
+% The original version of this file was created by Monika Jayme and
+% Klaus Guntermann at TH Darmstadt (THD), FR Germany.
+% Some parts are borrowed from the changes to dvitype, vftovp and vptovf.
+%
+% July 90 THD First versions for dvicopy 0.91 and 0.92
+% Aug 09 90 THD Updated to dvicopy 1.0 and released
+% Mar 20 91 THD Updated to dvicopy 1.2
+% (more recent changes in the ChangeLog)
+
+@x [0] WEAVE: print changes only
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+\let\maybe=\iffalse
+@z
+
+@x [3] Set up kpathsea.
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+ print (banner); print_ln (version_string);
+@z
+
+@x [5] Big enough arrays to convert the dvilj sample font document.
+@<Constants...@>=
+@!max_fonts=100; {maximum number of distinct fonts}
+@!max_chars=10000; {maximum number of different characters among all fonts}
+@!max_widths=3000; {maximum number of different characters widths}
+@!max_packets=5000; {maximum number of different characters packets;
+ must be less than 65536}
+@!max_bytes=30000; {maximum number of bytes for characters packets}
+@!max_recursion=10; {\.{VF} files shouldn't recurse beyond this level}
+@!stack_size=100; {\.{DVI} files shouldn't |push| beyond this depth}
+@!terminal_line_length=150; {maximum number of characters input in a single
+ line of input from the terminal}
+@!name_length=50; {a file name shouldn't be longer than this}
+@y
+@<Constants...@>=
+@!max_fonts=1000; {maximum number of distinct fonts}
+@!max_chars=750000; {maximum number of different characters among all fonts}
+@!max_widths=10000; {maximum number of different characters widths}
+@!max_packets=100000; {maximum number of different characters packets;
+ must be less than 65536}
+@!max_bytes=3000000; {maximum number of bytes for characters packets}
+@!max_recursion=10; {\.{VF} files shouldn't recurse beyond this level}
+@!stack_size=100; {\.{DVI} files shouldn't |push| beyond this depth}
+@!terminal_line_length=256; {maximum number of characters input in a single
+ line of input from the terminal}
+@z
+
+% [14] Redirect output, so it can go to either stdout or stderr,
+% depending on where the output dvi file is going.
+@x
+@d print(#)==write(output,#)
+@d print_ln(#)==write_ln(output,#)
+@d new_line==write_ln(output) {start new line}
+@y
+@d print(#)==write(term_out,#)
+@d print_ln(#)==write_ln(term_out,#)
+@d new_line==write_ln(term_out) {start new line}
+@z
+
+@x [14] Permissive input.
+@!ASCII_code=" ".."~"; {a subrange of the integers}
+@y
+@!ASCII_code=0..255; {a subrange of the integers}
+@z
+
+% [15] The text_char type is used as an array index into xord. The
+% default type `char' produces signed integers, which are bad array
+% indices in C.
+@x
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=127 {ordinal number of the largest element of |text_char|}
+@y
+@d text_char == ASCII_code {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=255 {ordinal number of the largest element of |text_char|}
+@z
+
+@x [23] Remove non-local goto
+@d abort(#)==begin print_ln(' ',#,'.'); jump_out;
+ end
+
+@<Error handling...@>=
+@<Basic printing procedures@>@;
+procedure close_files_and_terminate; forward;
+@#
+procedure jump_out;
+begin mark_fatal; close_files_and_terminate;
+goto final_end;
+end;
+@y
+@d abort(#)==begin write_ln(stderr, ' ',#,'.'); jump_out;
+ end
+
+@<Error handling...@>=
+@<Basic printing procedures@>@;
+procedure close_files_and_terminate; forward;
+@#
+procedure jump_out;
+begin mark_fatal; close_files_and_terminate;
+uexit(1);
+end;
+@z
+
+@x [51] Fix casting problem in C.
+@d comp_spair(#) == if a<128 then #:=a*256+b @+ else #:=(a-256)*256+b
+@d comp_upair(#) == #:=a*256+b
+@y
+@d comp_spair(#) == if a<128 then #:=a*intcast(256)+b
+ @+ else #:=(a-intcast(256))*intcast(256)+b
+@d comp_upair(#) == #:=a*intcast(256)+b
+@z
+
+@x [52]
+if a<128 then #:=(a*256+b)*256+c @+ else #:=((a-256)*256+b)*256+c
+@d comp_utrio(#) == #:=(a*256+b)*256+c
+@y
+if a<128 then #:=(a*intcast(256)+b)*intcast(256)+c @+
+else #:=((a-intcast(256))*intcast(256)+b)*intcast(256)+c
+@d comp_utrio(#) == #:=(a*intcast(256)+b)*intcast(256)+c
+@z
+
+@x [53]
+if a<128 then #:=((a*256+b)*256+c)*256+d
+else #:=(((a-256)*256+b)*256+c)*256+d
+@y
+if a<128 then #:=((a*intcast(256)+b)*intcast(256)+c)*intcast(256)+d
+else #:=(((a-intcast(256))*intcast(256)+b)*intcast(256)+c)*intcast(256)+d
+@z
+
+@x [62] cur_name is no longer a fixed-size array.
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+@y
+@!cur_name:^char;
+@z
+
+@x [63] Ignore arguments to make_font_name.
+@ For \.{TFM} and \.{VF} files we just append the apropriate extension
+to the file name packet; in addition a system dependent area part
+(usually different for \.{TFM} and \.{VF} files) is prepended if
+the file name packet contains no area part.
+@^system dependencies@>
+
+@d append_to_name(#)==
+ if l_cur_name<name_length then
+ begin incr(l_cur_name); cur_name[l_cur_name]:=#;
+ end
+ else overflow(str_name_length,name_length)
+@d make_font_name_end(#)==
+ append_to_name(#[l]); make_name
+@d make_font_name(#)==
+ l_cur_name:=0; for l:=1 to # do make_font_name_end
+@y
+@ Since files are actually searched through path definitions,
+the area definitions are ignored here.
+To reduce the required changes we simply ignore the parameters given
+to |make_font_name|.
+@^system dependencies@>
+
+@d append_to_name(#)== begin
+ cur_name[l_cur_name]:=#;
+ incr(l_cur_name);
+ end
+@d make_font_name_end(#)==
+ make_name
+@d make_font_name(#)==
+ l_cur_name:=0; make_font_name_end
+@z
+
+% [67] No conversion of filenames in lower case, and initialize and
+% terminate for C strings.
+@x
+cur_loc:=pckt_start[n]; cur_limit:=pckt_start[n+1];
+@y
+cur_name := xmalloc_array (char, pckt_length (n) + pckt_length (e));
+cur_loc:=pckt_start[n]; cur_limit:=pckt_start[n+1];
+@z
+
+@x
+ if (b>="a")and(b<="z") then Decr(b)("a"-"A"); {convert to upper case}
+@y
+@z
+
+@x
+cur_loc:=pckt_start[e]; cur_limit:=pckt_start[e+1];
+while cur_loc<cur_limit do
+ begin pckt_extract(b); append_res_to_name(xchr[b]);
+ end;
+while l_cur_name<name_length do
+ begin incr(l_cur_name); cur_name[l_cur_name]:=' ';
+ end;
+@y Skip copying in the extension, kpathsea knows what to do.
+ cur_name[l_cur_name] := 0;
+@z
+
+@x [92]
+id4(".")("T")("F")("M")(tfm_ext); {file name extension for \.{TFM} files}
+id4(".")("O")("F")("M")(ofm_ext); {file name extension for \.{OFM} files}
+@y
+id4(".")("t")("f")("m")(tfm_ext); {file name extension for \.{TFM} files}
+id4(".")("o")("f")("m")(ofm_ext); {file name extension for \.{OFM} files}
+@z
+
+@x [93] Set default directory name
+@ If no font directory has been specified, \.{\title} is supposed to use
+the default \.{TFM} directory, which is a system-dependent place where
+the \.{TFM} files for standard fonts are kept.
+The string variable |TFM_default_area| contains the name of this area.
+@^system dependencies@>
+
+@d TFM_default_area_name=='TeXfonts:' {change this to the correct name}
+@d OFM_default_area_name=='TeXfonts:' {change this to the correct name}
+@d TFM_default_area_name_length=9 {change this to the correct length}
+@d OFM_default_area_name_length=9 {change this to the correct length}
+
+@<Glob...@>=
+@!TFM_default_area:packed array[1..TFM_default_area_name_length] of char;
+@!OFM_default_area:packed array[1..OFM_default_area_name_length] of char;
+@y
+@ If no font directory has been specified, we search paths.
+@z
+
+@x [94] Remove initialization of now-defunct array
+@ @<Set init...@>=
+TFM_default_area:=TFM_default_area_name;
+OFM_default_area:=OFM_default_area_name;
+@y
+@ (No initialization to be done. Keep this module to preserve numbering.)
+@z
+
+@x [96] Open TFM file
+@<TFM: Open |tfm_file|@>=
+make_font_name(TFM_default_area_name_length)(TFM_default_area)(tfm_ext);
+reset(tfm_file,cur_name);
+if eof(tfm_file) then begin
+ make_font_name(OFM_default_area_name_length)(OFM_default_area)(ofm_ext);
+ reset(tfm_file,cur_name);
+ if eof(tfm_file) then
+@^system dependencies@>
+ abort('---not loaded, TFM or OFM file can''t be opened!')
+ else font_extend(cur_fnt):=true
+@.TFM or OFM file can\'t be opened@>
+ end
+else font_extend(cur_fnt):=false
+@y
+|TFM_default_area_name_length| and |TFM_default_area| will not
+be used by |make_font_name|.
+
+@<TFM: Open |tfm_file|@>=
+make_font_name(TFM_default_area_name_length)(TFM_default_area)(tfm_ext);
+full_name := kpse_find_tfm (cur_name);
+if full_name then begin
+ resetbin (tfm_file, full_name);
+ free (cur_name);
+ free (full_name);
+ font_extend(cur_fnt):=false
+ end
+else begin
+ make_font_name(OFM_default_area_name_length)(OFM_default_area)(ofm_ext);
+ full_name := kpse_find_ofm (cur_name);
+ if full_name then begin
+ resetbin (tfm_file, full_name);
+ free (cur_name);
+ free (full_name);
+ font_extend(cur_fnt):=true
+ end
+ else abort('---not loaded, TFM or OFM file can''t be opened!')
+ end
+@z
+
+@x
+close_in(tfm_file);
+@y
+xfclose(tfm_file, cur_name);
+@z
+
+@x [103] Fix casting problem in C.
+@d tfm_b01(#)== {|tfm_b0..tfm_b1| as non-negative integer}
+if tfm_b0>127 then bad_font
+else #:=tfm_b0*256+tfm_b1
+@d tfm_b23(#)== {|tfm_b2..tfm_b3| as non-negative integer}
+if tfm_b2>127 then bad_font
+else #:=tfm_b2*256+tfm_b3
+@d tfm_squad(#)== {|tfm_b0..tfm_b3| as signed integer}
+if tfm_b0<128 then #:=((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3
+else #:=(((tfm_b0-256)*256+tfm_b1)*256+tfm_b2)*256+tfm_b3
+@d tfm_uquad== {|tfm_b0..tfm_b3| as unsigned integer}
+(((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3)
+@y
+@d tfm_b01(#)== {|tfm_b0..tfm_b1| as non-negative integer}
+if tfm_b0>127 then bad_font
+else #:=tfm_b0*intcast(256)+tfm_b1
+@d tfm_b23(#)== {|tfm_b2..tfm_b3| as non-negative integer}
+if tfm_b2>127 then bad_font
+else #:=tfm_b2*intcast(256)+tfm_b3
+@d tfm_squad(#)== {|tfm_b0..tfm_b3| as signed integer}
+if tfm_b0<128
+then #:=((tfm_b0*intcast(256)+tfm_b1)*intcast(256)+tfm_b2)*intcast(256)+tfm_b3
+else #:=(((tfm_b0-intcast(256))*intcast(256)+tfm_b1)
+ *intcast(256)+tfm_b2)*intcast(256)+tfm_b3
+@d tfm_uquad== {|tfm_b0..tfm_b3| as unsigned integer}
+(((tfm_b0*intcast(256)+tfm_b1)*intcast(256)+tfm_b2)*intcast(256)+tfm_b3)
+@z
+
+@x [109] Declare full_name.
+@!dvi_loc:int_32; {where we are about to look, in |dvi_file|}
+@y
+@!dvi_loc:int_32; {where we are about to look, in |dvi_file|}
+@!full_name: ^char;
+@z
+
+@x [111] Fix up opening the binary files
+@ To prepare |dvi_file| for input, we |reset| it.
+
+@<Open input file(s)@>=
+reset(dvi_file); {prepares to read packed bytes from |dvi_file|}
+dvi_loc:=0;
+@y
+@ To prepare |dvi_file| for input, we |reset| it.
+
+@<Open input file(s)@>=
+dvi_loc:=0;
+@z
+
+@x [113] Make dvi_length() and dvi_move() work.
+@p function dvi_length:int_32;
+begin set_pos(dvi_file,-1); dvi_length:=cur_pos(dvi_file);
+end;
+@#
+procedure dvi_move(@!n:int_32);
+begin set_pos(dvi_file,n); dvi_loc:=n;
+end;
+@y
+@p function dvi_length:int_32;
+begin xfseek(dvi_file, 0, 2, 'odvicopy');
+dvi_loc:=xftell(dvi_file, 'odvicopy');
+dvi_length:=dvi_loc;
+end;
+@#
+procedure dvi_move(n:int_32);
+begin xfseek(dvi_file, n, 0, 'odvicopy');
+dvi_loc:=n;
+end;
+@z
+
+@x
+id3(".")("V")("F")(vf_ext); {file name extension for \.{VF} files}
+id4(".")("O")("V")("F")(ovf_ext); {file name extension for \.{OVF} files}
+@y
+id3(".")("v")("f")(vf_ext); {file name extension for \.{VF} files}
+id4(".")("o")("v")("f")(ovf_ext); {file name extension for \.{OVF} files}
+@z
+
+@x [137/138] Set default directory name
+@ If no font directory has been specified, \.{\title} is supposed to use
+the default \.{VF} directory, which is a system-dependent place where
+the \.{VF} files for standard fonts are kept.
+The string variable |VF_default_area| contains the name of this area.
+@^system dependencies@>
+
+@d VF_default_area_name=='TeXvfonts:' {change this to the correct name}
+@d VF_default_area_name_length=10 {change this to the correct length}
+@d OVF_default_area_name=='TeXvfonts:' {change this to the correct name}
+@d OVF_default_area_name_length=10 {change this to the correct length}
+
+@<Glob...@>=
+@!VF_default_area:packed array[1..VF_default_area_name_length] of char;
+@!OVF_default_area:packed array[1..OVF_default_area_name_length] of char;
+
+@ @<Set init...@>=
+VF_default_area:=VF_default_area_name;
+OVF_default_area:=OVF_default_area_name;
+@y
+@ If no font directory has been specified, \.{\title} is supposed to use
+the default \.{VF} directory, which is a system-dependent place where
+the \.{VF} files for standard fonts are kept.
+
+Actually, under UNIX the standard area is defined in an external
+file \.{site.h}. And the users have a path searched for fonts,
+by setting the \.{VFFONTS} environment variable.
+
+@ (No initialization to be done. Keep this module to preserve numbering.)
+@z
+
+@x [139] Open VF file
+@<VF: Open |vf_file| or |goto not_found|@>=
+make_font_name(VF_default_area_name_length)(VF_default_area)(vf_ext);
+reset(vf_file,cur_name);
+if eof(vf_file) then begin
+ make_font_name(OVF_default_area_name_length)(OVF_default_area)(ovf_ext);
+ reset(vf_file,cur_name);
+ if eof(vf_file) then
+@^system dependencies@>
+ goto not_found
+ end;
+@y
+Do path searching. But the \.{VF} file may not exist.
+
+@<VF: Open |vf_file| or |goto not_found|@>=
+make_font_name(VF_default_area_name_length)(VF_default_area)(vf_ext);
+full_name := kpse_find_vf (cur_name);
+if full_name then begin
+ resetbin (vf_file, full_name);
+ free (cur_name);
+ free (full_name);
+ end
+else begin
+ make_font_name(OVF_default_area_name_length)(OVF_default_area)(ovf_ext);
+ full_name := kpse_find_ovf (cur_name);
+ if full_name then begin
+ resetbin (vf_file, full_name);
+ free (cur_name);
+ free (full_name);
+ end
+ else goto not_found
+ end;
+@z
+
+@x
+close_in(vf_file);
+@y
+xfclose(vf_file,cur_name);
+@z
+
+@x [163] copy elements of array piece by piece
+@ @<VF: Start a new level@>=
+append_one(push);
+vf_move[vf_ptr]:=vf_move[vf_ptr-1];
+@y
+@ \.{web2c} does not like array assignments. So we need to do them
+through a macro replacement.
+
+@d do_vf_move(#) == vf_move[vf_ptr]# := vf_move[vf_ptr-1]#
+@d vf_move_assign == begin do_vf_move([0][0]); do_vf_move([0][1]);
+ do_vf_move([1][0]); do_vf_move([1][1])
+ end
+
+@<VF: Start a new level@>=
+append_one(push);
+vf_move_assign;
+@z
+
+@x [170] and again...
+ vf_move[vf_ptr]:=vf_move[vf_ptr-1];
+@y
+ vf_move_assign;
+@z
+
+@x [175] break is fflush.
+@d update_terminal == break(output) {empty the terminal output buffer}
+@y
+@d update_terminal == fflush(stdout) {empty the terminal output buffer}
+@z
+
+@x [175]
+procedure input_ln; {inputs a line from the terminal}
+var k:0..terminal_line_length;
+begin if n_opt=0 then
+ begin print('Enter option: '); update_terminal; reset(input);
+ if eoln(input) then read_ln(input);
+ k:=0; pckt_room(terminal_line_length);
+ while (k<terminal_line_length)and not eoln(input) do
+ begin append_byte(xord[input^]); incr(k); get(input);
+ end;
+ end
+else if k_opt<n_opt then
+ begin incr(k_opt);
+ {Copy command line option number |k_opt| into |byte_mem| array!}
+ end;
+end;
+@y
+procedure input_ln; {inputs a line from the terminal}
+var k:0..terminal_line_length;
+begin print('Enter option: '); update_terminal;
+{|if eoln(input) then read_ln(input);|}
+k:=0; pckt_room(terminal_line_length);
+while (k<terminal_line_length)and not eoln(input) do
+ begin append_byte(xord[getc(input)]); incr(k);
+ end;
+end;
+@z
+
+@x [231] No dialog, remove unused final label.
+dialog; {get options}
+@y
+@z
+@x
+final_end:end.
+@y
+end.
+@z
+
+@x [236] Do this later, to avoid creating empty files.
+@<Open output file(s)@>=
+rewrite(out_file); {prepares to write packed bytes to |out_file|}
+@y
+@<Open output file(s)@>=
+@z
+
+@x [238] Use external routine to output bytes.
+@d out_byte(#) == write(out_file,#) {write next \.{DVI} byte}
+@y
+@d out_byte(#) == put_byte(#,out_file) {write next \.{DVI} byte}
+@z
+
+@x [250] String declaration.
+@!comment:packed array[1..comm_length] of char; {preamble comment prefix}
+@y
+@!comment:^char; {preamble comment prefix}
+@z
+
+@x [251] Output the string from 0 to len-1, not 1 to len.
+for k:=1 to comm_length do append_byte(xord[comment[k]]);
+@y
+for k:=0 to comm_length - 1 do append_byte(xord[comment[k]]);
+@z
+
+@x [] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{DVIcopy} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+This macro tests if its argument is the current option, as represented
+by the index variable |option_index|.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 5; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+ @!k, @!m: c_int_type;
+ @!end_num: ^char;
+begin
+ @<Define the option table@>;
+ @<Initialize options@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('odvicopy');
+
+ end else if argument_is ('help') then begin
+ usage_help (ODVICOPY_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, 'J. Plaice, Y. Haralambous, P. Breitenlohner', nil);
+
+ end else if argument_is ('magnification') then begin
+ out_mag := atou (optarg);
+
+ end else if argument_is ('max-pages') then begin
+ max_pages := atou (optarg);
+
+ end else if argument_is ('page-start') then begin
+ @<Determine the desired |start_count| values from |optarg|@>;
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.
+ We can have zero, one, or two remaining arguments.}
+ if optind = argc then begin
+ dvi_file := make_binary_file (stdin);
+ out_file := make_binary_file (stdout);
+ term_out := stderr;
+
+ end else if optind + 1 = argc then begin
+ resetbin (dvi_file, extend_filename (cmdline (optind), 'dvi'));
+ out_file := make_binary_file (stdout);
+ term_out := stderr;
+
+ end else if optind + 2 = argc then begin
+ resetbin (dvi_file, extend_filename (cmdline (optind), 'dvi'));
+ rewritebin (out_file, extend_filename (cmdline (optind + 1), 'dvi'));
+ term_out := stdout;
+
+ end else begin
+ write_ln (stderr, 'odvicopy: Need at most two file arguments.');
+ usage ('odvicopy');
+ end;
+end;
+
+@ Here is the first of the options we allow.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[0].name := 'help';
+long_options[0].has_arg := 0;
+long_options[0].flag := 0;
+long_options[0].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Magnification to apply.
+@.-magnification@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'magnification';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ How many pages to do.
+@.-max-pages@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'max-pages';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ What page to start at.
+@.-page-start@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'page-start';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Parsing the starting page specification is a bit complicated.
+(This is the same as in \.{DVItype}.)
+
+@<Determine the desired |start_count|...@> =
+k := 0; {which \.{\\count} register we're on}
+m := 0; {position in |optarg|}
+while optarg[m] do begin
+ if optarg[m] = "*" then begin
+ start_there[k] := false;
+ incr (m);
+
+ end else if optarg[m] = "." then begin
+ incr (k);
+ if k >= 10 then begin
+ write_ln (stderr, 'odvicopy: More than ten count registers specified.');
+ uexit (1);
+ end;
+ incr (m);
+
+ end else begin
+ start_count[k] := strtol (optarg + m, address_of (end_num), 10);
+ if end_num = optarg + m then begin
+ write_ln (stderr, 'odvicopy: -page-start values must be numeric or *.');
+ uexit (1);
+ end;
+ start_there[k] := true;
+ m := m + end_num - (optarg + m);
+ end;
+end;
+start_vals := k;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ @<Glob...@> =
+@!term_out:text;
+@z
diff --git a/Build/source/texk/web2c/omegaware/odvicopy.web b/Build/source/texk/web2c/omegaware/odvicopy.web
new file mode 100644
index 00000000000..cda08cc427f
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/odvicopy.web
@@ -0,0 +1,4688 @@
+% odvicopy.web: Omega version of file dvicopy.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original dvicopy.web.
+%
+% This program is free software; you can redistribute it and/or modify
+% it under the terms of the GNU General Public License as published by
+% the Free Software Foundation; either version 1, or (at your option)
+% any later version.
+%
+% You should have received a copy of the GNU General Public License
+% along with this program; if not, write to the Free Software
+% Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+%
+% Version 0.9 was finished May 21, 1990.
+% Version 1.0 pixel rounding for real devices (August 6, 1990).
+% Version 1.1 major rearrangements for DVIprint (October 7, 1990).
+% Version 1.2 fixed some bugs, page selection (February 13, 1991).
+% Version 1.3 several more changes, command line options,
+% don't load fonts that are never used (August 25, 1992).
+% Version 1.4 fixed a typo (March 28, 1995).
+% Version 1.5 avoided cur_name_length identifier conflict (October 15, 1995).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\font\logo=manfnt % font used for the METAFONT logo
+\def\MF{{\logo META}\-{\logo FONT}}
+\mathchardef\RA="3221 % right arrow
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{ODVI\lowercase{copy}} % don't change this line!
+\def\contentspagenumber{1}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont ODVIcopy} processor}
+ \vskip 5pt
+ \centerline{Copyright (C) 1990,95 Peter Breitenlohner,
+1994,97 John Plaice and Yannis Haralambous}
+ \centerline{Distributed under terms of GNU General Public License}
+ \vskip 15pt
+ \centerline{(Version 1.5, March 1997)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ This program was developed at the Max-Planck-Institut f\"ur Physik
+ (Werner-Heisenberg-Institut), Munich, Germany.
+ And modified at the Universit\'e Laval, Qu\'ebec, Canada.
+ `\TeX' is a trademark of the American Mathematical Society.
+ `{\logo hijklmnj}\kern1pt' is a trademark of Addison-Wesley
+ Publishing Company.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{ODVIcopy} utility program copies (selected pages of) binary
+device-independent (``\.{DVI}'') files that are produced by document
+compilers such as \TeX and $\Omega$,
+and replaces all references to characters from
+virtual fonts by the typesetting instructions specified for them in
+binary virtual-font (``\.{VF}'' or ``OVF'') files.
+This program has two chief purposes: (1)~It can be used as preprocessor
+for existing \.{DVI}-related software in cases where this software is
+unable to handle virtual fonts or (given suitable \.{VF} or \.{OVF} files)
+where this software cannot handle fonts with more than 128~characters;
+and (2)~it serves as an example of a program that reads \.{DVI},
+\.{VF} and \.{OVF} files correctly, for system programmers who are developing
+\.{DVI}-related software.
+
+Goal number (1) is important since quite a few existing programs have
+to be adapted to the extened capabilities of Version~3 of \TeX\ which
+will require some time. Moreover some existing programs are `as is' and
+the source code is, unfortunately, not available.
+Goal number (2) needs perhaps a bit more explanation. Programs for
+typesetting need to be especially careful about how they do arithmetic; if
+rounding errors accumulate, margins won't be straight, vertical rules
+won't line up, and so on (see the documentaion of \.{DVItype} for more
+details). This program is written as if it were a \.{DVI}-driver for a
+hypothetical typesetting device |out_file|, the output file receiving
+the copy of the input |dvi_file|. In addition all code related to
+|out_file| is concentrated in two chapters at the end of this program
+and quite independent of the rest of the code concerned with the
+decoding of \.{DVI}, \.{VF} and \.{OVF} files and with font substitutions. Thus
+it should be relatively easy to replace the device dependent code of
+this program by the corresponding code required for a real typesetting
+device. Having this in mind \.{DVItype}'s pixel rounding algorithms are
+included as conditional code not used by \.{ODVIcopy}.
+
+The \.{ODVIcopy} program is an extension of \.{DVIcopy} that allows
+the use of \.{OVF} and \.{OFM} files, which are used by the $\Omega$
+typesetting system. These files allows fonts with 65536 characters,
+unlike ordinary \.{VF} and \.{TFM} files, which only allow 256
+characters. The definition for \.{OVF} files is identical to the one for
+\.{VF} files. On the other hand, \.{OFM} files are different; their
+documentation can be found in the $\Omega$ web.
+
+Unless the contrary is specified below, all references to \.{TFM} files
+also refer to \.{OFM} files, similarly for \.{VF} and \.{OVF} files.
+References to \.{DVIcopy} also apply to \.{ODVIcopy}.
+
+
+The |banner| and |preamble_comment| strings defined here should be
+changed whenever \.{ODVIcopy} gets modified.
+
+@d banner=='This is ODVIcopy, Version 1.5' {printed when the program starts}
+@d title=='ODVIcopy' {the name of this program, used in some messages}
+@d copyright==
+ '(C) 1990,95 P. Breitenlohner, 1994,97 J. Plaice and Y. Haralambous'
+@#
+@d preamble_comment=='ODVIcopy 1.5 output from '
+@d comm_length=25 {length of |preamble_comment|}
+@d from_length=6 {length of its |' from '| part}
+
+@ This program is written in standard \PASCAL, except where it is necessary
+to use extensions; for example, \.{DVIcopy} must read files whose names
+are dynamically specified, and that would be impossible in pure \PASCAL.
+All places where nonstandard constructions are used have been listed in
+the index under ``system dependencies.''
+@!@^system dependencies@>
+
+One of the extensions to standard \PASCAL\ that we shall deal with is the
+ability to move to a random place in a binary file; another is to
+determine the length of a binary file. Such extensions are not necessary
+for reading \.{DVI} files; since \.{DVIcopy} is (a model for) a
+production program it should, however, be made as efficient as possible
+for a particular system. If \.{DVIcopy} is being used with
+\PASCAL s for which random file positioning is not efficiently available,
+the following definition should be changed from |true| to |false|; in such
+cases, \.{DVIcopy} will not include the optional feature that reads the
+postamble first.
+
+@d random_reading==true {should we skip around in the file?}
+
+@ The program begins with a fairly normal header, made up of pieces that
+@^system dependencies@>
+will mostly be filled in later. The \.{DVI} input comes from file
+|dvi_file|, the \.{DVI} output goes to file |out_file|, and messages
+go to \PASCAL's standard |output| file.
+The \.{TFM} and \.{VF} files are defined later since their external names
+are determined dynamically.
+
+If it is necessary to abort the job because of a fatal error, the program
+calls the `|jump_out|' procedure, which goes to the label |final_end|.
+
+@d final_end = 9999 {go here to wrap it up}
+
+@p @t\4@>@<Compiler directives@>@/
+program ODVI_copy(@!dvi_file,@!out_file,@!output);
+label final_end;
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+@<Error handling procedures@>@/
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+ print_ln(copyright);
+ print_ln('Distributed under terms of GNU General Public License');@/
+ @<Set initial values@>@/
+ end;
+
+@ The definition of |max_font_type| should be adapted to the number of
+font types used by the program; the first three values have a fixed
+meaning: |defined_font=0| indicates that a font has been defined,
+|loaded_font=1| indicates that the \.{TFM} file has been loaded but the
+font has not yet been used, and |vf_font_type=2| indicates a virtual
+font. Font type values |>=real_font=3| indicate real fonts and
+different font types are used to distinguish various kinds of font files
+(\.{GF} or \.{PK} or \.{PXL}). \.{DVIcopy} uses |out_font_type=3| for
+fonts that appear in the output \.{DVI} file.
+@!@^font types@>
+
+@d defined_font=0 {this font has been defined}
+@d loaded_font=1 {this font has been defined and loaded}
+@d vf_font_type=2 {this font is a virtual font}
+@d real_font=3 {smallest font type for real fonts}
+@#
+@d out_font_type=3 {this font appears in the output file}
+@d max_font_type=3
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{DVIcopy}'s capacity.
+
+@d max_select=10 {maximum number of page selection ranges}
+
+@<Constants...@>=
+@!max_fonts=100; {maximum number of distinct fonts}
+@!max_chars=10000; {maximum number of different characters among all fonts}
+@!max_widths=3000; {maximum number of different characters widths}
+@!max_packets=5000; {maximum number of different characters packets;
+ must be less than 65536}
+@!max_bytes=30000; {maximum number of bytes for characters packets}
+@!max_recursion=10; {\.{VF} files shouldn't recurse beyond this level}
+@!stack_size=100; {\.{DVI} files shouldn't |push| beyond this depth}
+@!terminal_line_length=150; {maximum number of characters input in a single
+ line of input from the terminal}
+@!name_length=50; {a file name shouldn't be longer than this}
+@!neg_max_chars=-10000; {maximum number of different characters among all fonts}
+
+@ As mentioned above, \.{DVIcopy} has two chief purposes: (1)~It produces
+a copy of the input \.{DVI} file with all references to characters from
+virtual fonts replaced by their expansion as specified in the character
+packets of \.{VF} files; and (2)~it serves as an example of a program
+that reads \.{DVI} and \.{VF} files correctly, for system programmers
+who are developing \.{DVI}-related software.
+
+In fact, a very large section of code (starting with the second chapter
+`Introduction (continued)' and ending with the fifteenth chapter
+`The main program') is used in identical form in \.{DVIcopy} and in
+\.{DVIprint}, a prototype \.{DVI}-driver. This has been made possible
+mostly by using several \.{WEB} coding tricks, such as not to make the
+resulting \PASCAL\ program inefficient in any way.
+
+Parts of the program that are needed in \.{DVIprint} but not in
+\.{DVIcopy} are delimited by the codewords `$|device|\ldots|ecived|$';
+these are mostly the pixel rounding algorithms used to convert the
+\.{DVI} units of a \.{DVI} file to the raster units of a real output
+device and have been copied more or less verbatim from \.{DVItype}.
+
+@d device==@{ {change this to `$\\{device}\equiv\null$' when output
+ for a real device is produced}
+@d ecived==@t@>@} {change this to `$\\{ecived}\equiv\null$' when output
+ for a real device is produced}
+@f device==begin
+@f ecived==end
+
+@* Introduction (continued).
+On some systems it is necessary to use various integer subrange types
+in order to make \.{\title} efficient; this is true in particular for
+frequently used variables such as loop indices. Consider an integer
+variable |x| with values in the range |0..255|: on most small systems
+|x| should be a one or two byte integer whereas on most large systems
+|x| should be a four byte integer.
+Clearly the author of a program knows best which range of values is
+required for each variable; thus \.{\title} never uses \PASCAL's |integer|
+type. All integer variables are declared as one of the integer subrange
+types defined below as \.{WEB} macros or \PASCAL\ types; these definitions
+can be used without system-dependent changes, provided the signed 32~bit
+integers are a subset of the standard type |integer|, and the compiler
+automatically uses the optimal representation for integer subranges
+(both conditions need not be satisfied for a particular system).
+@^system dependencies@>
+
+The complementary problem of storing large arrays of integer type
+variables as compactly as possible is addressed differently; here
+\.{\title} uses a \PASCAL\ |type|~declaration for each kind of array
+element.
+
+Note that the primary purpose of these definitions is optimizations, not
+range checking. All places where optimization for a particular system is
+highly desirable have been listed in the index under ``optimization.''
+@!@^optimization@>
+
+@d int_32 == integer {signed 32~bit integers}
+
+@<Types...@>=
+@!int_31 = 0..@"7FFFFFFF; {unsigned 31~bit integer}
+@!int_24u = 0..@"FFFFFF; {unsigned 24~bit integer}
+@!int_24 = -@"800000..@"7FFFFF; {signed 24~bit integer}
+@!int_23 = 0..@"7FFFFF; {unsigned 23~bit integer}
+@!int_16u = 0..@"FFFF; {unsigned 16~bit integer}
+@!int_16 = -@"8000..@"7FFF; {signed 16~bit integer}
+@!int_15 = 0..@"7FFF; {unsigned 15~bit integer}
+@!int_8u = 0..@"FF; {unsigned 8~bit integer}
+@!int_8 = -@"80..@"7F; {signed 8~bit integer}
+@!int_7 = 0..@"7F; {unsigned 7~bit integer}
+
+@ Some of this code is optional for use when debugging only;
+such material is enclosed between the delimiters |debug| and $|gubed|$.
+Other parts, delimited by |stat| and $|tats|$, are optionally included
+if statistics about \.{\title}'s memory usage are desired.
+
+@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
+@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
+@f debug==begin
+@f gubed==end
+@#
+@d stat==@{ {change this to `$\\{stat}\equiv\null$'
+ when gathering usage statistics}
+@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$'
+ when gathering usage statistics}
+@f stat==begin
+@f tats==end
+
+@ The \PASCAL\ compiler used to develop this program has ``compiler
+directives'' that can appear in comments whose first character is a dollar sign.
+In production versions of \.{\title} these directives tell the compiler that
+@^system dependencies@>
+it is safe to avoid range checks and to leave out the extra code it inserts
+for the \PASCAL\ debugger's benefit, although interrupts will occur if
+there is arithmetic overflow.
+
+@<Compiler directives@>=
+@{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead}
+@!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging}
+
+@ Labels are given symbolic names by the following definitions. We insert
+the label `|exit|:' just before the `\ignorespaces|end|\unskip' of a
+procedure in which we have used the `|return|' statement defined below;
+the label `|restart|' is occasionally used at the very beginning of a
+procedure; and the label `|reswitch|' is occasionally used just prior to
+a \&{case} statement in which some cases change the conditions and we wish to
+branch to the newly applicable case.
+Loops that are set up with the \&{loop} construction defined below are
+commonly exited by going to `|done|' or to `|found|' or to `|not_found|',
+and they are sometimes repeated by going to `|continue|'.
+
+@d exit=10 {go here to leave a procedure}
+@d restart=20 {go here to start a procedure again}
+@d reswitch=21 {go here to start a case statement again}
+@d continue=22 {go here to resume a loop}
+@d done=30 {go here to exit a loop}
+@d found=31 {go here when you've found it}
+@d not_found=32 {go here when you've found something else}
+
+@ The term |print| is used instead of |write| when this program writes on
+|output|, so that all such output could easily be redirected if desired;
+the term |d_print| is used for conditional output if we are debugging.
+
+@d print(#)==write(output,#)
+@d print_ln(#)==write_ln(output,#)
+@d new_line==write_ln(output) {start new line}
+@d print_nl(#)== {print information starting on a new line}
+ begin new_line; print(#);
+ end
+@#
+@d d_print(#)==@!debug print(#) @; @+ gubed
+@d d_print_ln(#)==@! debug print_ln(#) @; @+ gubed
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@#
+@d Incr_Decr_end(#)==#
+@d Incr(#)==#:=#+Incr_Decr_end {we use |Incr(a)(b)| to increase \dots}
+@d Decr(#)==#:=#-Incr_Decr_end {\dots\ and |Decr(a)(b)| to decrease
+ variable |a| by |b|; this can be optimized for some compilers}
+@#
+@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
+@d do_nothing == {empty statement}
+@d return == goto exit {terminate a procedure call}
+@f return == nil
+@f loop == xclause
+
+@ We assume that |case| statements may include a default case that applies
+if no matching label is found. Thus, we shall use constructions like
+@^system dependencies@>
+$$\vbox{\halign{#\hfil\cr
+|case x of|\cr
+1: $\langle\,$code for $x=1\,\rangle$;\cr
+3: $\langle\,$code for $x=3\,\rangle$;\cr
+|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
+|endcases|\cr}}$$
+since most \PASCAL\ compilers have plugged this hole in the language by
+incorporating some sort of default mechanism. For example, the compiler
+used to develop \.{WEB} and \TeX\ allows `|others|:' as a default label,
+and other \PASCAL s allow syntaxes like `\ignorespaces|else|\unskip' or
+`\&{otherwise}' or `\\{otherwise}:', etc. The definitions of |othercases|
+and |endcases| should be changed to agree with local conventions. (Of
+course, if no default mechanism is available, the |case| statements of
+this program must be extended by listing all remaining cases.
+Donald~E. Knuth, the author of the \.{WEB} system program \.{TANGLE},
+@^Knuth, Donald Ervin@>
+would have taken the trouble to modify \.{TANGLE} so that such extensions
+were done automatically, if he had not wanted to encourage \PASCAL\
+compiler writers to make this important change in \PASCAL, where it belongs.)
+
+@d othercases == others: {default for cases not listed explicitly}
+@d endcases == @+end {follows the default case in an extended |case| statement}
+@f othercases == else
+@f endcases == end
+
+@* The character set.
+Like all programs written with the \.{WEB} system, \.{\title} can be
+used with any character set. But it uses ASCII code internally, because
+the programming for portable input-output is easier when a fixed internal
+code is used, and because \.{DVI} and \.{VF} files use ASCII code for
+file names and certain other strings.
+
+The next few sections of \.{\title} have therefore been copied from the
+analogous ones in the \.{WEB} system routines. They have been considerably
+simplified, since \.{\title} need not deal with the controversial
+ASCII codes less than @'40 or greater than @'176.
+If such codes appear in the \.{DVI} file,
+they will be printed as question marks.
+
+@<Types...@>=
+@!ASCII_code=" ".."~"; {a subrange of the integers}
+
+@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
+character sets were common, so it did not make provision for lower case
+letters. Nowadays, of course, we need to deal with both upper and lower case
+alphabets in a convenient way, especially in a program like \.{\title}.
+So we shall assume that the \PASCAL\ system being used for \.{\title}
+has a character set containing at least the standard visible characters
+of ASCII code (|"!"| through |"~"|).
+
+Some \PASCAL\ compilers use the original name |char| for the data type
+associated with the characters in text files, while other \PASCAL s
+consider |char| to be a 64-element subrange of a larger data type that has
+some other name. In order to accommodate this difference, we shall use
+the name |text_char| to stand for the data type of the characters in the
+output file. We shall also assume that |text_char| consists of
+the elements |chr(first_text_char)| through |chr(last_text_char)|,
+inclusive. The following definitions should be adjusted if necessary.
+@^system dependencies@>
+
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=127 {ordinal number of the largest element of |text_char|}
+
+@<Types...@>=
+@!text_file=packed file of text_char;
+
+@ @<Local variables for init...@>=
+@!i:int_16; {loop index for initializations}
+
+@ The \.{\title} processor converts between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to \PASCAL's |ord| and |chr| functions.
+
+@<Globals...@>=
+@!xord: array [text_char] of ASCII_code;
+ {specifies conversion of input characters}
+@!xchr: array [0..255] of text_char;
+ {specifies conversion of output characters}
+
+@ Under our assumption that the visible characters of standard ASCII are
+all present, the following assignment statements initialize the
+|xchr| array properly, without needing any system-dependent changes.
+
+@<Set init...@>=
+for i:=0 to @'37 do xchr[i]:='?';
+xchr[@'40]:=' ';
+xchr[@'41]:='!';
+xchr[@'42]:='"';
+xchr[@'43]:='#';
+xchr[@'44]:='$';
+xchr[@'45]:='%';
+xchr[@'46]:='&';
+xchr[@'47]:='''';@/
+xchr[@'50]:='(';
+xchr[@'51]:=')';
+xchr[@'52]:='*';
+xchr[@'53]:='+';
+xchr[@'54]:=',';
+xchr[@'55]:='-';
+xchr[@'56]:='.';
+xchr[@'57]:='/';@/
+xchr[@'60]:='0';
+xchr[@'61]:='1';
+xchr[@'62]:='2';
+xchr[@'63]:='3';
+xchr[@'64]:='4';
+xchr[@'65]:='5';
+xchr[@'66]:='6';
+xchr[@'67]:='7';@/
+xchr[@'70]:='8';
+xchr[@'71]:='9';
+xchr[@'72]:=':';
+xchr[@'73]:=';';
+xchr[@'74]:='<';
+xchr[@'75]:='=';
+xchr[@'76]:='>';
+xchr[@'77]:='?';@/
+xchr[@'100]:='@@';
+xchr[@'101]:='A';
+xchr[@'102]:='B';
+xchr[@'103]:='C';
+xchr[@'104]:='D';
+xchr[@'105]:='E';
+xchr[@'106]:='F';
+xchr[@'107]:='G';@/
+xchr[@'110]:='H';
+xchr[@'111]:='I';
+xchr[@'112]:='J';
+xchr[@'113]:='K';
+xchr[@'114]:='L';
+xchr[@'115]:='M';
+xchr[@'116]:='N';
+xchr[@'117]:='O';@/
+xchr[@'120]:='P';
+xchr[@'121]:='Q';
+xchr[@'122]:='R';
+xchr[@'123]:='S';
+xchr[@'124]:='T';
+xchr[@'125]:='U';
+xchr[@'126]:='V';
+xchr[@'127]:='W';@/
+xchr[@'130]:='X';
+xchr[@'131]:='Y';
+xchr[@'132]:='Z';
+xchr[@'133]:='[';
+xchr[@'134]:='\';
+xchr[@'135]:=']';
+xchr[@'136]:='^';
+xchr[@'137]:='_';@/
+xchr[@'140]:='`';
+xchr[@'141]:='a';
+xchr[@'142]:='b';
+xchr[@'143]:='c';
+xchr[@'144]:='d';
+xchr[@'145]:='e';
+xchr[@'146]:='f';
+xchr[@'147]:='g';@/
+xchr[@'150]:='h';
+xchr[@'151]:='i';
+xchr[@'152]:='j';
+xchr[@'153]:='k';
+xchr[@'154]:='l';
+xchr[@'155]:='m';
+xchr[@'156]:='n';
+xchr[@'157]:='o';@/
+xchr[@'160]:='p';
+xchr[@'161]:='q';
+xchr[@'162]:='r';
+xchr[@'163]:='s';
+xchr[@'164]:='t';
+xchr[@'165]:='u';
+xchr[@'166]:='v';
+xchr[@'167]:='w';@/
+xchr[@'170]:='x';
+xchr[@'171]:='y';
+xchr[@'172]:='z';
+xchr[@'173]:='{';
+xchr[@'174]:='|';
+xchr[@'175]:='}';
+xchr[@'176]:='~';
+for i:=@'177 to 255 do xchr[i]:='?';
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|.
+
+@<Set init...@>=
+for i:=first_text_char to last_text_char do xord[chr(i)]:=@'40;
+for i:=" " to "~" do xord[xchr[i]]:=i;
+
+@* Reporting errors to the user.
+The \.{\title} processor does not verify that every single bit read from
+one of its binary input files is meaningful and consistent; there are
+other programs, e.g., \.{DVItype}, \.{TFtoPL}, and \.{VFtoPL}, specially
+designed for that purpose.
+
+On the other hand, \.{\title} is designed to avoid unpredictable results
+due to undetected arithmetic overflow, or due to violation of integer
+subranges or array bounds under {\it all\/} circumstances. Thus a fair
+amount of checking is done when reading and analyzing the input data,
+even in cases where such checking reduces the efficiency of the program
+to some extent.
+
+@ A global variable called |history| will contain one of four values
+at the end of every run: |spotless| means that no unusual messages were
+printed; |harmless_message| means that a message of possible interest
+was printed but no serious errors were detected; |error_message| means that
+at least one error was found; |fatal_message| means that the program
+terminated abnormally. The value of |history| does not influence the
+behavior of the program; it is simply computed for the convenience
+of systems that might want to use such information.
+
+@d spotless=0 {|history| value for normal jobs}
+@d harmless_message=1 {|history| value when non-serious info was printed}
+@d error_message=2 {|history| value when an error was noted}
+@d fatal_message=3 {|history| value when we had to stop prematurely}
+@#
+@d mark_harmless==@t@>@+if history=spotless then history:=harmless_message
+@d mark_error==history:=error_message
+@d mark_fatal==history:=fatal_message
+
+@<Glob...@>=@!history:spotless..fatal_message; {how bad was this run?}
+
+@ @<Set init...@>=history:=spotless;
+
+@ If an input (\.{DVI}, \.{TFM}, \.{VF}, or other) file is badly malformed,
+the whole process must be aborted; \.{\title} will give up, after issuing
+an error message about what caused the error. These messages will, however,
+in most cases just indicate which input file caused the error. One of the
+programs \.{DVItype}, \.{TFtoPL} or \.{VFtoVP} should then be used to
+diagnose the error in full detail.
+
+Such errors might be discovered inside of subroutines inside of subroutines,
+so a procedure called |jump_out| has been introduced. This procedure, which
+transfers control to the label |final_end| at the end of the program,
+contains the only non-local |@!goto| statement in \.{\title}.
+@^system dependencies@>
+Some \PASCAL\ compilers do not implement non-local |goto| statements. In
+such cases the |goto final_end| in |jump_out| should simply be replaced
+by a call on some system procedure that quietly terminates the program.
+@^system dependencies@>
+
+@d abort(#)==begin print_ln(' ',#,'.'); jump_out;
+ end
+
+@<Error handling...@>=
+@<Basic printing procedures@>@;
+procedure close_files_and_terminate; forward;
+@#
+procedure jump_out;
+begin mark_fatal; close_files_and_terminate;
+goto final_end;
+end;
+
+@ Sometimes the program's behavior is far different from what it should
+be, and \.{\title} prints an error message that is really for the
+\.{\title} maintenance person, not the user. In such cases the program
+says |confusion(|indication of where we are|)|.
+
+@<Error handling...@>=
+procedure confusion(@!p:pckt_pointer);
+begin print(' !This can''t happen ('); print_packet(p); print_ln(').');
+@.This can't happen@>
+jump_out;
+end;
+
+@ An overflow stop occurs if \.{\title}'s tables aren't large enough.
+
+@<Error handling...@>=
+procedure overflow(@!p:pckt_pointer;@!n:int_16u);
+begin print(' !Sorry, ',title,' capacity exceeded ['); print_packet(p);
+@.Sorry, {\title} capacity exceeded@>
+print_ln('=',n:1,'].');
+jump_out;
+end;
+
+@* Binary data and binary files.
+A detailed description of the \.{DVI} file format can be found in the
+documentation of \TeX, \.{DVItype}, or \.{GFtoDVI}; here we just define
+symbolic names for some of the \.{DVI} command bytes.
+
+@d set_char_0=0 {typeset character 0 and move right}
+@d set1=128 {typeset a character and move right}
+@d set_rule=132 {typeset a rule and move right}
+@d put1=133 {typeset a character}
+@d put_rule=137 {typeset a rule}
+@d nop=138 {no operation}
+@d bop=139 {beginning of page}
+@d eop=140 {ending of page}
+@d push=141 {save the current positions}
+@d pop=142 {restore previous positions}
+@d right1=143 {move right}
+@d w0=147 {move right by |w|}
+@d w1=148 {move right and set |w|}
+@d x0=152 {move right by |x|}
+@d x1=153 {move right and set |x|}
+@d down1=157 {move down}
+@d y0=161 {move down by |y|}
+@d y1=162 {move down and set |y|}
+@d z0=166 {move down by |z|}
+@d z1=167 {move down and set |z|}
+@d fnt_num_0=171 {set current font to 0}
+@d fnt1=235 {set current font}
+@d xxx1=239 {extension to \.{DVI} primitives}
+@d xxx4=242 {potentially long extension to \.{DVI} primitives}
+@d fnt_def1=243 {define the meaning of a font number}
+@d pre=247 {preamble}
+@d post=248 {postamble beginning}
+@d post_post=249 {postamble ending}
+@#
+@d dvi_id=2 {identifies \.{DVI} files}
+@d dvi_pad=223 {pad bytes at end of \.{DVI} file}
+
+@ A \.{DVI}, \.{VF}, or \.{TFM} file is a sequence of 8-bit bytes.
+The bytes appear physically in what is called a `|packed file of 0..255|'
+in \PASCAL\ lingo. One, two, three, or four consecutive bytes are often
+interpreted as (signed or unsigned) integers.
+We might as well define the corresponding data types.
+@!@^system dependencies@>
+
+@<Types...@>=
+@!signed_byte=-@"80..@"7F; {signed one-byte quantity}
+@!eight_bits=0..@"FF; {unsigned one-byte quantity}
+@!signed_pair=-@"8000..@"7FFF; {signed two-byte quantity}
+@!sixteen_bits=0..@"FFFF; {unsigned two-byte quantity}
+@!signed_trio=-@"800000..@"7FFFFF; {signed three-byte quantity}
+@!twentyfour_bits=0..@"FFFFFF; {unsigned three-byte quantity}
+@!signed_quad=int_32; {signed four-byte quantity}
+
+@ Packing is system dependent, and many \PASCAL\ systems fail to implement
+such files in a sensible way (at least, from the viewpoint of producing
+good production software). For example, some systems treat all
+byte-oriented files as text, looking for end-of-line marks and such
+things. Therefore some system-dependent code is often needed to deal with
+binary files, even though most of the program in this section of
+\.{\title} is written in standard \PASCAL.
+@^system dependencies@>
+
+One common way to solve the problem is to consider files of |integer|
+numbers, and to convert an integer in the range $-2^{31}\L x<2^{31}$ to
+a sequence of four bytes $(a,b,c,d)$ using the following code, which
+avoids the controversial integer division of negative numbers:
+$$\vbox{\halign{#\hfil\cr
+|if x>=0 then a:=x div @'100000000|\cr
+|else begin x:=(x+@'10000000000)+@'10000000000; a:=x div @'100000000+128;|\cr
+\quad|end|\cr
+|x:=x mod @'100000000;|\cr
+|b:=x div @'200000; x:=x mod @'200000;|\cr
+|c:=x div @'400; d:=x mod @'400;|\cr}}$$
+The four bytes are then kept in a buffer and output one by one. (On 36-bit
+computers, an additional division by 16 is necessary at the beginning.
+Another way to separate an integer into four bytes is to use/abuse
+\PASCAL's variant records, storing an integer and retrieving bytes that are
+packed in the same place; {\sl caveat implementor!\/}) It is also desirable
+in some cases to read a hundred or so integers at a time, maintaining a
+larger buffer.
+
+@ We shall stick to simple \PASCAL\ in the standard version of this program,
+for reasons of clarity, even if such simplicity is sometimes unrealistic.
+
+@<Types...@>=
+@!byte_file=packed file of eight_bits; {files that contain binary data}
+
+@ For some operating systems it may be convenient or even necessary to
+close the input files.
+
+@d close_in(#)==do_nothing {close an input file}
+
+@ Character packets extracted from \.{VF} files will be stored in a large
+array |byte_mem|. Other packets of bytes, e.g., character packets
+extracted from a \.{GF} or \.{PK} or \.{PXL} file could be stored in the
+same way. A `|pckt_pointer|' variable, which signifies a packet,
+is an index into another array |pckt_start|. The actual sequence of bytes
+in the packet pointed to by |p| appears in positions |pckt_start[p]| to
+|pckt_start[p+1]-1|, inclusive, in |byte_mem|.
+
+Packets will also be used to store sequences of |ASCII_code|s; in this
+respect the |byte_mem| array is very similar to \TeX's string pool and
+part of the following code has, in fact, been copied more or less
+verbatim from \TeX.
+
+In other respects the packets resemble the identifiers used by
+\.{TANGLE} and \.{WEAVE} (also stored in an array called |byte_mem|)
+since there is, in general, at most one packet with a given contents;
+thus part of the code below has been adapted from the corresponding code
+in these programs.
+
+Some \PASCAL\ compilers won't pack integers into a single byte unless the
+integers lie in the range |-128..127|. To accommodate such systems we
+access the array |byte_mem| only via macros that can easily be redefined.
+@^system dependencies@>
+
+@d bi(#) == # {convert from |eight_bits| to |packed_byte|}
+@d bo(#) == # {convert from |packed_byte| to |eight_bits|}
+
+@<Types...@>=
+@!packed_byte = eight_bits; {elements of |byte_mem| array}
+@!byte_pointer = 0..max_bytes; {an index into |byte_mem|}
+@!pckt_pointer = 0..max_packets; {an index into |pckt_start|}
+
+@ The global variable |byte_ptr| points to the first unused location in
+|byte_mem| and |pckt_ptr| points to the first unused location in
+|pckt_start|.
+
+@<Globals...@>=
+@!byte_mem: packed array [byte_pointer] of packed_byte; {bytes of packets}
+@!pckt_start: array [pckt_pointer] of byte_pointer;
+ {directory into |byte_mem|}
+@!byte_ptr: byte_pointer;
+@!pckt_ptr: pckt_pointer;
+
+@ Several of the elementary operations with packets are performed using
+\.{WEB} macros instead of \PASCAL\ procedures, because many of the
+operations are done quite frequently and we want to avoid the
+overhead of procedure calls. For example, here is
+a simple macro that computes the length of a packet.
+@.WEB@>
+
+@d pckt_length(#)==(pckt_start[#+1]-pckt_start[#]) {the number of bytes
+ in packet number \#}
+
+@ Packets are created by appending bytes to |byte_mem|.
+The |append_byte| macro, defined here, does not check to see if the
+value of |byte_ptr| has gotten too high; this test is supposed to be
+made before |append_byte| is used. There is also a |flush_byte|
+macro, which erases the last byte appended.
+
+To test if there is room to append |l| more bytes to |byte_mem|,
+we shall write |pckt_room(l)|, which aborts \.{\title} and gives an
+apologetic error message if there isn't enough room.
+
+@d append_byte(#) == {put byte \# at the end of |byte_mem|}
+begin byte_mem[byte_ptr]:=bi(#); incr(byte_ptr);
+end
+@d flush_byte == decr(byte_ptr) {forget the last byte in |byte_mem|}
+@d pckt_room(#) == {make sure that |byte_mem| hasn't overflowed}
+ if max_bytes-byte_ptr<# then overflow(str_bytes,max_bytes)
+@#
+@d append_one(#) ==
+begin pckt_room(1); append_byte(#);
+end
+
+@ The length of the current packet is called |cur_pckt_length|:
+
+@d cur_pckt_length == (byte_ptr - pckt_start[pckt_ptr])
+
+@ Once a sequence of bytes has been appended to |byte_mem|, it
+officially becomes a packet when the |make_packet| function is called.
+This function returns as its value the identification number of either
+an existing packet with the same contents or, if no such packet exists,
+of the new packet. Thus two packets have the same contents if and only
+if they have the same identification number. In order to locate the
+packet with a given contents, or to find out that no such packet exists,
+we need a hash table. The hash table is kept by the method of simple
+chaining, where the heads of the individual lists appear in the |p_hash|
+array. If |h| is a hash code, the hash table list starts at |p_hash[h]|
+and proceeds through |p_link| pointers.
+
+@d hash_size=353 {should be prime, must be |>256|}
+
+@<Types...@>=
+@!hash_code=0..hash_size;
+
+@ @<Glob...@>=
+@!p_link:array[pckt_pointer] of pckt_pointer; {hash table}
+@!p_hash:array[hash_code] of pckt_pointer;
+
+@ Initially |byte_mem| and all the hash lists are empty; |empty_packet|
+is the empty packet.
+
+@d empty_packet=0 {the empty packet}
+@d invalid_packet==max_packets {used when there is no packet}
+
+@<Set init...@>=
+pckt_ptr:=1; byte_ptr:=1;
+pckt_start[0]:=1; pckt_start[1]:=1;
+for h:=0 to hash_size-1 do p_hash[h]:=0;
+
+@ @<Local variables for init...@>=
+@!h:hash_code; {index into hash-head arrays}
+
+@ Here now is the |make_packet| function used to create packets (and
+strings).
+
+@p function make_packet:pckt_pointer;
+label found;
+var i,@!k:byte_pointer; {indices into |byte_mem|}
+@!h:hash_code; {hash code}
+@!s,@!l:byte_pointer; {start and length of the given packet}
+@!p:pckt_pointer; {where the packet is being sought}
+begin s:=pckt_start[pckt_ptr]; l:=byte_ptr-s; {compute start and length}
+if l=0 then p:=empty_packet
+else begin @<Compute the packet hash code |h|@>;
+ @<Compute the packet location |p|@>;
+ if pckt_ptr=max_packets then overflow(str_packets,max_packets);
+ incr(pckt_ptr); pckt_start[pckt_ptr]:=byte_ptr;
+ end;
+found:make_packet:=p;
+end;
+
+@ A simple hash code is used: If the sequence of bytes is
+$b_1b_2\ldots b_n$, its hash value will be
+$$(2^{n-1}b_1+2^{n-2}b_2+\cdots+b_n)\,\bmod\,|hash_size|.$$
+
+@<Compute the packet hash...@>=
+h:=bo(byte_mem[s]); i:=s+1;
+while i<byte_ptr do
+ begin h:=(h+h+bo(byte_mem[i])) mod hash_size; incr(i);
+ end
+
+@ If the packet is new, it will be placed in position |p=pckt_ptr|,
+otherwise |p| will point to its existing location.
+
+@<Compute the packet location...@>=
+p:=p_hash[h];
+while p<>0 do
+ begin if pckt_length(p)=l then
+ @<Compare packet |p| with current packet, |goto found| if equal@>;
+ p:=p_link[p];
+ end;
+p:=pckt_ptr; {the current packet is new}
+p_link[p]:=p_hash[h]; p_hash[h]:=p {insert |p| at beginning of hash list}
+
+@ @<Compare packet |p|...@>=
+begin i:=s; k:=pckt_start[p];
+while (i<byte_ptr)and(byte_mem[i]=byte_mem[k]) do
+ begin incr(i); incr(k);
+ end;
+if i=byte_ptr then {all bytes agree}
+ begin byte_ptr:=pckt_start[pckt_ptr]; goto found;
+ end;
+end
+
+@ Some packets are initialized with predefined strings of |ASCII_code|s;
+a few macros permit us to do the initialization with a compact program.
+Since this initialization is done when |byte_mem| is still empty, and
+since |byte_mem| is supposed to be large enough for all the predefined
+strings, |pckt_room| is used only if we are debugging.
+
+@d pid0(#)==#:=make_packet
+@d pid1(#)==byte_mem[byte_ptr-1]:=bi(#); pid0
+@d pid2(#)==byte_mem[byte_ptr-2]:=bi(#); pid1
+@d pid3(#)==byte_mem[byte_ptr-3]:=bi(#); pid2
+@d pid4(#)==byte_mem[byte_ptr-4]:=bi(#); pid3
+@d pid5(#)==byte_mem[byte_ptr-5]:=bi(#); pid4
+@d pid6(#)==byte_mem[byte_ptr-6]:=bi(#); pid5
+@d pid7(#)==byte_mem[byte_ptr-7]:=bi(#); pid6
+@d pid8(#)==byte_mem[byte_ptr-8]:=bi(#); pid7
+@d pid9(#)==byte_mem[byte_ptr-9]:=bi(#); pid8
+@d pid10(#)==byte_mem[byte_ptr-10]:=bi(#); pid9
+@#
+@d pid_init(#)==
+ @!debug pckt_room(#); @+ gubed @;
+ Incr(byte_ptr)(#)
+@#
+@d id1==pid_init(1); pid1
+@d id2==pid_init(2); pid2
+@d id3==pid_init(3); pid3
+@d id4==pid_init(4); pid4
+@d id5==pid_init(5); pid5
+@d id6==pid_init(6); pid6
+@d id7==pid_init(7); pid7
+@d id8==pid_init(8); pid8
+@d id9==pid_init(9); pid9
+@d id10==pid_init(10); pid10
+
+@ Here we initialize some strings used as argument of the |overflow| and
+|confusion| procedures.
+
+@<Initialize predefined strings@>=
+id5("f")("o")("n")("t")("s")(str_fonts);
+id5("c")("h")("a")("r")("s")(str_chars);
+id6("w")("i")("d")("t")("h")("s")(str_widths);
+id7("p")("a")("c")("k")("e")("t")("s")(str_packets);
+id5("b")("y")("t")("e")("s")(str_bytes);
+id9("r")("e")("c")("u")("r")("s")("i")("o")("n")(str_recursion);
+id5("s")("t")("a")("c")("k")(str_stack);
+id10("n")("a")("m")("e")("l")("e")("n")("g")("t")("h")(str_name_length);
+
+@ @<Glob...@>=
+@!str_fonts,@!str_chars,@!str_widths,@!str_packets,@!str_bytes,
+@!str_recursion,@!str_stack,@!str_name_length:pckt_pointer;
+
+@ Some packets, e.g., the preamble comments of \.{DVI} and \.{VF} files,
+are needed only temporarily. In such cases |new_packet| is used to
+create a packet (which might duplicate an existing packet) and
+|flush_packet| is used to discard it; the calls to |new_packet| and
+|flush_packet| must occur in balanced pairs, without any intervening
+calls to |make_packet|.
+
+@p function new_packet: pckt_pointer;
+begin if pckt_ptr=max_packets then overflow(str_packets,max_packets);
+new_packet:=pckt_ptr; incr(pckt_ptr); pckt_start[pckt_ptr]:=byte_ptr;
+end;
+@#
+procedure flush_packet;
+begin decr(pckt_ptr); byte_ptr:=pckt_start[pckt_ptr];
+end;
+
+@ The |print_packet| procedure prints the contents of a packet; such a
+packets should, of course, consists of a sequence of |ASCII_code|s.
+
+@<Basic printing...@>=
+procedure print_packet(p:pckt_pointer);
+var k:byte_pointer;
+begin for k:=pckt_start[p] to pckt_start[p+1]-1 do
+ print(xchr[bo(byte_mem[k])]);
+end;
+
+@ When we interpret a packet we will use two (global or local) variables:
+|cur_loc| will point to the byte to be used next, and |cur_limit| will
+point to the start of the next packet. The macro |pckt_extract| will be
+used to extract one byte; it should, however, never be used with
+|cur_loc>=cur_limit|.
+
+@d pckt_extract(#) ==
+@!debug if cur_loc>=cur_limit then confusion(str_packets) @+ else @/
+gubed @;
+ begin #:=bo(byte_mem[cur_loc]); incr(cur_loc); @+ end
+
+@<Globals...@>=
+@!cur_pckt: pckt_pointer; {the current packet}
+@!cur_loc: byte_pointer; {current location in a packet}
+@!cur_limit: byte_pointer; {start of next packet}
+
+@ We will need routines to extract one, two, three, or four bytes from
+|byte_mem|, from the \.{DVI} file, or from a \.{VF} file and assemble
+them into (signed or unsigned) integers and these routines should be
+optimized for efficiency. Here we define \.{WEB} macros to be used for
+the body of these routines; thus the changes for system dependent
+optimization have to be applied only once.
+@^system dependencies@>
+@^optimization@>
+
+In addition we demonstrates how these macros can be used to define
+functions that extract one, two, three, or four bytes from a character
+packet and assemble them into signed or unsigned integers (assuming that
+|cur_loc| and |cur_limit| are initialized suitably).
+
+@d begin_byte(#) ==
+var a:eight_bits;
+begin #(a)
+@d comp_sbyte(#) == if a<128 then #:=a @+ else #:=a-256
+@d comp_ubyte(#) == #:=a
+@f begin_byte == begin
+
+@p function pckt_sbyte:int_8; {returns the next byte, signed}
+@!begin_byte(pckt_extract); comp_sbyte(pckt_sbyte);
+end;
+@#
+function pckt_ubyte:int_8u; {returns the next byte, unsigned}
+@!begin_byte(pckt_extract); comp_ubyte(pckt_ubyte);
+end;
+
+@ @d begin_pair(#) ==
+var a,@!b:eight_bits;
+begin #(a); #(b)
+@d comp_spair(#) == if a<128 then #:=a*256+b @+ else #:=(a-256)*256+b
+@d comp_upair(#) == #:=a*256+b
+@f begin_pair == begin
+
+@p function pckt_spair:int_16; {returns the next two bytes, signed}
+@!begin_pair(pckt_extract); comp_spair(pckt_spair);
+end;
+@#
+function pckt_upair:int_16u; {returns the next two bytes, unsigned}
+@!begin_pair(pckt_extract); comp_upair(pckt_upair);
+end;
+
+@ @d begin_trio(#) ==
+var a,@!b,@!c:eight_bits;
+begin #(a); #(b); #(c)
+@d comp_strio(#) ==
+if a<128 then #:=(a*256+b)*256+c @+ else #:=((a-256)*256+b)*256+c
+@d comp_utrio(#) == #:=(a*256+b)*256+c
+@f begin_trio == begin
+
+@p function pckt_strio:int_24; {returns the next three bytes, signed}
+@!begin_trio(pckt_extract); comp_strio(pckt_strio);
+end;
+@#
+function pckt_utrio:int_24u; {returns the next three bytes, unsigned}
+@!begin_trio(pckt_extract); comp_utrio(pckt_utrio);
+end;
+
+@ @d begin_quad(#) ==
+var a,@!b,@!c,@!d:eight_bits;
+begin #(a); #(b); #(c); #(d)
+@d comp_squad(#) ==
+if a<128 then #:=((a*256+b)*256+c)*256+d
+else #:=(((a-256)*256+b)*256+c)*256+d
+@f begin_quad == begin
+
+@p function pckt_squad:int_32; {returns the next four bytes, signed}
+@!begin_quad(pckt_extract); comp_squad(pckt_squad);
+end;
+
+@ A similar set of routines is needed for the inverse task of
+decomposing a \.{DVI} command into a sequence of bytes to be appended
+to |byte_mem| or, in the case of \.{DVIcopy}, to be written to the
+output file. Again we define \.{WEB} macros to be used for the body
+of these routines; thus the changes for system dependent optimization
+have to be applied only once.
+@^system dependencies@>
+@^optimization@>
+
+First, the |pckt_one| outputs one byte, negative values are represented
+in two's complement notation.
+
+@d begin_one == begin
+@d comp_one(#) ==
+if x<0 then Incr(x)(256);
+#(x)
+@f begin_one == begin
+
+@p @!device
+procedure pckt_one(@!x:int_32); {output one byte}
+@!begin_one; pckt_room(1); comp_one(append_byte);
+end;
+ecived
+
+@ The |pckt_two| outputs two bytes, negative values are represented in
+two's complement notation.
+
+@d begin_two == begin
+@d comp_two(#) ==
+if x<0 then Incr(x)(@"10000);
+#(x div @"100); #(x mod @"100)
+@f begin_two == begin
+
+@p @!device
+procedure pckt_two(@!x:int_32); {output two byte}
+@!begin_two; pckt_room(2); comp_two(append_byte);
+end;
+ecived
+
+@ The |pckt_four| procedure outputs four bytes in two's complement
+notation, without risking arithmetic overflow.
+
+@d begin_four == begin
+@d comp_four(#) ==
+if x>=0 then #(x div @"1000000)
+else begin Incr(x)(@"40000000); Incr(x)(@"40000000);
+ #((x div @"1000000) + 128);
+ end;
+x:=x mod @"1000000; #(x div @"10000);
+x:=x mod @"10000; #(x div @"100);
+#(x mod @"100)
+@f begin_four == begin
+
+@p procedure pckt_four(@!x:int_32); {output four bytes}
+@!begin_four; pckt_room(4); comp_four(append_byte);
+end;
+
+@ Next, the |pckt_char| procedure outputs a |set_char| or \\{set} command
+or, if |upd=false|, a |put| command.
+
+@d begin_char ==
+var o:eight_bits; {|set1| or |put1|}
+begin
+@d comp_char(#) ==
+if (res>=0) and (res<@"100) then begin
+ if (not upd)or(res>127)or(ext<>0) then
+ begin o:=dvi_char_cmd[upd]; {|set1| or |put1|}
+ if ext<0 then Incr(ext)(@"1000000);
+ if ext=0 then #(o) @+ else @;
+ begin if ext<@"100 then #(o+1) @+ else @;
+ begin if ext<@"10000 then #(o+2) @+ else @;
+ begin #(o+3); #(ext div @"10000); ext:=ext mod @"10000;
+ end;
+ #(ext div @"100); ext:=ext mod @"100;
+ end;
+ #(ext);
+ end;
+ end;
+ #(res)
+ end
+else
+ begin if (res>=0) and (res<@"10000) then #(o+1) @+ else @;
+ begin if (res>=0) and (res<@"1000000) then #(o+2) @+ else @;
+ begin #(o+3);
+ if res>=0 then #(res div @"1000000)
+ else begin Incr(res)(@"40000000); Incr(res)(@"40000000);
+ #((res div @"1000000) + 128); res:=res mod @"1000000;
+ end;
+ res:=res mod @"1000000
+ end;
+ #(res div @"10000); res:= res mod @"10000
+ end;
+ #(res div @"100); res:=res mod @"100; #(res)
+ end
+
+@f begin_char == begin
+
+@p procedure pckt_char(@!upd:boolean;@!ext:int_32;@!res:int_32);
+ {output \\{set} or |put|}
+@!begin_char; pckt_room(5); comp_char(append_byte);
+end;
+
+@ Then, the |pckt_unsigned| procedure outputs a |fnt| or |xxx|
+command with its first parameter (normally unsigned); a |fnt| command
+is converted into |fnt_num| whenever this is possible.
+
+@d begin_unsigned == begin
+@d comp_unsigned(#) ==
+if (x<@"100)and(x>=0) then
+ if (o=fnt1)and(x<64) then Incr(x)(fnt_num_0) @+ else #(o)
+else
+ begin if (x<@"10000)and(x>=0) then #(o+1) @+ else @;
+ begin if (x<@"1000000)and(x>=0) then #(o+2) @+ else @;
+ begin #(o+3);
+ if x>=0 then #(x div @"1000000)
+ else begin Incr(x)(@"40000000); Incr(x)(@"40000000);
+ #((x div @"1000000) + 128);
+ end;
+ x:=x mod @"1000000;
+ end;
+ #(x div @"10000); x:=x mod @"10000;
+ end;
+ #(x div @"100); x:=x mod @"100;
+ end;
+#(x)
+@f begin_unsigned == begin
+
+@p procedure pckt_unsigned(@!o:eight_bits;@!x:int_32);
+ {output |fnt_num|, |fnt|, or |xxx|}
+@!begin_unsigned; pckt_room(5); comp_unsigned(append_byte);
+end;
+
+@ Finally, the |pckt_signed| procedure outputs a movement (|right|, |w|,
+|x|, |down|, |y|, or |z|) command with its (signed) parameter.
+
+@d begin_signed ==
+var xx:int_31; {`absolute value' of |x|}
+begin
+@d comp_signed(#) ==
+if x>=0 then xx:=x @+ else xx:=-(x+1);
+if xx<@"80 then
+ begin #(o); @+ if x<0 then Incr(x)(@"100); @+ end
+else begin if xx<@"8000 then
+ begin #(o+1); @+ if x<0 then Incr(x)(@"10000); @+ end
+ else begin if xx<@"800000 then
+ begin #(o+2); @+ if x<0 then Incr(x)(@"1000000); @+ end
+ else begin #(o+3);
+ if x>=0 then #(x div @"1000000)
+ else begin x:=@"7FFFFFFF-xx; #((x div @"1000000) + 128); @+ end;
+ x:=x mod @"1000000;
+ end;
+ #(x div @"10000); x:=x mod @"10000;
+ end;
+ #(x div @"100); x:=x mod @"100;
+ end;
+#(x)
+@f begin_signed == begin
+
+@p procedure pckt_signed(@!o:eight_bits;@!x:int_32);
+ {output |right|, |w|, |x|, |down|, |y|, or |z|}
+@!begin_signed; pckt_room(5); comp_signed(append_byte);
+end;
+
+@ The |hex_packet| procedure prints the contents of a packet in
+hexadecimal form.
+
+@<Basic printing...@>=
+@!debug procedure hex_packet(@!p:pckt_pointer); {prints a packet in hex}
+var j,@!k,@!l:byte_pointer; {indices into |byte_mem|}
+@!d:int_8u;
+begin j:=pckt_start[p]-1; k:=pckt_start[p+1]-1;
+print_ln(' packet=',p:1,' start=',j+1:1,' length=',k-j:1);
+for l:=j+1 to k do
+ begin d:=(bo(byte_mem[l])) div 16;
+ if d<10 then print(xchr[d+"0"]) @+ else print(xchr[d-10+"A"]);
+ d:=(bo(byte_mem[l])) mod 16;
+ if d<10 then print(xchr[d+"0"]) @+ else print(xchr[d-10+"A"]);
+ if (l=k)or(((l-j) mod 16)=0) then new_line
+ else if ((l-j) mod 4)=0 then print(' ')
+ else print(' ');
+ end;
+end;
+gubed
+
+@* File names.
+The structure of file names is different for different systems; therefore
+this part of the program will, in most cases, require system dependent
+modifications. Here we assume that a file name consists of three parts:
+an area or directory specifying where the file can be found, a name
+proper and an extension; \.{\title} assumes that these three parts appear
+in order stated above but this need not be true in all cases.
+
+The font names extracted from \.{DVI} and \.{VF} files consist of an area
+part and a name proper; these are stored as packets consisting of the
+length of the area part followed by the area and the name proper.
+When we print an external font name we simple print the area and the name
+contained in the `file name packet' without delimiter between them.
+This may need to be modified for some systems.
+@^system dependencies@>
+
+@<Basic printing...@>=
+procedure print_font(@!f:font_number);
+var p:pckt_pointer; {the font name packet}
+@!k:byte_pointer; {index into |byte_mem|}
+@!m:int_31; {font magnification}
+begin print(' = '); p:=font_name(f);
+for k:=pckt_start[p]+1 to pckt_start[p+1]-1 do
+ print(xchr[bo(byte_mem[k])]);
+m:=round((font_scaled(f)/font_design(f))*out_mag);
+if m<>1000 then print(' scaled ',m:1);
+end;
+
+@ Before a font file can be opened for input we must build a string
+with its external name.
+
+@<Glob...@>=
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+@!l_cur_name:int_15; {this many characters are actually relevant in
+ |cur_name|}
+
+@ For \.{TFM} and \.{VF} files we just append the apropriate extension
+to the file name packet; in addition a system dependent area part
+(usually different for \.{TFM} and \.{VF} files) is prepended if
+the file name packet contains no area part.
+@^system dependencies@>
+
+@d append_to_name(#)==
+ if l_cur_name<name_length then
+ begin incr(l_cur_name); cur_name[l_cur_name]:=#;
+ end
+ else overflow(str_name_length,name_length)
+@d make_font_name_end(#)==
+ append_to_name(#[l]); make_name
+@d make_font_name(#)==
+ l_cur_name:=0; for l:=1 to # do make_font_name_end
+
+@ For files with character raster data (e.g., \.{GF} or \.{PK} files) the
+the extension and\slash or area part will in most cases depend on the
+resolution of the output device (corrected for font magnification).
+If the special character |res_char| occurs in the extension and\slash or
+default area, a character string representing the device resolution will
+be substituted.
+@^system dependencies@>
+
+@d res_char=='?' {character to be replaced by font resolution}
+@d res_ASCII="?" {|xord[res_char]|}
+@#
+@d append_res_to_name(#)==
+ begin c:=#;
+ @!device if c=res_char then
+ for ll:=n_res_digits downto 1 do append_to_name(res_digits[ll])
+ else ecived@;@/
+ append_to_name(c);
+ end
+@d make_font_res_end(#)==
+ append_res_to_name(#[l]); make_name
+@d make_font_res(#)==
+ make_res; l_cur_name:=0; for l:=1 to # do make_font_res_end
+
+@ @<Glob...@>=
+@!device
+@!f_res:int_16u; {font resolution}
+@!res_digits:array [1..5] of char;
+@!n_res_digits:int_7; {number of significant characters in |res_digits|}
+ecived
+
+@ The |make_res| procedure creates a sequence of characters representing
+to the font resolution |f_res|.
+
+@p @!device procedure make_res;
+var r:int_16u;
+begin n_res_digits:=0; r:=f_res;
+repeat incr(n_res_digits);
+ res_digits[n_res_digits]:=xchr["0"+(r mod 10)]; r:=r div 10;
+until r=0;
+end;
+ecived
+
+@ The |make_name| procedure used to build the external file name. The
+global variable |l_cur_name| contains the length of a default area
+which has been copied to |cur_name| before |make_name| is called.
+@^system dependencies@>
+
+@p procedure make_name(@!e:pckt_pointer);
+var b:eight_bits; {a byte extracted from |byte_mem|}
+@!n:pckt_pointer; {file name packet}
+@!cur_loc,@!cur_limit:byte_pointer; {indices into |byte_mem|}
+@!device
+@!ll:int_15; {loop index}
+ecived@;@/
+@!c:char; {a character to be appended to |cur_name|}
+begin n:=font_name(cur_fnt);
+cur_loc:=pckt_start[n]; cur_limit:=pckt_start[n+1];
+pckt_extract(b); {length of area part}
+if b>0 then l_cur_name:=0;
+while cur_loc<cur_limit do
+ begin pckt_extract(b);
+ if (b>="a")and(b<="z") then Decr(b)("a"-"A"); {convert to upper case}
+ append_to_name(xchr[b]);
+ end;
+cur_loc:=pckt_start[e]; cur_limit:=pckt_start[e+1];
+while cur_loc<cur_limit do
+ begin pckt_extract(b); append_res_to_name(xchr[b]);
+ end;
+while l_cur_name<name_length do
+ begin incr(l_cur_name); cur_name[l_cur_name]:=' ';
+ end;
+end;
+
+@* Font data.
+@ \.{DVI} file format does not include information about character widths, since
+that would tend to make the files a lot longer. But a program that reads
+a \.{DVI} file is supposed to know the widths of the characters that appear
+in \\{set\_char} commands. Therefore \.{\title} looks at the font metric
+(\.{TFM}) files for the fonts that are involved.
+@.TFM {\rm files}@>
+@.OFM {\rm files}@>
+
+The character-width data appears also in other files (e.g., in \.{VF} files
+or in \.{GF} and \.{PK} files that specify bit patterns for digitized
+characters); thus, it is usually possible for \.{DVI} reading programs
+to get by with accessing only one file per font. For \.{VF} reading
+programs there is, however, a problem: (1)~when reading the character
+packets from a \.{VF} file the \.{TFM} width for its local fonts should
+be known in order to analyze and optimize the packets (e.g., determine
+if a packet must indeed be enclosed with |push| and |pop| as implied by
+the \.{VF} format); and (2)~ in order to avoid infinite recursion such
+programs must not try to read a \.{VF} file for a font before a
+character from that font is actually used. Thus \.{\title} reads the
+\.{TFM} file whenever a new font is encountered and delays the decision
+whether this is a virtual font or not.
+
+@ First of all we need to know for each font~|f| such things as its
+external name, design and scaled size, and the approximate size of
+inter-word spaces. In addition we need to know the range |bc..ec| of
+valid characters for this font, and for each character~|c| in~|f| we
+need to know if this character exists and if so what is the width of~|c|.
+Depending on the font type of~|f| we may want to know a few other things
+about character~|c| in~|f| such as the character packet from a \.{VF}
+file or the raster data from a \.{PK} file.
+@^font types@>
+
+In \.{\title} we want to be able to handle the full range
+|@t$-2^{31}$@><=c<@t$2^{31}$@>| of character codes; each character code
+is decomposed into a character residue |0<=res<256| and character
+extension |@t$-2^{23}$@><=ext<@t$2^{23}$@>| such that |c=256*ext+res|.
+At present \.{VFtoVP}, \.{VPtoVF}, and the standard version of \TeX\ use
+only characters in the range |0<=c<256| (i.e., |ext=0|), there are,
+however, extensions of \TeX\ which use characters with |ext<>0|.
+In any case characters with |ext<>0| will be used rather infrequently
+and we want to handle this possibility without too much overhead.
+
+Some of the data for each character~|c| depend only on its residue:
+first of all its width and escapement; others, such as \.{VF} packets or
+raster data will also depend on its extension. The later will be stored
+as packets in |byte_mem|, and the packets for characters with the same
+residue but different extension will be chained.
+
+Thus we have to maintain several variables for each character
+residue~|bc<=res<=ec| from each font~|f|; we store each type of variable
+in a large array such that the array index |font_chars(f)+res| points to
+the value for characters with residue |res| from font~|f|.
+
+Although \TeX\ was designed to be used with 256 characters, $\Omega$
+has no such restrictions. Therefore when \.{OVF} and \.{OFM} files
+are being used, |ext| will remain 0 and |res| will vary over the full
+range of values.
+
+@ Quite often a particular width value is shared by several characters in
+a font or even by characters from different fonts; the later will
+probably occur in particular for virtual fonts and the local fonts used
+by them. Thus the array |widths| is used to store all different \.{TFM}
+width values of all legal characters in all fonts; a variable of type
+|width_pointer| is an index into |widths| or is zero if a characters does
+not exist.
+
+In order to locate a given width value we use again a hash
+table with simple chaining; this time the heads of the individual lists
+appear in the |w_hash| array and the lists proceed through |w_link|
+pointers.
+
+@<Types...@>=
+@!width_pointer=0..max_widths; {an index into |widths|}
+
+@ @<Glob...@>=
+@!widths:array[width_pointer] of int_32; {the different width values}
+@!w_link:array[width_pointer] of width_pointer; {hash table}
+@!w_hash:array[hash_code] of width_pointer;
+@!n_widths:width_pointer; {first unoccupied position in |widths|}
+
+@ Initially the |widths| array and all the hash lists are empty, except
+for one entry: the width value zero; in addition we set |widths[0]:=0|.
+
+@d invalid_width=0 {width pointer for invalid characters}
+@d zero_width=1 {a width pointer to the value zero}
+
+@<Set init...@>=
+w_hash[0]:=1; w_link[1]:=0; widths[0]:=0; widths[1]:=0; n_widths:=2;
+for h:=1 to hash_size-1 do w_hash[h]:=0;
+
+@ The |make_width| function returns an index into |widths| and, if
+necessary, adds a new width value; thus two characters will have the
+same |width_pointer| if and only if their widths agree.
+
+@p function make_width(@!w:int_32):width_pointer;
+label found;
+var h:hash_code; {hash code}
+@!p:width_pointer; {where the identifier is being sought}
+@!x:int_16; {intermediate value}
+begin widths[n_widths]:=w;
+@<Compute the width hash code |h|@>;
+@<Compute the width location |p|, |goto| found unless the value is new@>;
+if n_widths=max_widths then overflow(str_widths,max_widths);
+incr(n_widths);
+found:make_width:=p;
+end;
+
+@ A simple hash code is used: If the width value consists of the four
+bytes $b_0b_1b_2b_3$, its hash value will be
+$$(8*b_0+4*b_1+2*b_2+b_3)\,\bmod\,|hash_size|.$$
+
+@<Compute the width hash...@>=
+if w>=0 then x:=w div @"1000000
+else begin w:=w+@"40000000; w:=w+@"40000000; x:=(w div @"1000000)+@"80;
+ end;
+w:=w mod @"1000000; x:=x+x+(w div @"10000);
+w:=w mod @"10000; x:=x+x+(w div @"100);
+h:=(x+x+(w mod @"100)) mod hash_size
+
+@ If the width is new, it has been placed into position |p=n_widths|,
+otherwise |p| will point to its existing location.
+
+@<Compute the width location...@>=
+p:=w_hash[h];
+while p<>0 do
+ begin if widths[p]=widths[n_widths] then goto found;
+ p:=w_link[p];
+ end;
+p:=n_widths; {the current width is new}
+w_link[p]:=w_hash[h]; w_hash[h]:=p {insert |p| at beginning of hash list}
+
+@ The |char_widths| array is used to store the |width_pointer|s for all
+different characters among all fonts. The |char_packets| array is used
+to store the |pckt_pointer|s for all different characters among all
+fonts; they can point to character packets from \.{VF} files or, e.g.,
+raster packets from \.{PK} files.
+
+@<Types...@>=
+@!char_offset=neg_max_chars..max_chars; {|char_pointer| offset for a font}
+@!char_pointer=0..max_chars; {index into |char_widths| or similar arrays}
+
+@ @<Glob...@>=
+@!char_widths:array[char_pointer] of width_pointer; {width pointers}
+@!char_packets:array[char_pointer] of pckt_pointer; {packet pointers}
+@!n_chars:char_pointer; {first unused position in |char_widths|}
+
+@ @<Set init...@>=
+n_chars:=0;
+
+@ The current number of known fonts is |nf|; each known font has an
+internal number |f|, where |0<=f<nf|. For the moment we need for each
+known font: |font_check|, |font_scaled|, |font_design|, |font_name|,
+|font_bc|, |font_ec|, |font_chars|, and |font_type|. Here |font_scaled|
+and |font_design| are measured in \.{DVI} units and |font_chars| is of
+type |char_offset|: the width pointer for character~|c| of the font is
+stored in |char_widths[char_offset+c]| (for |font_bc<=c<=font_ec|).
+Later on we will need additional information depending on the font type:
+\.{VF} or real (\.{GF}, \.{PK} or \.{PXL}).
+
+@<Types...@>=
+@!f_type=defined_font..max_font_type; {type of a font}
+@!font_number=0..max_fonts;
+
+@ @<Glob...@>=
+@!nf:font_number;
+
+@ These data are stored in several arrays and we use \.{WEB} macros
+to access the various fields. Thus it would be simple to store the
+data in an array of record structures and adapt the \.{WEB} macros
+accordingly.
+
+We will say, e.g., |font_name(f)| for the name field of font~|f|, and
+|font_width(f)(c)| for the width pointer of character~|c| in font~|f|
+and |font_packet(f)(c)| for its character packet (this character
+exists provided |font_bc(f)<=c<=font_ec(f)| and
+|font_width(f)(c)<>invalid_width|). The actual width of character~|c| in
+font~|f| is stored in |widths[font_width(f)(c)]|.
+
+@d font_check(#)==fnt_check[#] {checksum}
+@d font_scaled(#)==fnt_scaled[#] {scaled or `at' size}
+@d font_design(#)==fnt_design[#] {design size}
+@d font_name(#)==fnt_name[#] {area plus name packet}
+@d font_bc(#)==fnt_bc[#] {first character}
+@d font_ec(#)==fnt_ec[#] {last character}
+@d font_chars(#)==fnt_chars[#] {character info offset}
+@d font_type(#)==fnt_type[#] {type of this font}
+@d font_font(#)==fnt_font[#] {use depends on |font_type|}
+@#
+@d font_width_end(#)==#]
+@d font_width(#)==char_widths[font_chars(#)+font_width_end
+@d font_packet(#)==char_packets[font_chars(#)+font_width_end
+@d font_extend(#)==fnt_extended[#]
+
+@<Glob...@>=
+@!fnt_check:array [font_number] of int_32; {checksum}
+@!fnt_scaled:array [font_number] of int_31; {scaled size}
+@!fnt_design:array [font_number] of int_31; {design size}
+@!device @<Declare device dependent font data arrays@>@; @+ ecived @; @/
+@!fnt_name:array [font_number] of pckt_pointer; {pointer to area plus
+ name packet}
+@!fnt_bc:array [font_number] of int_31; {first character}
+@!fnt_ec:array [font_number] of int_31; {last character}
+@!fnt_chars:array [font_number] of char_offset; {character info offset}
+@!fnt_type:array [font_number] of f_type; {type of font}
+@!fnt_font:array [font_number] of font_number; {use depends on |font_type|}
+@!fnt_extended:array [font_number] of boolean; {\.{TFM} or \.{OFM} file}
+
+@ @d invalid_font==max_fonts {used when there is no valid font}
+
+@<Set init...@>=
+@!device @<Initialize device dependent font data@>@; @+ ecived @;@/
+nf:=0;
+
+@ A \.{VF}, or \.{GF}, or \.{PK} file may contain information for
+several characters with the same residue but with different extension;
+all except the first of the corresponding packets in |byte_mem| will
+contain a pointer to the previous one and |font_packet(f)(res)|
+identifies the last such packet.
+
+A character packet in |byte_mem| starts with a flag byte
+$$\hbox{|flag=@"40*ext_flag+@"20*chain_flag+type_flag|}$$
+with |0<=ext_flag<=3|, |0<=chain_flag<=1|, |0<=type_flag<=@"1F|,
+followed by |ext_flag| bytes with the character extension for this
+packet and, if |chain_flag=1|, by a two byte packet pointer to the
+previous packet for the same font and character residue. The actual
+character packet follows after these header bytes and the
+interpretation of the |type_flag| depends on whether this is a \.{VF}
+packet or a packet for raster data.
+
+The empty packet is interpreted as a special case of a packet with
+|flag=0|.
+
+@d ext_flag=@"40
+@d chain_flag=@"20
+
+@<Types...@>=
+@!type_flag=0..chain_flag-1; {the range of values for the |type_flag|}
+
+@ The global variable |cur_fnt| is the internal font number of the
+currently selected font, or equals |invalid_font| if no font has
+been selected; |cur_res| and |cur_ext| are the residue and extension
+part of the current character code. The type of a character packet
+located by the |find_packet| function defined below is |cur_type|.
+While building a character packet for a character, |pckt_ext| and
+|pckt_res| are the extension and residue of this character; |pckt_dup|
+indicates whether a packet for this extension exists already.
+
+@<Glob...@>=
+@!cur_fnt:font_number; {the currently selected font}
+@!cur_ext:int_24; {the current character extension}
+@!cur_res:int_32; {the current character residue}
+@!cur_type:type_flag; {type of the current character packet}
+@!pckt_ext:int_24; {character extension for the current character packet}
+@!pckt_res:int_32; {character residue for the current character packet}
+@!pckt_dup:boolean; {is there a previous packet for the same extension?}
+@!pckt_prev:pckt_pointer; {a previous packet for the same extension}
+@!pckt_m_msg,@!pckt_s_msg,@!pckt_d_msg:int_7; {counts for various character
+ packet error messages}
+
+@ @<Set init...@>=
+cur_fnt:=invalid_font; pckt_m_msg:=0; pckt_s_msg:=0; pckt_d_msg:=0;
+
+@ The |find_packet| functions is used to locate the character packet for
+the character with residue~|cur_res| and extension~|cur_ext| from
+font~|cur_fnt| and returns |false| if no packet exists for any extension;
+otherwise the result is |true| and the global variables |cur_packet|,
+|cur_type|, |cur_loc|, and |cur_limit| are initialized. In case none of
+the character packets has the correct extension, the last one in the
+chain (the one defined first) is used instead and |cur_ext| is changed
+accordingly.
+
+@p function find_packet:boolean;
+label found,exit;
+var p,@!q:pckt_pointer; {current and next packet}
+@!f:eight_bits; {a flag byte}
+@!e:int_24; {extension for a packet}
+begin @<Locate a character packet and |goto found| if found@>;
+if font_packet(cur_fnt)(cur_res)=invalid_packet then
+ begin if pckt_m_msg<10 then {stop telling after first 10 times}
+ begin print_ln('---missing character packet for character ',cur_res:1,
+@.missing character packet...@>
+ ' font ',cur_fnt:1);
+ incr(pckt_m_msg); mark_error;
+ if pckt_m_msg=10 then print_ln('---further messages suppressed.');
+ end;
+ find_packet:=false; return;
+ end;
+if pckt_s_msg<10 then {stop telling after first 10 times}
+ begin print_ln('---substituted character packet with extension ',
+@.substituted character packet...@>
+ e:1,' instead of ',cur_ext:1,' for character ',cur_res:1,
+ ' font ',cur_fnt:1);
+ incr(pckt_s_msg); mark_error;
+ if pckt_s_msg=10 then print_ln('---further messages suppressed.');
+ end;
+cur_ext:=e;
+found: cur_pckt:=p; cur_type:=f; find_packet:=true;
+exit: end;
+
+@ @<Locate a character packet and |goto found| if found@>=
+q:=font_packet(cur_fnt)(cur_res);
+while q<>invalid_packet do
+ begin p:=q; q:=invalid_packet;
+ cur_loc:=pckt_start[p]; cur_limit:=pckt_start[p+1];
+ if p=empty_packet then
+ begin e:=0; f:=0;
+ end
+ else begin pckt_extract(f);
+ case (f div ext_flag) of
+ 0: e:=0;
+ 1: e:=pckt_ubyte;
+ 2: e:=pckt_upair;
+ 3: e:=pckt_strio;
+ end; {there are no other cases}
+ if (f mod ext_flag)>=chain_flag then q:=pckt_upair;
+ f:=f mod chain_flag;
+ end;
+ if e=cur_ext then goto found;
+ end
+
+@ The |start_packet| procedure is used to create the header bytes of a
+character packet for the character with residue~|cur_res| and
+extension~|cur_ext| from font~|cur_fnt|; if a previous such packet
+exists, we try to build an exact duplicate, i.e., use the chain field of
+that previous packet.
+
+@p procedure start_packet(@!t:type_flag);
+label found,not_found;
+var p,@!q:pckt_pointer; {current and next packet}
+@!f:int_8u; {a flag byte}
+@!e:int_32; {extension for a packet}
+@!cur_loc: byte_pointer; {current location in a packet}
+@!cur_limit: byte_pointer; {start of next packet}
+begin @<Locate a character packet and |goto found| if found@>;
+q:=font_packet(cur_fnt)(cur_res); pckt_dup:=false; goto not_found;
+found: pckt_dup:=true; pckt_prev:=p;
+not_found: pckt_ext:=cur_ext; pckt_res:=cur_res; pckt_room(6);
+@!debug if byte_ptr<>pckt_start[pckt_ptr] then confusion(str_packets);
+gubed @;@/
+if q=invalid_packet then f:=t @+ else f:=t+chain_flag;
+e:=cur_ext;
+if e<0 then Incr(e)(@"1000000);
+if e=0 then append_byte(f) @+ else @;
+ begin if e<@"100 then append_byte(f+ext_flag) @+ else @;
+ begin if e<@"10000 then append_byte(f+ext_flag+ext_flag) @+ else @;
+ begin append_byte(f+ext_flag+ext_flag+ext_flag);
+ append_byte(e div @"10000); e:=e mod @"10000;
+ end;
+ append_byte(e div @"100); e:=e mod @"100;
+ end;
+ append_byte(e);
+ end;
+if q<>invalid_packet then
+ begin append_byte(q div @"100); append_byte(q mod @"100);
+ end;
+end;
+
+@ The |build_packet| procedure is used to finish a character packet.
+If a previous packet for the same character extension exists, the new
+one is discarded; if the two packets are identical, as it occasionally
+occurs for raster files, this is done without an error message.
+
+@p procedure build_packet;
+var k,@!l:byte_pointer; {indices into |byte_mem|}
+begin if pckt_dup then
+ begin k:=pckt_start[pckt_prev+1]; l:=pckt_start[pckt_ptr];
+ if (byte_ptr-l)<>(k-pckt_start[pckt_prev]) then pckt_dup:=false;
+ while pckt_dup and(byte_ptr>l) do
+ begin flush_byte; decr(k);
+ if byte_mem[byte_ptr]<>byte_mem[k] then pckt_dup:=false;
+ end;
+ if (not pckt_dup)and(pckt_d_msg<10) then {stop telling after first 10 times}
+ begin print('---duplicate packet for character ',pckt_res:1);
+@.duplicate packet for character...@>
+ if pckt_ext<>0 then print('.',pckt_ext:1);
+ print_ln(' font ',cur_fnt:1);
+ incr(pckt_d_msg); mark_error;
+ if pckt_d_msg=10 then print_ln('---further messages suppressed.');
+ end;
+ byte_ptr:=l;
+ end
+else font_packet(cur_fnt)(pckt_res):=make_packet;
+end;
+
+@* Defining fonts.
+A detailed description of the \.{TFM} file format can be found in the
+documentation of \TeX, \MF, or \.{TFtoPL}. In order to read \.{TFM}
+files the program uses the binary file variable |tfm_file|.
+
+@<Glob...@>=
+@!tfm_file:byte_file; {a \.{TFM} file}
+@!tfm_ext:pckt_pointer; {extension for \.{TFM} files}
+@!ofm_ext:pckt_pointer; {extension for \.{OFM} files}
+
+@ @<Initialize predefined strings@>=
+id4(".")("T")("F")("M")(tfm_ext); {file name extension for \.{TFM} files}
+id4(".")("O")("F")("M")(ofm_ext); {file name extension for \.{OFM} files}
+
+@ If no font directory has been specified, \.{\title} is supposed to use
+the default \.{TFM} directory, which is a system-dependent place where
+the \.{TFM} files for standard fonts are kept.
+The string variable |TFM_default_area| contains the name of this area.
+@^system dependencies@>
+
+@d TFM_default_area_name=='TeXfonts:' {change this to the correct name}
+@d OFM_default_area_name=='TeXfonts:' {change this to the correct name}
+@d TFM_default_area_name_length=9 {change this to the correct length}
+@d OFM_default_area_name_length=9 {change this to the correct length}
+
+@<Glob...@>=
+@!TFM_default_area:packed array[1..TFM_default_area_name_length] of char;
+@!OFM_default_area:packed array[1..OFM_default_area_name_length] of char;
+
+@ @<Set init...@>=
+TFM_default_area:=TFM_default_area_name;
+OFM_default_area:=OFM_default_area_name;
+
+@ If a \.{TFM} file is badly malformed, we say |bad_font|; for a \.{TFM}
+file the |bad_tfm| procedure is used to give an error message which
+refers the user to \.{TFtoPL} and \.{PLtoTF}, and terminates \.{\title}.
+
+@<Error handling...@>=
+procedure bad_tfm;
+begin print('Bad TFM or OFM file'); print_font(cur_fnt); print_ln('!');
+@.Bad TFM or OFM file@>
+abort('Use OFM2OPL/OPL2OFM/TFtoPL/PLtoTF to diagnose and correct the problem');
+@.Use OFM2OPL/OPL2OFM/TFtoPL/PLtoTF@>
+end;
+@#
+procedure bad_font;
+begin new_line;
+case font_type(cur_fnt) of
+ defined_font: confusion(str_fonts);
+ loaded_font: bad_tfm;
+ @<Cases for |bad_font|@>@;@/
+ end; {there are no other cases}
+end;
+
+@ To prepare |tfm_file| for input we |reset| it.
+
+@<TFM: Open |tfm_file|@>=
+make_font_name(TFM_default_area_name_length)(TFM_default_area)(tfm_ext);
+reset(tfm_file,cur_name);
+if eof(tfm_file) then begin
+ make_font_name(OFM_default_area_name_length)(OFM_default_area)(ofm_ext);
+ reset(tfm_file,cur_name);
+ if eof(tfm_file) then
+@^system dependencies@>
+ abort('---not loaded, TFM or OFM file can''t be opened!')
+ else font_extend(cur_fnt):=true
+@.TFM or OFM file can\'t be opened@>
+ end
+else font_extend(cur_fnt):=false
+
+@ It turns out to be convenient to read four bytes at a time, when we
+are inputting from \.{TFM} files. The input goes into global variables
+|tfm_b0|, |tfm_b1|, |tfm_b2|, and |tfm_b3|, with |tfm_b0| getting
+the first byte and |tfm_b3| the fourth.
+
+@<Glob...@>=
+@!tfm_b0,@!tfm_b1,@!tfm_b2,@!tfm_b3: eight_bits; {four bytes input at once}
+
+@ Reading a \.{TFM} file should be done as efficient as possible for a
+particular system; on many systems this means that a large number of
+bytes from |tfm_file| is read into a buffer and will then be extracted
+from that buffer. In order to simplify such system dependent changes
+we use the \.{WEB} macro |tfm_byte| to extract the next \.{TFM} or \.{OFM}
+byte; this macro and |eof(tfm_file)| are used only in the |read_tfm_word|
+procedure which sets |tfm_b0| through |tfm_b3| to the next four bytes
+in the current \.{TFM} file. Here we give simple-minded definitions in
+terms of standard \PASCAL.
+@^system dependencies@>
+@^optimization@>
+
+@d tfm_byte(#)==read(tfm_file,#) {read next \.{TFM} byte}
+
+@p procedure read_tfm_word;
+begin tfm_byte(tfm_b0); tfm_byte(tfm_b1);
+tfm_byte(tfm_b2); tfm_byte(tfm_b3);
+if eof(tfm_file) then bad_font;
+end;
+
+@ Here are three procedures used to check the consistency of font files:
+First, the |check_check_sum| procedure compares two check sum values: a
+warning is given if they differ and are both non-zero; if the second
+value is not zero it may replace the first one.
+Next, the |check_design_size| procedure compares two design size
+values: a warning is given if they differ by more than a small amount.
+Finally, the |check_width| function compares the character width value
+for character |cur_res| read from a \.{VF} or raster file for font
+|cur_fnt| with the value previously read from the \.{TFM} file and
+returns the width pointer for that value; a warning is given if the two
+values differ.
+
+@p procedure check_check_sum(@!c:int_32;@!u:boolean);
+ {compare |font_check(cur_fnt)| with |c|}
+begin if (c<>font_check(cur_fnt))and(c<>0) then
+ begin
+ if font_check(cur_fnt)<>0 then
+ begin new_line; print_ln('---beware: check sums do not agree! (',
+@.beware: check sums do not agree@>
+@.check sums do not agree@>
+ c:1,' vs. ',font_check(cur_fnt):1,')');
+ mark_harmless;
+ end;
+ if u then font_check(cur_fnt):=c;
+ end;
+end;
+@#
+procedure check_design_size(@!d:int_32);
+ {compare |font_design(cur_fnt)| with |d|}
+begin if abs(d-font_design(cur_fnt))>2 then
+ begin new_line; print_ln('---beware: design sizes do not agree! (',
+@.beware: design sizes do not agree@>
+@.design sizes do not agree@>
+ d:1,' vs. ',font_design(cur_fnt):1,')');
+ mark_error;
+ end;
+end;
+@#
+procedure print_hex(@!num:int_31);
+var c:int_31;
+begin print('"');
+c:=num div @"10000000;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"10000000;
+c:=num div @"1000000;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"1000000;
+c:=num div @"100000;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"100000;
+c:=num div @"10000;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"10000;
+c:=num div @"1000;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"1000;
+c:=num div @"100;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"100;
+c:=num div @"10;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+num:=num mod @"10;
+c:=num;
+if (c<10) then print(xchr[c+'0']) else print(xchr[c-10+'a']);
+end;
+@#
+function check_width(w:int_32):width_pointer;
+ {compare |widths[font_width(cur_fnt)(cur_res)]| with |w|}
+var wp:width_pointer; {pointer to \.{TFM} width value}
+begin if (cur_res>=font_bc(cur_fnt))and(cur_res<=font_ec(cur_fnt)) then
+ wp:=font_width(cur_fnt)(cur_res)
+else wp:=invalid_width;
+if wp=invalid_width then
+ begin print_nl('Bad char ',cur_res:1);
+@.Bad char c@>
+ if cur_ext<>0 then print('.',cur_ext:1);
+ print(' font ',cur_fnt:1); print_font(cur_fnt);
+ abort(' (compare TFM or OFM file)');
+ end;
+if w<>widths[wp] then
+ begin
+ print_hex(cur_ext);
+ print(' ');
+ print_hex(cur_res);
+ print(': char widths do not agree! (');
+@.beware: char widths do not agree@>
+@.char widths do not agree@>
+ print_hex(w);
+ print(' vs. ');
+ print_hex(widths[wp]);
+ print_ln(')');
+ mark_error;
+ end;
+check_width:=wp;
+end;
+
+@ The |load_font| procedure reads the \.{TFM} file for a font and puts
+the data extracted into position |cur_fnt| of the font data arrays.
+
+@p procedure load_font; {reads a \.{TFM} file}
+var l,j,lprime:int_32; {loop index}
+@!p:char_pointer; {index into |char_widths|}
+@!q:width_pointer; {index into |widths|}
+@!bc,@!ec:int_31; {first and last character in this font}
+@!lf:int_31; {length of file in four byte words}
+@!lh:int_31; {length of header in four byte words}
+@!nw:int_31; {number of words in width table}
+@!w:int_32; {a four byte integer}
+@!first_two:int_31;
+@!ofm_level:int_32;
+@!nco,@!extra_words:int_31;
+@!tfm_width:int_31;
+@<Variables for scaling computation@>@;
+begin print('TFM: font ',cur_fnt:1); print_font(cur_fnt);
+font_type(cur_fnt):=loaded_font;
+@<TFM: Open |tfm_file|@>;
+@<TFM: Read past the header data@>;
+@<TFM: Store character-width indices@>;
+@<TFM: Read and convert the width values@>;
+@<TFM: Convert character-width indices to character-width pointers@>;
+close_in(tfm_file);
+@!device @<Initialize device dependent data for a font@>@; @+ ecived @; @/
+d_print(' loaded at ',font_scaled(cur_fnt):1,' DVI units');
+print_ln('.');
+end;
+
+@ @<Glob...@>=
+@!tfm_conv:real; {\.{DVI} units per absolute \.{TFM} unit}
+
+@ We will use the following \.{WEB} macros to construct integers from
+two or four of the four bytes read by |read_tfm_word|.
+@^system dependencies@>
+
+@d tfm_b03(#)== {|tfm_b0..tfm_b3| as non-negative integer}
+if tfm_b0>127 then bad_font
+else #:=tfm_b0*@"1000000+tfm_b1*@"10000+tfm_b2*@"100+tfm_b3
+
+@d tfm_b01(#)== {|tfm_b0..tfm_b1| as non-negative integer}
+if tfm_b0>127 then bad_font
+else #:=tfm_b0*256+tfm_b1
+@d tfm_b23(#)== {|tfm_b2..tfm_b3| as non-negative integer}
+if tfm_b2>127 then bad_font
+else #:=tfm_b2*256+tfm_b3
+@d tfm_squad(#)== {|tfm_b0..tfm_b3| as signed integer}
+if tfm_b0<128 then #:=((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3
+else #:=(((tfm_b0-256)*256+tfm_b1)*256+tfm_b2)*256+tfm_b3
+@d tfm_uquad== {|tfm_b0..tfm_b3| as unsigned integer}
+(((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3)
+
+@d read_tfm_width(#)==begin
+read_tfm_word;
+if first_two<>0 then tfm_width:=tfm_b0
+else begin
+ if # then read_tfm_word;
+ tfm_b01(tfm_width);
+ end
+end
+
+@<TFM: Read past the header data@>=
+read_tfm_word; tfm_b01(first_two);
+if (first_two<>0) then begin
+ ofm_level:=-1;
+ tfm_b23(lh);
+ read_tfm_word; tfm_b01(bc); tfm_b23(ec);
+ if ec<bc then
+ begin bc:=1; ec:=0;
+ end
+ else if ec>255 then bad_font;
+ read_tfm_word; tfm_b01(nw);
+ if (nw=0)or(nw>256) then bad_font;
+ for l:=-2 to lh do
+ begin read_tfm_word;
+ if l=1 then
+ begin tfm_squad(w); check_check_sum(w,true);
+ end
+ else if l=2 then
+ begin if tfm_b0>127 then bad_font;
+ check_design_size(round(tfm_conv*tfm_uquad));
+ end
+ end
+ end
+else begin
+ tfm_b23(ofm_level);
+ read_tfm_word; tfm_b03(lf);
+ read_tfm_word; tfm_b03(lh);
+ read_tfm_word; tfm_b03(bc);
+ read_tfm_word; tfm_b03(ec);
+ if ec<bc then begin
+ bc:=1; ec:=0;
+ end
+ else if ec>65535 then bad_font;
+ read_tfm_word; tfm_b03(nw);
+ if (nw=0)or(nw>65536) then bad_font;
+ for l:=1 to 8 do
+ begin if eof(tfm_file) then bad_font;
+ read_tfm_word;
+ end;
+ if ofm_level=1 then begin
+ read_tfm_word;
+ nco:=(((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3) div 2;
+ read_tfm_word; read_tfm_word;
+ extra_words:=(((tfm_b0*256+tfm_b1)*256+tfm_b2)*256+tfm_b3) div 2;
+ for l:=1 to 12 do
+ begin if eof(tfm_file) then bad_font;
+ read_tfm_word;
+ end;
+ end;
+ for l:=1 to lh do begin
+ read_tfm_word;
+ if l=1 then begin
+ tfm_squad(w); check_check_sum(w,true);
+ end
+ else if l=2 then begin
+ if tfm_b0>127 then bad_font;
+ check_design_size(round(tfm_conv*tfm_uquad));
+ end
+ end;
+ if ofm_level>0 then
+ for l:=1 to (nco-29-lh) do
+ read_tfm_word;
+ end
+
+@ The width indices for the characters are stored in positions |n_chars|
+through |n_chars-bc+ec| of the |char_widths| array; if characters on
+either end of the range |bc..ec| do not exist, they are ignored and the
+range is adjusted accordingly.
+
+@<TFM: Store character-width indices@>=
+if ofm_level<=0 then begin
+ read_tfm_width(false);
+ while (tfm_width=0)and(bc<=ec) do
+ begin incr(bc); read_tfm_width(true);
+ end;
+ font_bc(cur_fnt):=bc; font_chars(cur_fnt):=n_chars-bc;
+ if ec>=max_chars-font_chars(cur_fnt) then overflow(str_chars,max_chars);
+ for l:=bc to ec do
+ begin char_widths[n_chars]:=tfm_width; incr(n_chars); read_tfm_width(true);
+ end;
+ while (char_widths[n_chars-1]=0)and(ec>=bc) do
+ begin decr(n_chars); decr(ec);
+ end;
+ font_ec(cur_fnt):=ec
+ end
+else begin
+ font_bc(cur_fnt):=bc; font_chars(cur_fnt):=n_chars-bc;
+ if ec>=max_chars-font_chars(cur_fnt) then overflow(str_chars,max_chars);
+ font_ec(cur_fnt):=ec;
+ l:=bc;
+ while l<ec do begin
+ read_tfm_word;
+ tfm_width:=tfm_b0*256+tfm_b1;
+ char_widths[n_chars]:=tfm_width; incr(n_chars);
+ read_tfm_word; read_tfm_word;
+ lprime:=l+(tfm_b0*256+tfm_b1);
+ for j:=l+1 to lprime do begin
+ char_widths[n_chars]:=tfm_width; incr(n_chars);
+ end;
+ l:=lprime;
+ for j:=1 to extra_words do
+ read_tfm_word;
+ end;
+ read_tfm_word;
+ end
+
+@ The most important part of |load_font| is the width computation, which
+involves multiplying the relative widths in the \.{TFM} file by the
+scaling factor in the \.{DVI} file. A similar computation is used for
+dimensions read from \.{VF} files. This fixed-point multiplication must
+be done with precisely the same accuracy by all \.{DVI}-reading programs,
+in order to validate the assumptions made by \.{DVI}-writing programs
+like \TeX82.
+
+Let us therefore summarize what needs to be done. Each width in a \.{TFM}
+file appears as a four-byte quantity called a |fix_word|. A |fix_word|
+whose respective bytes are $(a,b,c,d)$ represents the number
+$$x=\left\{\vcenter{\halign{$#$,\hfil\qquad&if $#$\hfil\cr
+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=0;\cr
+-16+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=255.\cr}}\right.$$
+(No other choices of $a$ are allowed, since the magnitude of a \.{TFM}
+dimension must be less than 16.) We want to multiply this quantity by the
+integer~|z|, which is known to be less than $2^{27}$.
+If $|z|<2^{23}$, the individual multiplications $b\cdot z$, $c\cdot z$,
+$d\cdot z$ cannot overflow; otherwise we will divide |z| by 2, 4, 8, or
+16, to obtain a multiplier less than $2^{23}$, and we can compensate for
+this later. If |z| has thereby been replaced by $|z|^\prime=|z|/2^e$, let
+$\beta=2^{4-e}$; we shall compute
+$$\lfloor(b+c\cdot2^{-8}+d\cdot2^{-16})\,z^\prime/\beta\rfloor$$ if $a=0$,
+or the same quantity minus $\alpha=2^{4+e}z^\prime$ if $a=255$.
+This calculation must be done exactly, for the reasons stated above; the
+following program does the job in a system-independent way, assuming
+that arithmetic is exact on numbers less than $2^{31}$ in magnitude. We
+use \.{WEB} macros for various versions of this computation.
+@^system dependencies@>
+@^optimization@>
+
+@d tfm_fix3u== {convert |tfm_b1..tfm_b3| to an unsigned scaled dimension}
+(((((tfm_b3*z)div@'400)+(tfm_b2*z))div@'400)+(tfm_b1*z))div beta
+@#
+@d tfm_fix4(#)== {convert |tfm_b0..tfm_b3| to a scaled dimension}
+ #:=tfm_fix3u;
+ if tfm_b0>0 then if tfm_b0=255 then Decr(#)(alpha) else bad_font
+@d tfm_fix3(#)== {convert |tfm_b1..tfm_b3| to a scaled dimension}
+ #:=tfm_fix3u; @+ if tfm_b1>127 then Decr(#)(alpha)
+@d tfm_fix2== {convert |tfm_b2..tfm_b3| to a scaled dimension}
+ if tfm_b2>127 then tfm_b1:=255 else tfm_b1:=0;
+ tfm_fix3
+@d tfm_fix1== {convert |tfm_b3| to a scaled dimension}
+ if tfm_b3>127 then tfm_b1:=255 else tfm_b1:=0;
+ tfm_b2:=tfm_b1; tfm_fix3
+
+@<Variables for scaling computation@>=
+@!z:int_32; {multiplier}
+@!alpha:int_32; {correction for negative values}
+@!beta:int_15; {divisor}
+
+@ @<Replace |z| by $|z|^\prime$ and compute $\alpha,\beta$@>=
+alpha:=16;
+while z>=@'40000000 do
+ begin z:=z div 2; alpha:=alpha+alpha;
+ end;
+beta:=256 div alpha; alpha:=alpha*z
+
+@ The first width value, which indicates that a character does not exist
+and which must vanish, is converted to |invalid_width|; the other width
+values are scaled by |font_scaled(cur_fnt)| and converted to width
+pointers by |make_width|. The resulting width pointers are stored
+temporarily in the |char_widths| array, following the with indices.
+
+@<TFM: Read and convert the width values@>=
+if nw-1>max_chars-n_chars then overflow(str_chars,max_chars);
+if (tfm_b0<>0)or(tfm_b1<>0)or(tfm_b2<>0)or(tfm_b3<>0) then bad_font
+ else char_widths[n_chars]:=invalid_width;
+z:=font_scaled(cur_fnt);
+@<Replace |z|...@>;
+for p:=n_chars+1 to n_chars+nw-1 do
+ begin read_tfm_word; tfm_fix4(w);
+ char_widths[p]:=make_width(w);
+ end
+
+@ We simply translate the width indices into width pointers. In addition
+we initialize the character packets with the invalid packet.
+
+@<TFM: Convert character-width indices to character-width pointers@>=
+for p:=font_chars(cur_fnt)+bc to n_chars-1 do
+ begin q:=char_widths[n_chars+char_widths[p]]; char_widths[p]:=q;
+ char_packets[p]:=invalid_packet;
+ end
+
+@ When processing a font definition we put the data extracted from the
+\.{DVI} or \.{VF} file into position |nf| of the font data arrays and
+call |define_font| to obtain the internal font number for this font.
+The parameter |load| is true if the \.{TFM} file should be loaded.
+
+@p function define_font(@!load:boolean):font_number;
+var save_fnt:font_number; {used to save |cur_fnt|}
+begin save_fnt:=cur_fnt; {save}
+cur_fnt:=0;
+while (font_name(cur_fnt)<>font_name(nf))or@|
+ (font_scaled(cur_fnt)<>font_scaled(nf)) do incr(cur_fnt);
+d_print(' => ',cur_fnt:1); print_font(cur_fnt);
+if cur_fnt<nf then
+ begin check_check_sum(font_check(nf),true);
+ check_design_size(font_design(nf));
+ @!debug if font_type(cur_fnt)=defined_font then print(' defined')
+ else print(' loaded');
+ print(' previously');
+ gubed@;
+ end
+else begin if nf=max_fonts then overflow(str_fonts,max_fonts);
+ incr(nf); font_font(cur_fnt):=invalid_font;
+ font_type(cur_fnt):=defined_font;
+ d_print(' defined');
+ end;
+print_ln('.');
+if load and(font_type(cur_fnt)=defined_font) then load_font;
+define_font:=cur_fnt;
+cur_fnt:=save_fnt; {restore}
+end;
+
+@* Low-level DVI input routines.
+The program uses the binary file variable |dvi_file| for its main input
+file; |dvi_loc| is the number of the byte about to be read next from
+|dvi_file|.
+
+@<Glob...@>=
+@!dvi_file:byte_file; {the stuff we are \.{\title}ing}
+@!dvi_loc:int_32; {where we are about to look, in |dvi_file|}
+
+@ If the \.{DVI} file is badly malformed, we say |bad_dvi|; this
+procedure gives an error message which refers the user to \.{DVItype},
+and terminates \.{\title}.
+
+@<Error handling...@>=
+procedure bad_dvi;
+begin new_line; print_ln('Bad DVI file: loc=',dvi_loc:1,'!');
+@.Bad DVI file@>
+print(' Use DVItype with output level');
+@.Use DVItype@>
+if random_reading then print('=4') @+ else print('<4');
+abort('to diagnose the problem');
+end;
+
+@ To prepare |dvi_file| for input, we |reset| it.
+
+@<Open input file(s)@>=
+reset(dvi_file); {prepares to read packed bytes from |dvi_file|}
+dvi_loc:=0;
+
+@ Reading the \.{DVI} file should be done as efficient as possible for a
+particular system; on many systems this means that a large number of
+bytes from |dvi_file| is read into a buffer and will then be extracted
+from that buffer. In order to simplify such system dependent changes
+we use a pair of \.{WEB} macros: |dvi_byte| extracts the next \.{DVI}
+byte and |dvi_eof| is |true| if we have reached the end of the \.{DVI}
+file. Here we give simple minded definitions for these macros in terms
+of standard \PASCAL.
+@^system dependencies@>
+@^optimization@>
+
+@d dvi_eof == eof(dvi_file) {has the \.{DVI} file been exhausted?}
+@d dvi_byte(#) ==
+ if dvi_eof then bad_dvi
+ else read(dvi_file,#) {obtain next \.{DVI} byte}
+
+@ Next we come to the routines that are used only if |random_reading| is
+|true|. The driver program below needs two such routines: |dvi_length| should
+compute the total number of bytes in |dvi_file|, possibly also
+causing |eof(dvi_file)| to be true; and |dvi_move(n)| should position
+|dvi_file| so that the next |dvi_byte| will read byte |n|, starting with
+|n=0| for the first byte in the file.
+@^system dependencies@>
+
+Such routines are, of course, highly system dependent. They are implemented
+here in terms of two assumed system routines called |set_pos| and |cur_pos|.
+The call |set_pos(f,n)| moves to item |n| in file |f|, unless |n| is
+negative or larger than the total number of items in |f|; in the latter
+case, |set_pos(f,n)| moves to the end of file |f|.
+The call |cur_pos(f)| gives the total number of items in |f|, if
+|eof(f)| is true; we use |cur_pos| only in such a situation.
+
+@p function dvi_length:int_32;
+begin set_pos(dvi_file,-1); dvi_length:=cur_pos(dvi_file);
+end;
+@#
+procedure dvi_move(@!n:int_32);
+begin set_pos(dvi_file,n); dvi_loc:=n;
+end;
+
+@ We need seven simple functions to read the next byte or bytes
+from |dvi_file|.
+
+@p function dvi_sbyte:int_8; {returns the next byte, signed}
+@!begin_byte(dvi_byte); incr(dvi_loc); comp_sbyte(dvi_sbyte);
+end;
+@#
+function dvi_ubyte:int_8u; {returns the next byte, unsigned}
+@!begin_byte(dvi_byte); incr(dvi_loc); comp_ubyte(dvi_ubyte);
+end;
+@#
+function dvi_spair:int_16; {returns the next two bytes, signed}
+@!begin_pair(dvi_byte); Incr(dvi_loc)(2); comp_spair(dvi_spair);
+end;
+@#
+function dvi_upair:int_16u; {returns the next two bytes, unsigned}
+@!begin_pair(dvi_byte); Incr(dvi_loc)(2); comp_upair(dvi_upair);
+end;
+@#
+function dvi_strio:int_24; {returns the next three bytes, signed}
+@!begin_trio(dvi_byte); Incr(dvi_loc)(3); comp_strio(dvi_strio);
+end;
+@#
+function dvi_utrio:int_24u; {returns the next three bytes, unsigned}
+@!begin_trio(dvi_byte); Incr(dvi_loc)(3); comp_utrio(dvi_utrio);
+end;
+@#
+function dvi_squad:int_32; {returns the next four bytes, signed}
+@!begin_quad(dvi_byte); Incr(dvi_loc)(4); comp_squad(dvi_squad);
+end;
+
+@ Three other functions are used in cases where a four byte integer
+(which is always signed) must have a non-negative value, a positive
+value, or is a pointer which must be either positive or |=-1|.
+
+@p function dvi_uquad:int_31; {result must be non-negative}
+var x:int_32;
+begin x:=dvi_squad; if x<0 then bad_dvi
+else dvi_uquad:=x;
+end;
+@#
+function dvi_pquad:int_31; {result must be positive}
+var x:int_32;
+begin x:=dvi_squad; if x<=0 then bad_dvi
+else dvi_pquad:=x;
+end;
+@#
+function dvi_pointer:int_32; {result must be positive or |=-1|}
+var x:int_32;
+begin x:=dvi_squad; if (x<=0)and(x<>-1) then bad_dvi
+else dvi_pointer:=x;
+end;
+
+@ Given the structure of the \.{DVI} commands it is fairly obvious
+that their interpretation consists of two steps: First zero to four
+bytes are read in order to obtain the value of the first parameter
+(e.g., zero bytes for |set_char_0|, four bytes for |set4|); then,
+depending on the command class, a specific action is performed (e.g.,
+typeset a character but don't move the reference point for |put1..put4|).
+
+The \.{DVItype} program uses large case statements for both steps;
+unfortunately some \PASCAL\ compilers fail to implement large case
+statements efficiently -- in particular those as the one used in the
+|first_par| function of \.{DVItype}. Here we use a pair of look up tables:
+|dvi_par| determines how to obtain the value of the first parameter, and
+|dvi_cl| determines the command class.
+
+A slight complication arises from the fact that we want to decompose the
+character code of each character to be typeset into a residue
+|0<=char_res<256| and extension: |char_code=char_res+256*char_ext|;
+the \.{TFM} widths as well as the pixel widths for a given resolution
+are the same for all characters in a font with the same residue.
+For \.{OFM} files, |char_res| can have any value and |char_ext=0|.
+
+@d two_cases(#)==#,#+1
+@d three_cases(#)==#,#+1,#+2
+@d five_cases(#)==#,#+1,#+2,#+3,#+4
+
+@ First we define the values used as array elements of |dvi_par|; we
+distinguish between pure numbers and dimensions because dimensions read
+from a \.{VF} file must be scaled.
+
+@d char_par=0 {character for \\{set} and |put|}
+@d no_par=1 {no parameter}
+@d dim1_par=2 {one-byte signed dimension}
+@d num1_par=3 {one-byte unsigned number}
+@d dim2_par=4 {two-byte signed dimension}
+@d num2_par=5 {two-byte unsigned number}
+@d dim3_par=6 {three-byte signed dimension}
+@d num3_par=7 {three-byte unsigned number}
+@d dim4_par=8 {four-byte signed dimension}
+@d num4_par=9 {four-byte signed number}
+@d numu_par=10 {four-byte non-negative number}
+@d rule_par=11 {dimensions for |set_rule| and |put_rule|}
+@d fnt_par=12 {font for |fnt_num| commands}
+@d max_par=12 {largest possible value}
+
+@<Types...@>=
+@!cmd_par=char_par..max_par;
+
+@ Here we declare the array |dvi_par|.
+
+@<Globals...@>=
+@!dvi_par:packed array [eight_bits] of cmd_par;
+
+@ And here we initialize it.
+
+@<Set init...@>=
+for i:=0 to put1+3 do dvi_par[i]:=char_par;@/
+for i:=nop to 255 do dvi_par[i]:=no_par;@/
+dvi_par[set_rule]:=rule_par; dvi_par[put_rule]:=rule_par;@/
+dvi_par[right1]:=dim1_par; dvi_par[right1+1]:=dim2_par;
+dvi_par[right1+2]:=dim3_par; dvi_par[right1+3]:=dim4_par;@/
+for i:=fnt_num_0 to fnt_num_0+63 do dvi_par[i]:=fnt_par;@/
+dvi_par[fnt1]:=num1_par; dvi_par[fnt1+1]:=num2_par;
+dvi_par[fnt1+2]:=num3_par; dvi_par[fnt1+3]:=num4_par;@/
+dvi_par[xxx1]:=num1_par; dvi_par[xxx1+1]:=num2_par;
+dvi_par[xxx1+2]:=num3_par; dvi_par[xxx1+3]:=numu_par;@/
+for i:=0 to 3 do
+ begin dvi_par[i+w1]:=dvi_par[i+right1];
+ dvi_par[i+x1]:=dvi_par[i+right1];
+ dvi_par[i+down1]:=dvi_par[i+right1];
+ dvi_par[i+y1]:=dvi_par[i+right1];
+ dvi_par[i+z1]:=dvi_par[i+right1];
+ dvi_par[i+fnt_def1]:=dvi_par[i+fnt1];
+ end;
+
+@ Next we define the values used as array elements of |dvi_cl|;
+several \.{DVI} commands (e.g., |nop|, |bop|, |eop|, |pre|, |post|) will
+always be treated separately and are therfore assigned to the invalid
+class here.
+
+@d char_cl=0
+@d rule_cl=char_cl+1
+@d xxx_cl=char_cl+2
+@d push_cl=3
+@d pop_cl=4
+@d w0_cl=5
+@d x0_cl=w0_cl+1
+@d right_cl=w0_cl+2
+@d w_cl=w0_cl+3
+@d x_cl=w0_cl+4
+@d y0_cl=10
+@d z0_cl=y0_cl+1
+@d down_cl=y0_cl+2
+@d y_cl=y0_cl+3
+@d z_cl=y0_cl+4
+@d fnt_cl=15
+@d fnt_def_cl=16
+@d invalid_cl=17
+@d max_cl=invalid_cl {largest possible value}
+
+@<Types...@>=
+@!cmd_cl=char_cl..max_cl;
+
+@ Here we declare the array |dvi_cl|.
+
+@<Globals...@>=
+@!dvi_cl:packed array [eight_bits] of cmd_cl;
+
+@ And here we initialize it.
+
+@<Set init...@>=
+for i:=set_char_0 to put1+3 do dvi_cl[i]:=char_cl;
+dvi_cl[set_rule]:=rule_cl; dvi_cl[put_rule]:=rule_cl;@/
+dvi_cl[nop]:=invalid_cl;
+dvi_cl[bop]:=invalid_cl; dvi_cl[eop]:=invalid_cl;@/
+dvi_cl[push]:=push_cl; dvi_cl[pop]:=pop_cl;@/
+dvi_cl[w0]:=w0_cl; dvi_cl[x0]:=x0_cl;@/
+dvi_cl[y0]:=y0_cl; dvi_cl[z0]:=z0_cl;@/
+for i:=0 to 3 do
+ begin dvi_cl[i+right1]:=right_cl;
+ dvi_cl[i+w1]:=w_cl;
+ dvi_cl[i+x1]:=x_cl;@/
+ dvi_cl[i+down1]:=down_cl;
+ dvi_cl[i+y1]:=y_cl;
+ dvi_cl[i+z1]:=z_cl;@/
+ dvi_cl[i+xxx1]:=xxx_cl;
+ dvi_cl[i+fnt_def1]:=fnt_def_cl;
+ end;
+for i:=fnt_num_0 to fnt1+3 do dvi_cl[i]:=fnt_cl;
+for i:=pre to 255 do dvi_cl[i]:=invalid_cl;
+
+@ A few small arrays are used to generate \.{DVI} commands.
+
+@<Glob...@>=
+@!dvi_char_cmd:array[boolean] of eight_bits; {|put1| and |set1|}
+@!dvi_rule_cmd:array[boolean] of eight_bits; {|put_rule| and |set_rule|}
+@!dvi_right_cmd:array[right_cl..x_cl] of eight_bits; {|right1|, |w1|, and |x1|}
+@!dvi_down_cmd:array[down_cl..z_cl] of eight_bits; {|down1|, |y1|, and |z1|}
+
+@ @<Set init...@>=
+dvi_char_cmd[false]:=put1;
+dvi_char_cmd[true]:=set1;@/
+dvi_rule_cmd[false]:=put_rule;
+dvi_rule_cmd[true]:=set_rule;@/
+dvi_right_cmd[right_cl]:=right1;
+dvi_right_cmd[w_cl]:=w1;
+dvi_right_cmd[x_cl]:=x1;@/
+dvi_down_cmd[down_cl]:=down1;
+dvi_down_cmd[y_cl]:=y1;
+dvi_down_cmd[z_cl]:=z1;
+
+@ The global variables |cur_cmd|, |cur_parm| and |cur_class| are used
+for the current \.{DVI} command, its first parameter (if any), and its
+command class respectively.
+
+@<Glob...@>=
+@!cur_cmd:eight_bits; {current \.{DVI} command byte}
+@!cur_parm:int_32; {its first parameter (if any)}
+@!cur_class:cmd_cl; {its class}
+
+@ When typesetting a character or rule, the boolean variable |cur_upd|
+is |true| for \\{set} commands, |false| for |put| commands.
+
+@<Glob...@>=
+@!cur_cp:char_pointer; {|char_widths| index for the current character}
+@!cur_wp:width_pointer; {width pointer of the current character}
+@!cur_upd:boolean; {is this a \\{set} or |set_rule| command ?}
+@!cur_v_dimen:int_32; {a vertical dimension}
+@!cur_h_dimen:int_32; {a horizontal dimension}
+
+@ @<Set init...@>=
+cur_cp:=0; cur_wp:=invalid_width; {so they can be saved and restored!}
+
+@ The |dvi_first_par| procedure first reads \.{DVI} command bytes into
+|cur_cmd| until |cur_cmd<>nop|; then |cur_parm| is set to the value of
+the first parameter (if any) and |cur_class| to the command class.
+
+@d set_cur_char(#)== {set up |cur_res|, |cur_ext|, and |cur_upd|}
+begin cur_ext:=0;
+if cur_cmd<set1 then
+ begin cur_res:=cur_cmd; cur_upd:=true
+ end
+else begin cur_res:=#; cur_upd:=(cur_cmd<put1);
+ Decr(cur_cmd)(dvi_char_cmd[cur_upd]);
+ if font_extend(cur_fnt) then
+ begin
+ cur_ext:=0;
+ while cur_cmd>0 do
+ begin
+ cur_res:=cur_res*256+#; decr(cur_cmd);
+ end
+ end
+ else
+ while cur_cmd>0 do
+ begin if cur_cmd=3 then if cur_res>127 then cur_ext:=-1;
+ cur_ext:=cur_ext*256+cur_res; cur_res:=#; decr(cur_cmd);
+ end;
+ end;
+end
+
+@p procedure dvi_first_par;
+begin repeat cur_cmd:=dvi_ubyte;
+until cur_cmd<>nop; {skip over |nop|s}
+case dvi_par[cur_cmd] of
+char_par: set_cur_char(dvi_ubyte);
+no_par: do_nothing;
+dim1_par: cur_parm:=dvi_sbyte;
+num1_par: cur_parm:=dvi_ubyte;
+dim2_par: cur_parm:=dvi_spair;
+num2_par: cur_parm:=dvi_upair;
+dim3_par: cur_parm:=dvi_strio;
+num3_par: cur_parm:=dvi_utrio;
+two_cases(dim4_par): cur_parm:=dvi_squad; {|dim4_par| and |num4_par|}
+numu_par: cur_parm:=dvi_uquad;
+rule_par:
+ begin cur_v_dimen:=dvi_squad; cur_h_dimen:=dvi_squad;
+ cur_upd:=(cur_cmd=set_rule);
+ end;
+fnt_par:cur_parm:=cur_cmd-fnt_num_0;
+end; {there are no other cases}
+cur_class:=dvi_cl[cur_cmd];
+end;
+
+@ The global variable |dvi_nf| is used for the number of different
+\.{DVI} fonts defined so far; their external font numbers (as extracted
+from the \.{DVI} file) are stored in the array |dvi_e_fnts|, the
+corresponding internal font numbers used internally by \.{\title} are
+stored in the array |dvi_i_fnts|.
+
+@<Glob...@>=
+@!dvi_e_fnts:array[font_number] of int_32; {external font numbers}
+@!dvi_i_fnts:array[font_number] of font_number; {corresponding
+ internal font numbers}
+@!dvi_nf:font_number; {number of \.{DVI} fonts defined so far}
+
+@ @<Set ini...@>=
+dvi_nf:=0;
+
+@ The |dvi_font| procedure sets |cur_fnt| to the internal font number
+corresponding to the external font number |cur_parm| (or aborts the
+program if such a font was never defined).
+
+@p procedure dvi_font; {computes |cur_fnt| corresponding to |cur_parm|}
+var f:font_number; {where the font is sought}
+begin @<DVI: Locate font |cur_parm|@>;
+if f=dvi_nf then bad_dvi;
+cur_fnt:=dvi_i_fnts[f];
+if font_type(cur_fnt)=defined_font then load_font;
+end;
+
+@ @<DVI: Locate font |cur_parm|@>=
+f:=0; dvi_e_fnts[dvi_nf]:=cur_parm;
+while cur_parm<>dvi_e_fnts[f] do incr(f)
+
+@ Finally the |dvi_do_font| procedure is called when one of the command
+|fnt_def1..fnt_def4| and its first parameter have been read from the
+\.{DVI} file; the argument indicates whether this should be the second
+definition of the font (|true|) or not (|false|).
+
+@p procedure dvi_do_font(@!second:boolean);
+var f:font_number; {where the font is sought}
+@!k:int_15; {general purpose variable}
+begin print('DVI: font ',cur_parm:1);
+@<DVI: Locate font |cur_parm|@>;
+if (f=dvi_nf)=second then bad_dvi;
+font_check(nf):=dvi_squad;
+font_scaled(nf):=dvi_pquad;
+font_design(nf):=dvi_pquad;
+k:=dvi_ubyte; pckt_room(1); append_byte(k);
+Incr(k)(dvi_ubyte); pckt_room(k);
+while k>0 do begin append_byte(dvi_ubyte); decr(k);
+ end;
+font_name(nf):=make_packet; {the font area plus name}
+dvi_i_fnts[dvi_nf]:=define_font(false);
+if not second then
+ begin if dvi_nf=max_fonts then overflow(str_fonts,max_fonts);
+ incr(dvi_nf);
+ end
+else if dvi_i_fnts[f]<>dvi_i_fnts[dvi_nf] then bad_dvi;
+end;
+
+@* Low-level VF input routines.
+A detailed description of the \.{VF} file format can be found in
+the documentation of \.{VFtoVP}; here we just define symbolic names for
+some of the \.{VF} command bytes.
+
+@d long_char=242 {\.{VF} command for general character packet}
+@#
+@d vf_id=202 {identifies \.{VF} files}
+
+@ The program uses the binary file variable |vf_file| for input from
+\.{VF} files; |vf_loc| is the number of the byte about to be read next
+from |vf_file|.
+
+@<Glob...@>=
+@!vf_file:byte_file; {a \.{VF} file}
+@!vf_loc:int_32; {where we are about to look, in |vf_file|}
+@!vf_limit:int_32; {value of |vf_loc| at end of a character packet}
+@!vf_ext:pckt_pointer; {extension for \.{VF} files}
+@!ovf_ext:pckt_pointer; {extension for \.{OVF} files}
+@!vf_cur_fnt:font_number; {current font number in a \.{VF} file}
+
+@ @<Initialize predefined strings@>=
+id3(".")("V")("F")(vf_ext); {file name extension for \.{VF} files}
+id4(".")("O")("V")("F")(ovf_ext); {file name extension for \.{OVF} files}
+
+@ If a \.{VF} file is badly malformed, we say |bad_font|; this procedure
+gives an error message which refers the user to \.{VFtoVP} and
+\.{OVPtoOVF}, and terminates \.{\title}.
+
+@<Cases for |bad_font|@>=
+vf_font_type: begin print('Bad (O)VF file'); print_font(cur_fnt);
+@.Bad (O)VF file@>
+ print_ln(' loc=',vf_loc:1);
+ abort(
+ 'Use OVF2OVP/OVP2OVF/VFtoVP/VPtoVF to diagnose and correct the problem');
+@.Use OVF2OVP/OVP2OVF/VFtoVP/VPtoVF@>
+ end;
+
+@ If no font directory has been specified, \.{\title} is supposed to use
+the default \.{VF} directory, which is a system-dependent place where
+the \.{VF} files for standard fonts are kept.
+The string variable |VF_default_area| contains the name of this area.
+@^system dependencies@>
+
+@d VF_default_area_name=='TeXvfonts:' {change this to the correct name}
+@d VF_default_area_name_length=10 {change this to the correct length}
+@d OVF_default_area_name=='TeXvfonts:' {change this to the correct name}
+@d OVF_default_area_name_length=10 {change this to the correct length}
+
+@<Glob...@>=
+@!VF_default_area:packed array[1..VF_default_area_name_length] of char;
+@!OVF_default_area:packed array[1..OVF_default_area_name_length] of char;
+
+@ @<Set init...@>=
+VF_default_area:=VF_default_area_name;
+OVF_default_area:=OVF_default_area_name;
+
+@ To prepare |vf_file| for input we |reset| it.
+
+@<VF: Open |vf_file| or |goto not_found|@>=
+make_font_name(VF_default_area_name_length)(VF_default_area)(vf_ext);
+reset(vf_file,cur_name);
+if eof(vf_file) then begin
+ make_font_name(OVF_default_area_name_length)(OVF_default_area)(ovf_ext);
+ reset(vf_file,cur_name);
+ if eof(vf_file) then
+@^system dependencies@>
+ goto not_found
+ end;
+vf_loc:=0
+
+@ Reading a \.{VF} file should be done as efficient as possible for a
+particular system; on many systems this means that a large number of
+bytes from |vf_file| is read into a buffer and will then be extracted
+from that buffer. In order to simplify such system dependent changes
+we use a pair of \.{WEB} macros: |vf_byte| extracts the next \.{VF}
+byte and |vf_eof| is |true| if we have reached the end of the \.{VF}
+file. Here we give simple minded definitions for these macros in terms
+of standard \PASCAL.
+@^system dependencies@>
+@^optimization@>
+
+@d vf_eof == eof(vf_file) {has the \.{VF} file been exhausted?}
+@d vf_byte(#) ==
+ if vf_eof then bad_font
+ else read(vf_file,#) {obtain next \.{VF} byte}
+
+@ We need several simple functions to read the next byte or bytes
+from |vf_file|.
+
+@p function vf_ubyte:int_8u; {returns the next byte, unsigned}
+@!begin_byte(vf_byte); incr(vf_loc); comp_ubyte(vf_ubyte);
+end;
+@#
+function vf_upair:int_16u; {returns the next two bytes, unsigned}
+@!begin_pair(vf_byte); Incr(vf_loc)(2); comp_upair(vf_upair);
+end;
+@#
+function vf_strio:int_24; {returns the next three bytes, signed}
+@!begin_trio(vf_byte); Incr(vf_loc)(3); comp_strio(vf_strio);
+end;
+@#
+function vf_utrio:int_24u; {returns the next three bytes, unsigned}
+@!begin_trio(vf_byte); Incr(vf_loc)(3); comp_utrio(vf_utrio);
+end;
+@#
+function vf_squad:int_32; {returns the next four bytes, signed}
+@!begin_quad(vf_byte); Incr(vf_loc)(4); comp_squad(vf_squad);
+end;
+
+@ All dimensions in a \.{VF} file, except the design sizes of a virtual
+font and its local fonts, are |fix_word|s that must be scaled in exactly
+the same way as the character widths from a \.{TFM} file; we can use the
+same code, but this time |z|, |alpha|, and |beta| are global variables.
+
+@<Glob...@>=
+@<Variables for scaling computation@>@;
+
+@ We need five functions to read the next byte or bytes and convert a
+|fix_word| to a scaled dimension.
+
+@p function vf_fix1:int_32; {returns the next byte as scaled value}
+var x:int_32; {accumulator}
+begin vf_byte(tfm_b3); incr(vf_loc);
+tfm_fix1(x); vf_fix1:=x;
+end;
+@#
+function vf_fix2:int_32; {returns the next two bytes as scaled value}
+var x:int_32; {accumulator}
+begin vf_byte(tfm_b2); vf_byte(tfm_b3); Incr(vf_loc)(2);
+tfm_fix2(x); vf_fix2:=x;
+end;
+@#
+function vf_fix3:int_32; {returns the next three bytes as scaled value}
+var x:int_32; {accumulator}
+begin vf_byte(tfm_b1); vf_byte(tfm_b2); vf_byte(tfm_b3);
+Incr(vf_loc)(3);@/
+tfm_fix3(x); vf_fix3:=x;
+end;
+@#
+function vf_fix3u:int_32; {returns the next three bytes as scaled value}
+begin vf_byte(tfm_b1); vf_byte(tfm_b2); vf_byte(tfm_b3);
+Incr(vf_loc)(3);@/
+vf_fix3u:=tfm_fix3u;
+end;
+@#
+function vf_fix4:int_32; {returns the next four bytes as scaled value}
+var x:int_32; {accumulator}
+begin vf_byte(tfm_b0); vf_byte(tfm_b1); vf_byte(tfm_b2); vf_byte(tfm_b3);
+Incr(vf_loc)(4);@/
+tfm_fix4(x); vf_fix4:=x;
+end;
+
+@ Three other functions are used in cases where the result must have a
+non-negative value or a positive value.
+
+@p function vf_uquad:int_31; {result must be non-negative}
+var x:int_32;
+begin x:=vf_squad; if x<0 then bad_font @+ else vf_uquad:=x;
+end;
+@#
+function vf_pquad:int_31; {result must be positive}
+var x:int_32;
+begin x:=vf_squad; if x<=0 then bad_font @+ else vf_pquad:=x;
+end;
+@#
+function vf_fixp:int_31; {result must be positive}
+var x:int_32; {accumulator}
+begin vf_byte(tfm_b0); vf_byte(tfm_b1); vf_byte(tfm_b2); vf_byte(tfm_b3);
+Incr(vf_loc)(4);@/
+if tfm_b0>0 then bad_font;
+vf_fixp:=tfm_fix3u;
+end;
+
+@ The |vf_first_par| procedure first reads a \.{VF} command byte into
+|cur_cmd|; then |cur_parm| is set to the value of the first parameter
+(if any) and |cur_class| to the command class.
+
+@d set_cur_wp_end(#)== if cur_wp=invalid_width then #
+@d set_cur_wp(#)== {set |cur_wp| to the char's width pointer}
+cur_wp:=invalid_width;
+if #<>invalid_font then
+ if (cur_res>=font_bc(#))and(cur_res<=font_ec(#)) then
+ begin cur_cp:=font_chars(#)+cur_res; cur_wp:=char_widths[cur_cp];
+ end;
+set_cur_wp_end
+
+@p procedure vf_first_par;
+begin cur_cmd:=vf_ubyte;
+case dvi_par[cur_cmd] of
+char_par:
+ begin set_cur_char(vf_ubyte); set_cur_wp(vf_cur_fnt)(bad_font);
+ end;
+no_par: do_nothing;
+dim1_par: cur_parm:=vf_fix1;
+num1_par: cur_parm:=vf_ubyte;
+dim2_par: cur_parm:=vf_fix2;
+num2_par: cur_parm:=vf_upair;
+dim3_par: cur_parm:=vf_fix3;
+num3_par: cur_parm:=vf_utrio;
+dim4_par: cur_parm:=vf_fix4;
+num4_par: cur_parm:=vf_squad;
+numu_par: cur_parm:=vf_uquad;
+rule_par:
+ begin cur_v_dimen:=vf_fix4; cur_h_dimen:=vf_fix4;
+ cur_upd:=(cur_cmd=set_rule);
+ end;
+fnt_par:cur_parm:=cur_cmd-fnt_num_0;
+end; {there are no other cases}
+cur_class:=dvi_cl[cur_cmd];
+end;
+
+@ For a virtual font we set |font_type(f):=vf_font_type|; in this case
+|font_font(f)| is the default font for character packets from virtual
+font~|f|.
+@^font types@>
+
+The global variable |vf_nf| is used for the number of different local
+fonts defined in a \.{VF} file so far; their external font numbers
+(as extracted from the \.{VF} file) are stored in the array |vf_e_fnts|,
+the corresponding internal font numbers used internally by \.{\title} are
+stored in the array |vf_i_fnts|.
+
+@<Glob...@>=
+@!vf_e_fnts:array[font_number] of int_32; {external font numbers}
+@!vf_i_fnts:array[font_number] of font_number; {corresponding
+ internal font numbers}
+@!vf_nf:font_number; {number of local fonts defined so far}
+@!lcl_nf:font_number; {largest |vf_nf| value for any \.{VF} file}
+
+@ @<Set init...@>=
+lcl_nf:=0;
+
+@ The |vf_font| procedure sets |vf_cur_fnt| to the internal font number
+corresponding to the external font number |cur_parm| (or aborts the
+program if such a font was never defined).
+
+@p procedure vf_font; {computes |vf_cur_fnt| corresponding to |cur_parm|}
+var f:font_number; {where the font is sought}
+begin @<VF: Locate font |cur_parm|@>;
+if f=vf_nf then bad_font;
+vf_cur_fnt:=vf_i_fnts[f];
+end;
+
+@ @<VF: Locate font |cur_parm|@>=
+f:=0; vf_e_fnts[vf_nf]:=cur_parm;
+while cur_parm<>vf_e_fnts[f] do incr(f)
+
+@ Finally the |vf_do_font| procedure is called when one of the command
+|fnt_def1..fnt_def4| and its first parameter have been read from the
+\.{VF} file.
+
+@p procedure vf_do_font;
+var f:font_number; {where the font is sought}
+@!k:int_31; {general purpose variable}
+begin
+print('VF: font ',cur_parm:1);@/
+@<VF: Locate font |cur_parm|@>;
+if f<>vf_nf then bad_font;
+font_check(nf):=vf_squad;
+font_scaled(nf):=vf_fixp;
+font_design(nf):=round(tfm_conv*vf_pquad);
+k:=vf_ubyte; pckt_room(1); append_byte(k);
+Incr(k)(vf_ubyte); pckt_room(k);
+while k>0 do begin append_byte(vf_ubyte); decr(k);
+ end;
+font_name(nf):=make_packet; {the font area plus name}
+vf_i_fnts[vf_nf]:=define_font(true);
+if vf_nf=lcl_nf then
+ if lcl_nf=max_fonts then overflow(str_fonts,max_fonts)
+ else incr(lcl_nf);
+incr(vf_nf);
+end;
+
+@* Reading VF and OVF files.
+The |do_vf| function attempts to read the \.{VF} file for a font and
+returns |false| if the \.{VF} file could not be found; otherwise the
+font type is changed to |vf_font_type|.
+
+@p function do_vf:boolean; {read a \.{VF} file}
+label reswitch,done,not_found,exit;
+var temp_int:int_32; {integer for temporary variables}
+@!temp_byte:int_8u; {byte for temporary variables}
+@!k:byte_pointer; {index into |byte_mem|}
+@!l:int_15; {general purpose variable}
+@!save_ext:int_24; {used to save |cur_ext|}
+@!save_res:int_32; {used to save |cur_res|}
+@!save_cp:width_pointer; {used to save |cur_cp|}
+@!save_wp:width_pointer; {used to save |cur_wp|}
+@!save_upd:boolean; {used to save |cur_upd|}
+@!vf_wp:width_pointer; {width pointer for the current character packet}
+@!vf_fnt:font_number; {current font in the current character packet}
+@!move_zero:boolean; {|true| if rule 1 is used}
+@!last_pop:boolean; {|true| if final |pop| has been manufactured}
+begin @<VF: Open |vf_file| or |goto not_found|@>;
+save_ext:=cur_ext; save_res:=cur_res; save_cp:=cur_cp; save_wp:=cur_wp;
+save_upd:=cur_upd; {save}
+font_type(cur_fnt):=vf_font_type;@/
+@<VF: Process the preamble@>;@/
+@<VF: Process the font definitions@>;@/
+while cur_cmd<=long_char do @<VF: Build a character packet@>;
+if cur_cmd<>post then bad_font;
+@!debug print('VF file for font ',cur_fnt:1); print_font(cur_fnt);
+print_ln(' loaded.');
+gubed @;@/
+close_in(vf_file);
+cur_ext:=save_ext; cur_res:=save_res; cur_cp:=save_cp; cur_wp:=save_wp;
+cur_upd:=save_upd; {restore}
+do_vf:=true; return;
+not_found:do_vf:=false;
+exit:end;
+
+@ @<VF: Process the preamble@>=
+if vf_ubyte<>pre then bad_font;
+if vf_ubyte<>vf_id then bad_font;
+temp_byte:=vf_ubyte; pckt_room(temp_byte);
+for l:=1 to temp_byte do append_byte(vf_ubyte);
+if font_extend(cur_fnt) then print('O');
+print('VF file: '''); print_packet(new_packet); print(''',');
+flush_packet;@/
+check_check_sum(vf_squad,false);
+check_design_size(round(tfm_conv*vf_pquad));@/
+z:=font_scaled(cur_fnt);
+@<Replace |z|...@>;@/
+print_nl(' for font ',cur_fnt:1); print_font(cur_fnt); print_ln('.')
+
+@ @<VF: Process the font definitions@>=
+vf_i_fnts[0]:=invalid_font; vf_nf:=0;@/
+cur_cmd:=vf_ubyte;
+while (cur_cmd>=fnt_def1)and(cur_cmd<=fnt_def1+3) do
+ begin case cur_cmd-fnt_def1 of
+ 0: cur_parm:=vf_ubyte;
+ 1: cur_parm:=vf_upair;
+ 2: cur_parm:=vf_utrio;
+ 3: cur_parm:=vf_squad;
+ end; {there are no other cases}
+ vf_do_font;
+ cur_cmd:=vf_ubyte;
+ end;
+font_font(cur_fnt):=vf_i_fnts[0]
+
+@ The \.{VF} format specifies that the interpretation of each packet
+begins with |w=x=y=z=0|; any |w0|, |x0|, |y0|, or |z0| command using
+these initial values will be ignored.
+
+@<Types...@>=
+@!vf_state=array[0..1,0..1] of boolean; {state of |w|, |x|, |y|, and |z|}
+
+@ As implied by the \.{VF} format the \.{DVI} commands read from the \.{VF}
+file are enclosed by |push| and |pop|; as we read \.{DVI}
+commands and append them to |byte_mem|, we perform a set of
+transformations in order to simplify the resulting packet: Let |zero| be
+any of the commands |put|, |put_rule|, |fnt_num|, |fnt|, or |xxx| which
+all leave the current position on the page unchanged, let |move| be any
+of the horizontal or vertical movement commands |right1..z4|, and let
+|any| be any sequence of commands containing |push| and |pop| in
+properly nested pairs; whenever possible we apply one of the following
+transformation rules: $$\def\n#1:{\hbox to 3cm{\hfil#1:}}
+\leqalignno{
+\hbox{|push| |zero|}&\RA\hbox{|zero| |push|}&\n1:\cr
+\hbox{|move| |pop|}&\RA\hbox{|pop|}&\n2:\cr
+\hbox{|push| |pop|}&\RA{}&\n3:\cr
+\hbox{|push| |set_char| |pop|}&\RA\hbox{|put|}&\n4a:\cr
+\hbox{|push| \\{set} |pop|}&\RA\hbox{|put|}&\n4b:\cr
+\hbox{|push| |set_rule| |pop|}&\RA\hbox{|put_rule|}&\n4c:\cr
+\hbox{|push| |push| |any| |pop|}&\RA\hbox{|push| |any| |pop| |push|}&\n5:\cr
+\hbox{|push| |any| |pop| |pop|}&\RA\hbox{|any| |pop|}&\n6:\cr
+}$$
+
+@ In order to perform these transformations we need a stack which is
+indexed by |vf_ptr|, the number of |push| commands without corresponding
+|pop| in the packet we are building; the |vf_push_loc| array contains
+the locations in |byte_mem| following such |push| commands.
+In view of rule~5 consecutive |push| commands are never stored, the
+|vf_push_num| array is used to count them.
+The |vf_last| array indicates the type of the last non-discardable item:
+a character, a rule, or a group enclosed by |push| and |pop|;
+the |vf_last_end| array points to the ending locations and, if
+|vf_last<>vf_other|, the |vf_last_loc| array points to the starting
+locations of these items.
+
+@d vf_set=0 {|vf_set=char_cl|, last item is a |set_char| or \\{set}}
+@d vf_rule=1 {|vf_rule=rule_cl|, last item is a |set_rule|}
+@d vf_group=2 {last item is a group enclosed by |push| and |pop|}
+@d vf_put=3 {last item is a |put|}
+@d vf_other=4 {last item (if any) is none of the above}
+
+@<Types...@>=
+@!vf_type=vf_set..vf_other;
+
+@ @<Glob...@>=
+@!vf_move: array[stack_pointer] of vf_state; {state of |w|, |x|, |y|, and |z|}
+@!vf_push_loc: array[stack_pointer] of byte_pointer; {end of a |push|}
+@!vf_last_loc: array[stack_pointer] of byte_pointer; {start of an item}
+@!vf_last_end: array[stack_pointer] of byte_pointer; {end of an item}
+@!vf_push_num: array[stack_pointer] of eight_bits; {|push| count}
+@!vf_last: array[stack_pointer] of vf_type; {type of last item}
+@!vf_ptr:stack_pointer; {current number of unfinished groups}
+@!stack_used:stack_pointer; {largest |vf_ptr| or |stack_ptr| value}
+
+@ We use two small arrays to determine the item type of a character or a
+rule.
+
+@<Glob...@>=
+@!vf_char_type:array[boolean] of vf_type;
+@!vf_rule_type:array[boolean] of vf_type;
+
+@ @<Set init...@>=
+vf_move[0][0][0]:=false; vf_move[0][0][1]:=false;
+vf_move[0][1][0]:=false; vf_move[0][1][1]:=false;@/
+stack_used:=0;@/
+vf_char_type[false]:=vf_put; vf_char_type[true]:=vf_set;@/
+vf_rule_type[false]:=vf_other; vf_rule_type[true]:=vf_rule;
+
+@ Here we read the first bytes of a character packet from the \.{VF} or \.{OVF}
+file and initialize the packet being built in |byte_mem|; the start of
+the whole packet is stored in |vf_push_loc[0]|. When the character
+packet is finished, a type is be assigned to it: |vf_simple| if the
+packet ends with a character of the correct width, or |vf_complex|
+otherwise. Moreover, if such a packet for a character with
+extension zero consists of just one character with extension zero and
+the same residue, and if there is no previous packet, the whole packet
+is replaced by the empty packet.
+
+@d vf_simple=0 {the packet ends with a character of the correct width}
+@d vf_complex=vf_simple+1 {otherwise}
+
+@<VF: Build a character packet@>=
+begin if cur_cmd<long_char then
+ begin vf_limit:=cur_cmd;
+ cur_ext:=0; cur_res:=vf_ubyte; vf_wp:=check_width(vf_fix3u);
+ end
+else if font_extend(cur_fnt) then
+ begin vf_limit:=vf_uquad;
+ cur_ext:=0; cur_res:=vf_squad; vf_wp:=check_width(vf_fix4);
+ end
+else begin vf_limit:=vf_uquad;
+ cur_ext:=vf_strio; cur_res:=vf_ubyte; vf_wp:=check_width(vf_fix4);
+ end;
+Incr(vf_limit)(vf_loc);
+vf_push_loc[0]:=byte_ptr; vf_last_end[0]:=byte_ptr;
+vf_last[0]:=vf_other; vf_ptr:=0;@/
+start_packet(vf_complex);
+@<VF: Append \.{DVI} commands to the character packet@>;@/
+k:=pckt_start[pckt_ptr];
+if vf_last[0]=vf_put then if cur_wp=vf_wp then
+ begin decr(byte_mem[k]); {change |vf_complex| into |vf_simple|}
+ if (byte_mem[k]=bi(0))and@|(vf_push_loc[0]=vf_last_loc[0])and@|
+ (cur_ext=0)and@|(cur_res=pckt_res) then byte_ptr:=k;
+ end;
+build_packet;
+cur_cmd:=vf_ubyte;
+end
+
+@ For every \.{DVI} command read from the \.{VF} file some action is
+performed; in addition the initial |push| and the final |pop| are
+manufactured here.
+
+@<VF: Append \.{DVI} commands to the character packet@>=
+vf_cur_fnt:=font_font(cur_fnt); vf_fnt:=vf_cur_fnt;@/
+last_pop:=false; cur_class:=push_cl; {initial |push|}
+loop begin
+reswitch:case cur_class of
+ three_cases(char_cl): @<VF: Do a |char|, |rule|, or |xxx|@>;
+ push_cl: @<VF: Do a |push|@>;
+ pop_cl: @<VF: Do a |pop|@>;
+ two_cases(w0_cl):
+ if vf_move[vf_ptr][0][cur_class-w0_cl] then append_one(cur_cmd);
+ three_cases(right_cl):
+ begin pckt_signed(dvi_right_cmd[cur_class],cur_parm);
+ if cur_class>=w_cl then vf_move[vf_ptr][0][cur_class-w_cl]:=true;
+ end;
+ two_cases(y0_cl):
+ if vf_move[vf_ptr][1][cur_class-y0_cl] then append_one(cur_cmd);
+ three_cases(down_cl):
+ begin pckt_signed(dvi_down_cmd[cur_class],cur_parm);
+ if cur_class>=y_cl then vf_move[vf_ptr][1][cur_class-y_cl]:=true;
+ end;
+ fnt_cl: vf_font;
+ fnt_def_cl: bad_font;
+ invalid_cl: if cur_cmd<>nop then bad_font;
+ end; {there are no other cases}
+ if vf_loc<vf_limit then vf_first_par
+ else if last_pop then goto done
+ else begin cur_class:=pop_cl; last_pop:=true; {final |pop|}
+ end;
+ end;
+done:if (vf_ptr<>0)or(vf_loc<>vf_limit) then bad_font
+
+@ For a |push| we either increase |vf_push_num| or start a new level and
+append a |push|.
+
+@d incr_stack(#)==
+if #=stack_used then
+ if stack_used=stack_size then overflow(str_stack,stack_size)
+ else incr(stack_used);
+incr(#)
+
+@<VF: Do a |push|@>=
+if (vf_ptr>0)and(vf_push_loc[vf_ptr]=byte_ptr) then
+ begin if vf_push_num[vf_ptr]=255 then overflow(str_stack,255);
+ incr(vf_push_num[vf_ptr]);
+ end
+else begin incr_stack(vf_ptr);
+ @<VF: Start a new level@>;
+ vf_push_num[vf_ptr]:=0;
+ end
+
+@ @<VF: Start a new level@>=
+append_one(push);
+vf_move[vf_ptr]:=vf_move[vf_ptr-1];
+vf_push_loc[vf_ptr]:=byte_ptr;
+vf_last_end[vf_ptr]:=byte_ptr;
+vf_last[vf_ptr]:=vf_other
+
+@ When a character, a rule, or an |xxx| is appended, transformation
+rule~1 might be applicable.
+
+@<VF: Do a |char|, |rule|, or |xxx|@>=
+begin if (vf_ptr=0)or(byte_ptr>vf_push_loc[vf_ptr]) then move_zero:=false
+else case cur_class of
+char_cl: move_zero:=(not cur_upd)or(vf_cur_fnt<>vf_fnt);
+rule_cl: move_zero:=not cur_upd;
+xxx_cl: move_zero:=true;
+end; {there are no other cases}
+if move_zero then
+ begin decr(byte_ptr); decr(vf_ptr);
+ end;
+case cur_class of
+char_cl: @<VF: Do a |fnt|, a |char|, or both@>;
+rule_cl: @<VF: Do a |rule|@>;
+xxx_cl: @<VF: Do an |xxx|@>;
+end; {there are no other cases}
+vf_last_end[vf_ptr]:=byte_ptr;
+if move_zero then
+ begin incr(vf_ptr); append_one(push); vf_push_loc[vf_ptr]:=byte_ptr;
+ vf_last_end[vf_ptr]:=byte_ptr;
+ if cur_class=char_cl then if cur_upd then goto reswitch;
+ end;
+end
+
+@ A special situation arises if transformation rule~1 is applied to a
+|fnt_num| of |fnt| command, but not to the |set_char| or \\{set} command
+following it; in this case |cur_upd| and |move_zero| are both |true| and
+the |set_char| or \\{set} command will be appended later.
+
+@<VF: Do a |fnt|, a |char|, or both@>=
+begin if vf_cur_fnt<>vf_fnt then
+ begin vf_last[vf_ptr]:=vf_other;
+ pckt_unsigned(fnt1,vf_cur_fnt); vf_fnt:=vf_cur_fnt;
+ end;
+if (not move_zero)or(not cur_upd) then
+ begin vf_last[vf_ptr]:=vf_char_type[cur_upd];
+ vf_last_loc[vf_ptr]:=byte_ptr;
+ pckt_char(cur_upd,cur_ext,cur_res);
+ end;
+end
+
+@ @<VF: Do a |rule|@>=
+begin vf_last[vf_ptr]:=vf_rule_type[cur_upd];
+vf_last_loc[vf_ptr]:=byte_ptr;
+append_one(dvi_rule_cmd[cur_upd]);
+pckt_four(cur_v_dimen); pckt_four(cur_h_dimen);
+end
+
+@ @<VF: Do an |xxx|@>=
+begin vf_last[vf_ptr]:=vf_other;
+pckt_unsigned(xxx1,cur_parm); pckt_room(cur_parm);
+while cur_parm>0 do
+ begin append_byte(vf_ubyte); decr(cur_parm);
+ end;
+end
+
+@ Transformation rules 2--6 are triggered by a |pop|, either read from
+the \.{VF} file or manufactured at the end of the packet.
+
+@<VF: Do a |pop|@>=
+begin if vf_ptr<1 then bad_font;
+byte_ptr:=vf_last_end[vf_ptr]; {this is rule 2}
+if vf_last[vf_ptr]<=vf_rule then
+ if vf_last_loc[vf_ptr]=vf_push_loc[vf_ptr] then
+ @<VF: Prepare for rule 4@>;
+if byte_ptr=vf_push_loc[vf_ptr] then @<VF: Apply rule 3 or 4@>
+else begin if vf_last[vf_ptr]=vf_group then @<VF: Apply rule 6@>;
+ append_one(pop); decr(vf_ptr); vf_last[vf_ptr]:=vf_group;
+ vf_last_loc[vf_ptr]:=vf_push_loc[vf_ptr+1]-1;
+ vf_last_end[vf_ptr]:=byte_ptr;
+ if vf_push_num[vf_ptr+1]>0 then @<VF: Apply rule 5@>;
+ end;
+end
+
+@ In order to implement transformation rule~4, we cancel the |set_char|,
+\\{set}, or |set_rule|, append a |pop|, and insert a |put| or |put_rule|
+with the old parameters.
+
+@<VF: Prepare for rule 4@>=
+begin cur_class:=vf_last[vf_ptr]; cur_upd:=false;
+byte_ptr:=vf_push_loc[vf_ptr];
+end
+
+@ @<VF: Apply rule 3 or 4@>=
+begin if vf_push_num[vf_ptr]>0 then
+ begin decr(vf_push_num[vf_ptr]);
+ vf_move[vf_ptr]:=vf_move[vf_ptr-1];
+ end
+else begin decr(byte_ptr); decr(vf_ptr);
+ end;
+if cur_class<>pop_cl then goto reswitch; {this is rule 4}
+end
+
+@ @<VF: Apply rule 6@>=
+begin Decr(byte_ptr)(2);
+for k:=vf_last_loc[vf_ptr]+1 to byte_ptr do byte_mem[k-1]:=byte_mem[k];
+vf_last[vf_ptr]:=vf_other; vf_last_end[vf_ptr]:=byte_ptr;
+end
+
+@ @<VF: Apply rule 5@>=
+begin incr(vf_ptr);
+@<VF: Start a new level@>;
+decr(vf_push_num[vf_ptr]);
+end
+
+@ The \.{VF} formats specify that after a character packet invoked by a
+|set_char| or \\{set} command, ``|h|~is increased by the \.{TFM} width
+(properly scaled)---just as if a simple character had been typeset'';
+for |vf_simple| packets this is achieved by changing the final |put|
+command into |set_char| or \\{set}, but for |vf_complex| packets an
+explicit movement must be done. This poses a problem for programs,
+such as \.{DVIcopy}, which write a new \.{DVI} file with all references
+to characters from virtual fonts replaced by their character packets:
+The \.{DVItype} program specifies that the horizontal movements after a
+|set_char| or \\{set} command, after a |set_rule| command, and after one
+of the commands |right1..x4|, are all treated differently when \.{DVI}
+units are converted to pixels.
+
+Thus we introduce a slight extension of \.{DVItype}'s pixel rounding
+algorithm and hope that this extension will become part of the standard
+\.{DVItype} program in the near future: If a \.{DVI} file contains a
+|set_rule| command for a rule with the negative height |width_dimen|,
+then this rule shall be treated in exactly the same way as a ficticious
+character whose width is the width of that rule; as value of |width_dimen|
+we choose $-2^{31}$, the smallest signed 32-bit integer.
+
+@<Glob...@>=
+@!width_dimen:int_32; {vertical dimension of special rules}
+
+@ When initializing |width_dimen| we are careful to avoid arithmetic
+overflow.
+
+@<Set init...@>=
+width_dimen:=-@"40000000; Decr(width_dimen)(@"40000000);
+
+@* Terminal communication.
+When \.{\title} begins, it engages the user in a brief dialog so that
+various options may be specified. This part of \.{\title} requires
+nonstandard \PASCAL\ constructions to handle the online interaction; so
+it may be preferable in some cases to omit the dialog and simply to
+stick to the default options. On other hand, the system-dependent
+routines that are needed are not complicated, so it will not be terribly
+difficult to introduce them; furthermore they are similar to those in
+\.{DVItype}.
+
+It may be desirable to (optionally) specify all the options in the
+command line and skip the dialog with the user, provided the operating
+system permits this. Here we just define the system-indepent part of the
+code required for this possibility. Since a complete option (a keyword
+possibly followed by one or several parameters) may have embedded blanks
+it might be necessary to replace these blanks by some other separator,
+e.g., by a '/'. Using, e.g., \.{UNIX} style options one might then say
+$$\.{\title\space-mag/2000 -sel/17.3/5 -sel/47 ...}$$
+to override the magnification factor that is stated in the \.{DVI} file,
+and to select five pages starting with the page numbered~17.3 as well as
+all remaining pages starting with the one numbered~47; alternatively one
+might simply say
+$$\.{\title\space- ...}$$
+to skip the dialog and use the default options.
+
+The system-dependent initialization code should set the |n_opt| variable
+to the number of options found in the command line. If |n_opt=0| the
+|input_ln| procedure defined below will promt the user for options. If
+|n_opt>0| the |k_opt| variable will be incremented and another piece of
+system-dependent code is invoked instead of the dialog; that code should
+place the value of command line option number |k_opt| as temporary
+string into the |byte-mem| array. This process will be repeated until
+|k_opt=n_opt|, indicating that all command line options have been
+processed.
+@^system dependencies@>
+
+@d opt_separator="/" {acts as blank when scanning (command line) options}
+
+@<Set init...@>=
+n_opt:=0; {change this to indicate the presence of command line options}
+k_opt:=0; {just in case}
+
+@ The |input_ln| routine waits for the user to type a line at his or her
+terminal; then it puts ASCII-code equivalents for the characters on that
+line into the |byte_mem| array as a temporary string. \PASCAL's
+standard |input| file is used for terminal input, as |output| is used
+for terminal output.
+
+Since the terminal is being used for both input and output, some systems
+need a special routine to make sure that the user can see a prompt message
+before waiting for input based on that message. (Otherwise the message
+may just be sitting in a hidden buffer somewhere, and the user will have
+no idea what the program is waiting for.) We shall invoke a system-dependent
+subroutine |update_terminal| in order to avoid this problem.
+@^system dependencies@>
+
+@d update_terminal == break(output) {empty the terminal output buffer}
+@#
+@d scan_blank(#)== {tests for `blank' when scanning (command line) options}
+ ((byte_mem[#]=bi(" "))or(byte_mem[#]=bi(opt_separator)))
+@d scan_skip== {skip `blanks'}
+ while scan_blank(scan_ptr)and(scan_ptr<byte_ptr) do incr(scan_ptr)
+@d scan_init== {initialize |scan_ptr|}
+ byte_mem[byte_ptr]:=bi(" "); scan_ptr:=pckt_start[pckt_ptr-1]; scan_skip
+
+@<Action procedures for |dialog|@>=
+procedure input_ln; {inputs a line from the terminal}
+var k:0..terminal_line_length;
+begin if n_opt=0 then
+ begin print('Enter option: '); update_terminal; reset(input);
+ if eoln(input) then read_ln(input);
+ k:=0; pckt_room(terminal_line_length);
+ while (k<terminal_line_length)and not eoln(input) do
+ begin append_byte(xord[input^]); incr(k); get(input);
+ end;
+ end
+else if k_opt<n_opt then
+ begin incr(k_opt);
+ {Copy command line option number |k_opt| into |byte_mem| array!}
+ end;
+end;
+
+@ The global variable |scan_ptr| is used while scanning the temporary
+packet; it points to the next byte in |byte_mem| to be examined.
+
+@<Glob...@>=
+@!n_opt:int_16; {number of options found in command line}
+@!k_opt:int_16; {number of command line options processed}
+@!scan_ptr:byte_pointer; {pointer to next byte to be examined}
+@!sep_char:text_char; {|' '| or |xchr[opt_separator]|}
+
+@ The |scan_keyword| function is used to test for keywords in a character
+string stored as temporary packet in |byte_mem|; the result is |true|
+(and |scan_ptr| is updated) if the characters starting at position
+|scan_ptr| are an abbreviation of a given keyword followed by at least
+one blank.
+
+@<Action procedures for |dialog|@>=
+function scan_keyword(@!p:pckt_pointer;@!l:int_7):boolean;
+var i,@!j,@!k:byte_pointer; {indices into |byte_mem|}
+begin i:=pckt_start[p]; j:=pckt_start[p+1]; k:=scan_ptr;
+while (i<j)and((byte_mem[k]=byte_mem[i])or(byte_mem[k]=byte_mem[i]-"a"+"A")) do
+ begin incr(i); incr(k);
+ end;
+if scan_blank(k)and(i-pckt_start[p]>=l) then
+ begin scan_ptr:=k; scan_skip; scan_keyword:=true;
+ end
+else scan_keyword:=false;
+end;
+
+@ Here is a routine that scans a (possibly signed) integer and computes
+the decimal value. If no decimal integer starts at |scan_ptr|, the
+value~0 is returned. The integer should be less than $2^{31}$ in
+absolute value.
+
+@<Action procedures for |dialog|@>=
+function scan_int:int_32;
+var x:int_32; {accumulates the value}
+@!negative:boolean; {should the value be negated?}
+begin if byte_mem[scan_ptr]="-" then
+ begin negative:=true; incr(scan_ptr);
+ end
+else negative:=false;
+x:=0;
+while (byte_mem[scan_ptr]>="0")and(byte_mem[scan_ptr]<="9") do
+ begin x:=10*x+byte_mem[scan_ptr]-"0"; incr(scan_ptr);
+ end;
+scan_skip;
+if negative then scan_int:=-x @+ else scan_int:=x;
+end;
+
+@ The selected options are put into global variables by the |dialog|
+procedure, which is called just as \.{\title} begins.
+@^system dependencies@>
+
+@p @<Action procedures for |dialog|@>@;
+procedure dialog;
+label exit;
+var p:pckt_pointer; {packet being created}
+begin @<Initialize options@>@;
+loop begin input_ln; p:=new_packet; scan_init;
+ if scan_ptr=byte_ptr then
+ begin flush_packet; return;
+ end@;@/
+ @<Cases for options@>@;@/
+ else begin if n_opt=0 then sep_char:=' '
+ else sep_char:=xchr[opt_separator];
+ print_options;
+ if n_opt>0 then
+ begin print('Bad command line option: ');
+ print_packet(p); abort('---run terminated');
+ end;
+ end;
+ flush_packet;
+ end;
+exit:end;
+
+@ The |print_options| procedure might be used in a `Usage message'
+displaying the command line syntax.
+
+@<Basic printing...@>=
+procedure print_options;
+begin print_ln('Valid options are:');
+@<Print valid options@>@;
+end;
+
+@* Subroutines for typesetting commands.
+This is the central part of the whole \.{\title} program:
+When a typesetting command from the \.{DVI} file or from a \.{VF} packet
+has been decoded, one of the typesetting routines defined below is
+invoked to execute the command; apart from the necessary book keeping,
+these routines invoke device dependent code defined later.
+
+@p @<Declare typesetting procedures@>
+
+@ These typesetting routines communicate with the rest of the program
+through global variables.
+
+@<Glob...@>=
+@!type_setting:boolean; {|true| while typesetting a page}
+
+@ @<Set init...@>=
+type_setting:=false;
+
+@ The user may select up to |max_select| ranges of consecutive pages to
+be processed. Each starting page specification is recorded in two global
+arrays called |start_count| and |start_there|. For example, `\.{1.*.-5}'
+is represented by |start_there[0]=true|, |start_count[0]=1|,
+|start_there[1]=false|, |start_there[2]=true|, |start_count[2]=-5|. We
+also set |start_vals=2|, to indicate that count 2 was the last one
+mentioned. The other values of |start_count| and |start_there| are not
+important, in this example. The number of pages is recorded in
+|max_pages|; a non positive value indicates that there is no limit.
+
+@d start_count==select_count[cur_select] {count values to select
+ starting page}
+@d start_there==select_there[cur_select] {is the |start_count| value
+ relevant?}
+@d start_vals==select_vals[cur_select] {the last count considered
+ significant}
+@d max_pages==select_max[cur_select] {at most this many |bop..eop| pages
+ will be printed}
+
+@<Glob...@>=
+@!select_count:array[0..max_select-1,0..9] of int_32;
+@!select_there:array[0..max_select-1,0..9] of boolean;
+@!select_vals:array[0..max_select-1] of 0..9;
+@!select_max:array[0..max_select-1] of int_32;
+@!out_mag:int_32; {output maginfication}
+@!count:array[0..9] of int_32; {the count values on the current page}
+@!num_select:0..max_select; {number of page selection ranges specified}
+@!cur_select:0..max_select; {current page selection range}
+@!selected:boolean; {has starting page been found?}
+@!all_done:boolean; {have all selected pages been processed?}
+@!str_mag,@!str_select:pckt_pointer;
+
+@ Here is a simple subroutine that tests if the current page might be the
+starting page.
+
+@p function start_match:boolean; {does |count| match the starting spec?}
+var k:0..9; {loop index}
+@!match:boolean; {does everything match so far?}
+begin match:=true;
+for k:=0 to start_vals do
+ if start_there[k]and(start_count[k]<>count[k]) then match:=false;
+start_match:=match;
+end;
+
+@ @<Initialize options@>=
+out_mag:=0; cur_select:=0; max_pages:=0; selected:=true;
+
+@ @<Print valid options@>=
+print_ln(' mag',sep_char,'<new_mag>');
+print_ln(' select',sep_char,'<start_count>',sep_char,
+ '[<max_pages>] (up to ',max_select:1,' ranges)');
+
+@ @<Action procedures for |dialog|@>=
+procedure scan_count; {scan a |start_count| value}
+begin if byte_mem[scan_ptr]=bi("*") then
+ begin start_there[start_vals]:=false; incr(scan_ptr); scan_skip;
+ end
+else begin start_there[start_vals]:=true;
+ start_count[start_vals]:=scan_int;
+ if cur_select=0 then selected:=false; {don't start at first page}
+ end;
+end;
+
+@ @<Cases for options@>=
+else if scan_keyword(str_mag,3) then out_mag:=scan_int
+else if scan_keyword(str_select,3) then
+ if cur_select=max_select then print_ln('Too many page selections')
+ else begin start_vals:=0; scan_count;
+ while (start_vals<9)and(byte_mem[scan_ptr]=bi(".")) do
+ begin incr(start_vals); incr(scan_ptr); scan_count;
+ end;
+ max_pages:=scan_int; incr(cur_select);
+ end
+
+@ @<Initialize predefined strings@>=
+id3("m")("a")("g")(str_mag);
+id6("s")("e")("l")("e")("c")("t")(str_select);
+
+@ A stack is used to keep track of the current horizonal and vertical
+position, |h| and |v|, and the four registers |w|, |x|, |y|, and |z|;
+the register pairs |(w,x)| and |(y,z)| are maintained as arrays.
+
+@<Types...@>=
+@!device @<Declare device dependend types@>@; @+ ecived @; @/
+@!stack_pointer=0..stack_size;@/
+@!stack_index=1..stack_size;@/
+@!pair_32=array[0..1] of int_32; {a pair of |int_32| variables}
+@!stack_record=record@;@/
+ @!h_field:int_32; {horizontal position |h|}
+ @!v_field:int_32; {vertical position |v|}
+ @!w_x_field:pair_32; {|w| and |x| register for horizontal movements}
+ @!y_z_field:pair_32; {|y| and |z| register for vertical movements}
+ @!device @<Device dependent stack record fields@>@; @+ ecived @; @/
+ end;
+
+@ The current values are kept in |cur_stack|; they are pushed onto and
+popped from |stack|. We use \.{WEB} macros to access the current values.
+
+@d cur_h==cur_stack.h_field {the current |@!h| value}
+@d cur_v==cur_stack.v_field {the current |@!v| value}
+@d cur_w_x==cur_stack.w_x_field {the current |@!w| and |@!x| value}
+@d cur_y_z==cur_stack.y_z_field {the current |@!y| and |@!z| value}
+
+@<Glob...@>=
+@!stack:array[stack_index] of stack_record; {the pushed values}
+@!cur_stack:stack_record; {the current values}
+@!zero_stack:stack_record; {initial values}
+@!stack_ptr:stack_pointer; {last used position in |stack|}
+
+@ @<Set init...@>=
+zero_stack.h_field:=0; zero_stack.v_field:=0;
+for i:=0 to 1 do
+ begin zero_stack.w_x_field[i]:=0; zero_stack.y_z_field[i]:=0;
+ end;
+@!device @<Initialize device dependent stack record fields@>@; @+ ecived @; @/
+
+@ When typesetting for a real device we must convert the current
+position from \.{DVI} units to pixels, i.e., |cur_h| and |cur_v| into
+|cur_hh| and |cur_vv|. This might be a good place to collect everything
+related to the conversion from \.{DVI} units to pixels and in particular
+all the pixel rounding algorithms.
+
+@d font_space(#)==fnt_space[#] {boundary between ``small'' and ``large''
+ spaces}
+
+@<Declare device dependent font data arrays@>=
+@!fnt_space:array [font_number] of int_32; {boundary between ``small''
+ and ``large'' spaces}
+
+@ @<Initialize device dependent font data@>=
+font_space(invalid_font):=0;
+
+@ @<Initialize device dependent data for a font@>=
+font_space(cur_fnt):=font_scaled(cur_fnt) div 6;
+ {this is a 3-unit ``thin space''}
+
+@ The |char_pixels| array is used to store the horizontal character
+escapements: for \.{PK} or \.{GF} files we use the values given there,
+otherwise we must convert the character widths to (horizontal) pixels.
+The horizontal escapement of character~|c| in font~|f| is given by
+|font_pixel(f)(c)|.
+
+@d font_pixel(#)==char_pixels[font_chars(#)+font_width_end
+@#
+@d max_pix_value==@"7FFF {largest allowed pixel value; this range may not
+ suffice for high resolution output devices}
+
+@<Declare device dependend types@>=
+@!pix_value=-max_pix_value..max_pix_value; {a pixel coordinate or displacement}
+
+@ @<Glob...@>=
+@!device
+@!char_pixels:array[char_pointer] of pix_value; {character escapements}
+@!h_pixels:pix_value; {a horizontal dimension in pixels}
+@!v_pixels:pix_value; {a vertical dimension in pixels}
+@!temp_pix:pix_value; {temporary value for pixel rounding}
+ecived
+
+@ @d cur_hh==cur_stack.hh_field {the current |@!hh| value}
+@d cur_vv==cur_stack.vv_field {the current |@!vv| value}
+
+@<Device dependent stack record fields@>=
+@!hh_field:pix_value; {horizontal pixel position |hh|}
+@!vv_field:pix_value; {vertical pixel position |vv|}
+
+@ @<Initialize device dependent stack record fields@>=
+zero_stack.hh_field:=0; zero_stack.vv_field:=0;
+
+@ For small movements we round the increment in position, for large
+movements we round the incremented position. The same applies to rule
+dimensions with the only difference that they will always be rounded
+towards larger values. For characters we increment the horizontal
+position by the escapement values obtained, e.g., from a \.{PK} file or
+by the \.{TFM} width converted to pixels.
+
+@d h_pixel_round(#)==round(h_conv*(#))
+@d v_pixel_round(#)==round(v_conv*(#))
+@^system dependencies@>
+@#
+@d large_h_space(#)==(#>=font_space(cur_fnt))or(#<=-4*font_space(cur_fnt))
+ {is this a ``large'' horizontal distance?}
+@d large_v_space(#)==(abs(#)>=5*font_space(cur_fnt))
+ {is this a ``large'' vertical distance?}
+@#
+@d h_rule_pixels== {converts the rule width |cur_h_dimen| to pixels}
+@!device if large_h_space(cur_h_dimen) then
+ begin h_pixels:=h_pixel_round(cur_h+cur_h_dimen)-cur_hh;
+ if h_pixels<=0 then if cur_h_dimen>0 then h_pixels:=1;
+ end
+else begin h_pixels:=trunc(h_conv*cur_h_dimen);
+ if h_pixels<h_conv*cur_h_dimen then incr(h_pixels);
+ end;
+ecived
+@#
+@d v_rule_pixels== {converts the rule height |cur_v_dimen| to pixels}
+@!device if large_v_space(cur_v_dimen) then
+ begin v_pixels:=cur_vv-v_pixel_round(cur_v-cur_v_dimen);
+ if v_pixels<=0 then v_pixels:=1; {used only for |cur_v_dimen>0|}
+ end
+else begin v_pixels:=trunc(v_conv*cur_v_dimen);
+ if v_pixels<v_conv*cur_v_dimen then incr(v_pixels);
+ end;
+ecived
+
+@ A sequence of consecutive rules, or consecutive characters in a
+fixed-width font whose width is not an integer number of pixels, can
+cause |hh| to drift far away from a correctly rounded value. \.{\title}
+ensures that the amount of drift will never exceed |max_h_drift| pixels;
+similarly |vv| shall never drift away from the correctly rounded value
+by more than |max_v_drift| pixels.
+
+@d h_upd_end(#)== {check for proper horizontal pixel rounding}
+begin Incr(cur_hh)(#); temp_pix:=h_pixel_round(cur_h);
+if abs(temp_pix-cur_hh)>max_h_drift then
+ if temp_pix>cur_hh then cur_hh:=temp_pix-max_h_drift
+ else cur_hh:=temp_pix+max_h_drift;
+end @+ ecived
+@d h_upd_char(#)==Incr(cur_h)(#)@;
+ @!device; h_upd_end
+@d h_upd_move(#)==Incr(cur_h)(#)@;
+ @!device; if large_h_space(#) then cur_hh:=h_pixel_round(cur_h)
+ else h_upd_end
+@#
+@d v_upd_end(#)== {check for proper vertical pixel rounding}
+begin Incr(cur_vv)(#); temp_pix:=v_pixel_round(cur_v);
+if abs(temp_pix-cur_vv)>max_v_drift then
+ if temp_pix>cur_vv then cur_vv:=temp_pix-max_v_drift
+ else cur_vv:=temp_pix+max_v_drift;
+end @+ ecived
+@d v_upd_move(#)==Incr(cur_v)(#)@;
+ @!device; if large_v_space(#) then cur_vv:=v_pixel_round(cur_v)
+ else v_upd_end
+
+@ The routines defined below use sections named `Declare local variables
+(if any) for \dots' or `Declare additional local variables for \dots';
+the former may declare variables (including the keyword \&{var}), whereas
+the later must at least contain the keyword \&{var}. In general, both may
+start with the declaration of labels, constants, and\slash or types.
+
+Let us start with the simple cases:
+The |do_pre| procedure is called when the preamble has been read from
+the \.{DVI} file; the preamble comment has just been converted into a
+temporary packet with the |new_packet| procedure.
+
+@p procedure do_pre;@/
+@<OUT: Declare local variables (if any) for |do_pre|@>@;
+begin all_done:=false; num_select:=cur_select; cur_select:=0;
+if num_select=0 then max_pages:=0;
+@!device
+h_conv:=(dvi_num/254000.0)*(h_resolution/dvi_den)*(out_mag/1000.0);
+v_conv:=(dvi_num/254000.0)*(v_resolution/dvi_den)*(out_mag/1000.0);
+ecived @; @/
+@<OUT: Process the |pre|@>@;@/
+end;
+
+@ The |do_bop| procedure is called when a |bop| has been read. This
+routine determines whether a page shall be processed or skipped and sets
+the variable |type_setting| accordingly.
+
+@p procedure do_bop;@/
+@<OUT: Declare additional local variables |do_bop|@>@;
+@!i,@!j:0..9; {indices into |count|}
+begin @<Determine whether this page should be processed or skipped@>;
+print('DVI: ');
+if type_setting then print('process') @+ else print('skipp');
+print('ing page ',count[0]:1); j:=9;
+while (j>0)and(count[j]=0) do decr(j);
+for i:=1 to j do print('.',count[i]:1);
+d_print(' at ',dvi_loc-45:1);
+print_ln('.');
+if type_setting then
+ begin stack_ptr:=0; cur_stack:=zero_stack; cur_fnt:=invalid_font;@/
+ @<OUT: Process a |bop|@>@;@/
+ end;
+end;
+
+@ Note that the device dependent code `OUT: Process a |bop|' may choose
+to set |type_setting| to false even if |selected| is true.
+
+@<Determine whether this page...@>=
+if not selected then selected:=start_match;
+type_setting:=selected
+
+@ The |do_eop| procedure is called in order to process an |eop|; the
+stack should be empty.
+
+@p procedure do_eop;@/
+@<OUT: Declare local variables (if any) for |do_eop|@>@;
+begin if stack_ptr<>0 then bad_dvi;
+@<OUT: Process an |eop|@>@;
+if max_pages>0 then
+ begin decr(max_pages);
+ if max_pages=0 then
+ begin selected:=false; incr(cur_select);
+ if cur_select=num_select then all_done:=true;
+ end;
+ end;
+type_setting:=false;
+end;
+
+@ The procedures |do_push| and |do_pop| are called in order to process
+|push| and |pop| commands; |do_push| must check for stack overflow,
+|do_pop| should never be called when the stack is empty.
+
+@p procedure do_push; {push onto stack}
+@<OUT: Declare local variables (if any) for |do_push|@>@;
+begin incr_stack(stack_ptr); stack[stack_ptr]:=cur_stack;@/
+@<OUT: Process a |push|@>@;
+end;
+@#
+procedure do_pop; {pop from stack}
+@<OUT: Declare local variables (if any) for |do_pop|@>@;
+begin if stack_ptr=0 then bad_dvi;
+cur_stack:=stack[stack_ptr]; decr(stack_ptr);
+@<OUT: Process a |pop|@>@;@/
+end;
+
+@ The |do_xxx| procedure is called in order to process a special command.
+The bytes of the special string have been put into |byte_mem| as the
+current string. They are converted to a temporary packet and discarded
+again.
+
+@p procedure do_xxx;@/
+@<OUT: Declare additional local variables for |do_xxx|@>@;
+@!p:pckt_pointer; {temporary packet}
+begin p:=new_packet;@/
+@<OUT: Process an |xxx|@>@;@/
+flush_packet;
+end;
+
+@ Next are the movement commands:
+The |do_right| procedure is called in order to process the horizontal
+movement commands |right|, |w|, and |x|.
+
+
+@p procedure do_right;@/
+@<OUT: Declare local variables (if any) for |do_right|@>@;
+begin if cur_class>=w_cl then cur_w_x[cur_class-w_cl]:=cur_parm
+else if cur_class<right_cl then cur_parm:=cur_w_x[cur_class-w0_cl];
+@<OUT: Process a |right| or |w| or |x|@>@;@/
+h_upd_move(cur_parm)(h_pixel_round(cur_parm));
+@<OUT: Move right@>@;
+end;
+
+@ The |do_down| procedure is called in order to process the vertical
+movement commands |down|, |y|, and |z|.
+
+@p procedure do_down;@/
+@<OUT: Declare local variables (if any) for |do_down|@>@;
+begin if cur_class>=y_cl then cur_y_z[cur_class-y_cl]:=cur_parm
+else if cur_class<down_cl then cur_parm:=cur_y_z[cur_class-y0_cl];
+@<OUT: Process a |down| or |y| or |z|@>@;@/
+v_upd_move(cur_parm)(v_pixel_round(cur_parm));
+@<OUT: Move down@>@;
+end;
+
+@ The |do_width| procedure, or actually the |do_a_width| macro, is
+called in order to increase the current horizontal position |cur_h| by
+|cur_h_dimen| in exactly the same way as if a character of width
+|cur_h_dimen| had been typeset.
+
+@d do_a_width(#)==
+ begin @!device h_pixels:=#; @+ ecived @; @+ do_width;
+ end
+
+@p procedure do_width;@/
+@<OUT: Declare local variables (if any) for |do_width|@>@;
+begin @<OUT: Typeset a |width|@>@;@/
+h_upd_char(cur_h_dimen)(h_pixels);
+@<OUT: Move right@>@;
+end;
+
+@ Finally we have the commands for the typesetting of rules and characters;
+the global variable |cur_upd| is |true| if the horizontal position shall
+be updated (\\{set} commands).
+
+The |do_rule| procedure is called in order to typeset a rule.
+
+@p procedure do_rule;@/
+@<OUT: Declare additional local variables |do_rule|@>@;
+@!visible:boolean;
+begin h_rule_pixels@;
+if (cur_h_dimen>0)and(cur_v_dimen>0) then
+ begin visible:=true; v_rule_pixels@;
+ @<OUT: Typeset a visible |rule|@>@;
+ end
+else begin visible:=false;
+ @<OUT: Typeset an invisible |rule|@>@;
+ end;
+if cur_upd then
+ begin h_upd_move(cur_h_dimen)(h_pixels);
+ @<OUT: Move right@>@;
+ end;
+end;
+
+@ Last not least the |do_char| procedure is called in order to typeset
+character~|cur_res| with extension~|cur_ext| from the real font~|cur_fnt|.
+
+@p procedure do_char;@/
+@<OUT: Declare local variables (if any) for |do_char|@>@;
+begin @<OUT: Typeset a |char|@>@;
+if cur_upd then
+ begin h_upd_char(widths[cur_wp])(char_pixels[cur_cp]);
+ @<OUT: Move right@>@;
+ end;
+end;
+
+@ If the program terminates abnormally, the following code may be
+invoked in the middle of a page.
+
+@<Finish output file(s)@>=
+begin if type_setting then @<OUT: Finish incomplete page@>;
+@<OUT: Finish output file(s)@>@;
+end
+
+@ When the first character of font~|cur_fnt| is about to be typeset, the
+|do_font| procedure is called in order to decide whether this is a
+virtual font or a real font.
+
+One step in this decision is the attempt to find and read the \.{VF}
+file for this font; other attempts to locate a font file may be
+performed before and after that, depending on the nature of the output
+device and on the structure of the file system at a particular
+installation. For a real device we convert the character widths to
+(horizontal) pixels.
+
+In any case |do_font| must change |font_type(cur_fnt)| to a value
+|>defined_font|; as a last resort one might use the \.{TFM} width data
+and draw boxes or leave blank spaces in the output.
+
+@p procedure do_font;@/
+label done;@/
+@<OUT: Declare additional local variables for |do_font|@>@;
+@!p:char_pointer; {index into |char_widths| and |char_pixels|}
+begin @!debug if font_type(cur_fnt)=defined_font then confusion(str_fonts);
+gubed@;
+@!device for p:=font_chars(cur_fnt)+font_bc(cur_fnt)
+ to font_chars(cur_fnt)+font_ec(cur_fnt) do
+ char_pixels[p]:=h_pixel_round(widths[char_widths[p]]);
+ecived@;
+@<OUT: Look for a font file before trying to read the \.{VF} file;
+ if found |goto done|@>@;@/
+if do_vf then goto done; {try to read the \.{VF} file}
+@<OUT: Look for a font file after trying to read the \.{VF} file@>@;@/
+done:
+@!debug if font_type(cur_fnt)<=loaded_font then confusion(str_fonts);
+gubed@;
+end;
+
+@ Before a character of font~|cur_fnt| is typeset the following piece of
+code ensures that the font is ready to be used.
+
+@<Prepare to use font |cur_fnt|@>=
+@<OUT: Prepare to use font |cur_fnt|@>@;
+if font_type(cur_fnt)<=loaded_font then do_font {|cur_fnt| was not yet used}
+
+@* Interpreting VF packets.
+The |pckt_first_par| procedure first reads a \.{DVI} command byte from
+the packet into |cur_cmd|; then |cur_parm| is set to the value of the
+first parameter (if any) and |cur_class| to the command class.
+
+@p procedure pckt_first_par;
+begin cur_cmd:=pckt_ubyte;
+case dvi_par[cur_cmd] of
+char_par: set_cur_char(pckt_ubyte);
+no_par: do_nothing;
+dim1_par: cur_parm:=pckt_sbyte;
+num1_par: cur_parm:=pckt_ubyte;
+dim2_par: cur_parm:=pckt_spair;
+num2_par: cur_parm:=pckt_upair;
+dim3_par: cur_parm:=pckt_strio;
+num3_par: cur_parm:=pckt_utrio;
+three_cases(dim4_par): cur_parm:=pckt_squad; {|dim4|, |num4|, or |numu|}
+rule_par:
+ begin cur_v_dimen:=pckt_squad; cur_h_dimen:=pckt_squad;
+ cur_upd:=(cur_cmd=set_rule);
+ end;
+fnt_par:cur_parm:=cur_cmd-fnt_num_0;
+end; {there are no other cases}
+cur_class:=dvi_cl[cur_cmd];
+end;
+
+@ The |do_vf_packet| procedure is called in order to interpret the
+character packet for a virtual character. Such a packet may contain the
+instruction to typeset a character from the same or an other virtual
+font; in such cases |do_vf_packet| calls itself recursively. The
+recursion level, i.e., the number of times this has happened, is kept
+in the global variable |n_recur| and should not exceed |max_recursion|.
+@^recursion@>
+
+@<Types...@>=
+@!recur_pointer=0..max_recursion;
+
+@ The \.{\title} processor should detect an infinite recursion caused by
+bad \.{VF} files; thus a new recursion level is entered even in cases
+where this could be avoided without difficulty.
+
+If the recursion level exceeds the allowed maximum, we want to give
+a traceback how this has happened; thus some of the global variables
+used in different invocations of |do_vf_packet| are saved in a stack,
+others are saved as local variables of |do_vf_packet|.
+
+@<Glob...@>=
+@!recur_fnt:array[recur_pointer] of font_number; {this packet's font}
+@!recur_ext:array[recur_pointer] of int_24; {this packet's extension}
+@!recur_res:array[recur_pointer] of int_32; {this packet's residue}
+@!recur_pckt:array[recur_pointer] of pckt_pointer; {the packet}
+@!recur_loc:array[recur_pointer] of byte_pointer; {next byte of packet}
+@!n_recur:recur_pointer; {current recursion level}
+@!recur_used:recur_pointer; {highest recursion level used so far}
+
+@ @<Set init...@>=
+n_recur:=0; recur_used:=0;
+
+@ Here now is the |do_vf_packet| procedure.
+
+@p procedure do_vf_packet;
+label continue,found,done;
+var k:recur_pointer; {loop index}
+@!f:int_8u; {packet type flag}
+@!save_upd:boolean; {used to save |cur_upd|}
+@!save_cp:width_pointer; {used to save |cur_cp|}
+@!save_wp:width_pointer; {used to save |cur_wp|}
+@!save_limit:byte_pointer; {used to save |cur_limit|}
+begin @<VF: Save values on entry to |do_vf_packet|@>;@/
+@<VF: Interpret the \.{DVI} commands in the packet@>@;@/
+if save_upd then
+ begin cur_h_dimen:=widths[save_wp]; do_a_width(char_pixels[save_cp]);
+ end;
+@<VF: Restore values on exit from |do_vf_packet|@>;@/
+end;
+
+@ On entry to |do_vf_packet| several values must be saved.
+
+@<VF: Save values on entry to |do_vf_packet|@>=
+save_upd:=cur_upd; save_cp:=cur_cp; save_wp:=cur_wp;@/
+recur_fnt[n_recur]:=cur_fnt;
+recur_ext[n_recur]:=cur_ext;
+recur_res[n_recur]:=cur_res
+
+@ Some of these values must be restored on exit from |do_vf_packet|.
+
+@<VF: Restore values on exit from |do_vf_packet|@>=
+cur_fnt:=recur_fnt[n_recur]
+
+@ If |cur_pckt| is the empty packet, we manufacture a |put| command;
+otherwise we read and interpret \.{DVI} commands from the packet.
+
+@<VF: Interpret the \.{DVI} commands in the packet@>=
+if find_packet then f:=cur_type @+ else goto done;
+recur_pckt[n_recur]:=cur_pckt;
+save_limit:=cur_limit;
+cur_fnt:=font_font(cur_fnt);
+if cur_pckt=empty_packet then
+ begin cur_class:=char_cl; goto found;
+ end;
+if cur_loc>=cur_limit then goto done;
+continue: pckt_first_par;
+found: case cur_class of
+char_cl: @<VF: Typeset a |char|@>;
+rule_cl: do_rule;
+xxx_cl:
+ begin pckt_room(cur_parm);
+ while cur_parm>0 do
+ begin append_byte(pckt_ubyte); decr(cur_parm);
+ end;
+ do_xxx;
+ end;
+push_cl: do_push;
+pop_cl: do_pop;
+five_cases(w0_cl): do_right; {|right|, |w|, or |x|}
+five_cases(y0_cl): do_down; {|down|, |y|, or |z|}
+fnt_cl: cur_fnt:=cur_parm;
+othercases confusion(str_packets); {font definition or invalid}
+endcases;
+if cur_loc<cur_limit then goto continue;
+done:
+
+@ The final |put| of a simple packet may be changed into |set_char| or
+\\{set}.
+
+@<VF: Typeset a |char|@>=
+begin @<Prepare to use font |cur_fnt|@>;
+cur_cp:=font_chars(cur_fnt)+cur_res; cur_wp:=char_widths[cur_cp];
+if (cur_loc=cur_limit)and(f=vf_simple) and save_upd then
+ begin save_upd:=false; cur_upd:=true;
+ end;
+if font_type(cur_fnt)=vf_font_type then
+ @<VF: Enter a new recursion level@>
+else do_char;
+end
+
+@ Before entering a new recursion level we must test for overflow; in
+addition a few variables must be saved and restored.
+A |set_char| or \\{set} followed by |pop| is changed into |put|.
+
+@<VF: Enter a new recursion level@>=
+begin recur_loc[n_recur]:=cur_loc; {save}
+if cur_loc<cur_limit then
+ if byte_mem[cur_loc]=bi(pop) then cur_upd:=false;
+if n_recur=recur_used then
+ if recur_used=max_recursion then
+ @<VF: Display the recursion traceback and terminate@>
+ else incr(recur_used);@/
+incr(n_recur); do_vf_packet; decr(n_recur); {recurse}
+cur_loc:=recur_loc[n_recur]; cur_limit:=save_limit; {restore}
+end
+
+@ @<VF: Display the recursion traceback and terminate@>=
+begin print_ln(' !Infinite VF recursion?');
+@.Infinite VF recursion?@>
+for k:=max_recursion downto 0 do
+ begin print('level=',k:1,' font');
+ d_print('=',recur_fnt[k]:1);
+ print_font(recur_fnt[k]);
+ print(' char=',recur_res[k]:1);
+ if recur_ext[k]<>0 then print('.',recur_ext[k]:1);
+ new_line;
+ @!debug hex_packet(recur_pckt[k]); print_ln('loc=',recur_loc[k]:1);
+ gubed@;
+ end;
+overflow(str_recursion,max_recursion);
+end
+
+@* Interpreting the DVI file.
+The |do_dvi| procedure reads the entire \.{DVI} file and initiates
+whatever actions may be necessary.
+
+@p procedure do_dvi;
+label done,exit;
+var temp_byte:int_8u; {byte for temporary variables}
+@!temp_int:int_32; {integer for temporary variables}
+@!dvi_start:int_32; {starting location}
+@!dvi_bop_post:int_32; {location of |bop| or |post|}
+@!dvi_back:int_32; {a back pointer}
+@!k:int_15; {general purpose variable}
+begin @<DVI: Process the preamble@>;
+if random_reading then @<DVI: Process the postamble@>;
+repeat dvi_first_par;
+ while cur_class=fnt_def_cl do
+ begin dvi_do_font(random_reading); dvi_first_par;
+ end;
+ if cur_cmd=bop then @<DVI: Process one page@>;
+until cur_cmd<>eop;
+if cur_cmd<>post then bad_dvi;
+exit:end;
+
+@ @<DVI: Process the preamble@>=
+if dvi_ubyte<>pre then bad_dvi;
+if dvi_ubyte<>dvi_id then bad_dvi;
+dvi_num:=dvi_pquad; dvi_den:=dvi_pquad; dvi_mag:=dvi_pquad;
+tfm_conv:=(25400000.0/dvi_num)*(dvi_den/473628672)/16.0;
+temp_byte:=dvi_ubyte; pckt_room(temp_byte);
+for k:=1 to temp_byte do append_byte(dvi_ubyte);
+print('DVI file: '''); print_packet(new_packet); print_ln(''',');
+print(' num=',dvi_num:1,', den=',dvi_den:1,', mag=',dvi_mag:1);
+if out_mag<=0 then out_mag:=dvi_mag @+ else print(' => ',out_mag:1);
+print_ln('.');
+do_pre; flush_packet
+
+@ @<Glob...@>=
+@!dvi_num:int_31; {numerator}
+@!dvi_den:int_31; {denominator}
+@!dvi_mag:int_31; {magnification}
+
+@ @<DVI: Process the postamble@>=
+begin dvi_start:=dvi_loc; {remember start of first page}
+@<DVI: Find the postamble@>;
+d_print_ln('DVI: postamble at ',dvi_bop_post:1);
+dvi_back:=dvi_pointer;
+if dvi_num<>dvi_pquad then bad_dvi;
+if dvi_den<>dvi_pquad then bad_dvi;
+if dvi_mag<>dvi_pquad then bad_dvi;
+temp_int:=dvi_squad; temp_int:=dvi_squad;
+if stack_size<dvi_upair then overflow(str_stack,stack_size);
+temp_int:=dvi_upair;
+dvi_first_par;
+while cur_class=fnt_def_cl do
+ begin dvi_do_font(false); dvi_first_par;
+ end;
+if cur_cmd<>post_post then bad_dvi;
+if not selected then @<DVI: Find the starting page@>;
+dvi_move(dvi_start); {go to first or starting page}
+end
+
+@ @<DVI: Find the postamble@>=
+temp_int:=dvi_length-5;
+repeat if temp_int<49 then bad_dvi;
+dvi_move(temp_int); temp_byte:=dvi_ubyte; decr(temp_int);
+until temp_byte<>dvi_pad;
+if temp_byte<>dvi_id then bad_dvi;
+dvi_move(temp_int-4); if dvi_ubyte<>post_post then bad_dvi;
+dvi_bop_post:=dvi_pointer;
+if (dvi_bop_post<15)or(dvi_bop_post>dvi_loc-34) then bad_dvi;
+dvi_move(dvi_bop_post); if dvi_ubyte<>post then bad_dvi
+
+@ @<DVI: Find the starting page@>=
+begin dvi_start:=dvi_bop_post; {just in case}
+while dvi_back<>-1 do
+ begin if (dvi_back<15)or(dvi_back>dvi_bop_post-46) then bad_dvi;
+ dvi_bop_post:=dvi_back; dvi_move(dvi_back);
+ if dvi_ubyte<>bop then bad_dvi;
+ for k:=0 to 9 do count[k]:=dvi_squad;
+ if start_match then dvi_start:=dvi_bop_post;
+ dvi_back:=dvi_pointer;
+ end;
+end
+
+@ When a |bop| has been read, the \.{DVI} commands for one page are
+interpreted until an |eop| is found.
+
+@<DVI: Process one page@>=
+begin for k:=0 to 9 do count[k]:=dvi_squad;
+temp_int:=dvi_pointer; do_bop;
+dvi_first_par;
+if type_setting then @<DVI: Process a page; then |goto done|@>
+else @<DVI: Skip a page; then |goto done|@>;
+done:if cur_cmd<>eop then bad_dvi;
+if selected then
+ begin do_eop;
+ if all_done then return;
+ end;
+end
+
+@ All \.{DVI} commands are processed, as long as |cur_class<>invalid_cl|;
+then we should have found an |eop|.
+
+@<DVI: Process a page; then |goto done|@>=
+loop begin
+ case cur_class of
+ char_cl: @<DVI: Typeset a |char|@>;
+ rule_cl:
+ if cur_upd and(cur_v_dimen=width_dimen) then
+ do_a_width(h_pixel_round(cur_h_dimen))
+ else do_rule;
+ xxx_cl:
+ begin pckt_room(cur_parm);
+ while cur_parm>0 do
+ begin append_byte(dvi_ubyte); decr(cur_parm);
+ end;
+ do_xxx;
+ end;
+ push_cl: do_push;
+ pop_cl: do_pop;
+ five_cases(w0_cl): do_right; {|right|, |w|, or |x|}
+ five_cases(y0_cl): do_down; {|down|, |y|, or |z|}
+ fnt_cl: dvi_font;
+ fnt_def_cl: dvi_do_font(random_reading);
+ invalid_cl: goto done;
+ end; {there are no other cases}
+dvi_first_par; {get the next command}
+end
+
+@ While skipping a page all commands other than font definitions are
+ignored.
+
+@<DVI: Skip a page; then |goto done|@>=
+loop begin
+ case cur_class of
+ xxx_cl: while cur_parm>0 do
+ begin temp_byte:=dvi_ubyte; decr(cur_parm);
+ end;
+ fnt_def_cl: dvi_do_font(random_reading);
+ invalid_cl: goto done;
+ othercases do_nothing;
+ endcases;
+dvi_first_par; {get the next command}
+end
+
+@ @<DVI: Typeset a |char|@>=
+begin @<Prepare to use font |cur_fnt|@>;
+set_cur_wp(cur_fnt)(bad_dvi);
+if font_type(cur_fnt)=vf_font_type then do_vf_packet @+ else do_char;
+end
+
+@* The main program.
+The code for real devices is still rather incomplete.
+Moreover several branches of the program have not been tested because
+they are never used with \.{DVI} files made by \TeX\ and \.{VF} files
+made by \.{VPtoVF}. The same holds true for~$\Omega$.
+
+@ At the end of the program the output file(s) have to be finished and
+on some systems it may be necessary to close input and\slash or output
+files.
+@^system dependencies@>
+
+@p procedure close_files_and_terminate;
+var k:@!int_15; {general purpose index}
+begin close_in(dvi_file);
+if history<fatal_message then @<Finish output file(s)@>;
+stat @<Print memory usage statistics@>;@+tats@;@/
+@<Close output file(s)@>@;
+@<Print the job |history|@>;
+end;
+
+@ Now we are ready to put it all together.
+Here is where \.{\title} starts, and where it ends.
+@^system dependencies@>
+
+@p begin initialize; {get all variables initialized}
+@<Initialize predefined strings@>@;
+dialog; {get options}
+@<Open input file(s)@>@;
+@<Open output file(s)@>@;
+do_dvi; {process the entire \.{DVI} file}
+close_files_and_terminate;
+final_end:end.
+
+@ @<Print memory usage statistics@>=
+print_ln('Memory usage statistics:');
+print(dvi_nf:1,' dvi, ',lcl_nf:1,' local, ');
+@<Print more font usage statistics@>@;@/
+print_ln('and ',nf:1,' internal fonts of ',max_fonts:1);
+print_ln(n_widths:1,' widths of ',max_widths:1,' for ',
+ n_chars:1,' characters of ',max_chars:1);
+print_ln(pckt_ptr:1,' byte packets of ',max_packets:1,' with ',
+ byte_ptr:1,' bytes of ',max_bytes:1);
+@<Print more memory usage statistics@>@;@/
+print_ln(stack_used:1,' of ',stack_size:1,' stack and ',
+ recur_used:1,' of ',max_recursion:1,' recursion levels.')
+
+@ Some implementations may wish to pass the |history| value to the
+operating system so that it can be used to govern whether or not other
+programs are started. Here we simply report the history to the user.
+@^system dependencies@>
+
+@<Print the job |history|@>=
+case history of
+spotless: print_ln('(No errors were found.)');
+harmless_message: print_ln('(Did you see the warning message above?)');
+error_message: print_ln('(Pardon me, but I think I spotted something wrong.)');
+fatal_message: print_ln('(That was a fatal error, my friend.)');
+end {there are no other cases}
+
+@* Low-level output routines.
+The program uses the binary file variable |out_file| for its main output
+file; |out_loc| is the number of the byte about to be written next on
+|out_file|.
+
+@<Glob...@>=
+@!out_file:byte_file; {the \.{DVI} file we are writing}
+@!out_loc:int_32; {where we are about to write, in |out_file|}
+@!out_back:int_32; {a back pointer}
+@!out_max_v:int_31; {maximum |v| value so far}
+@!out_max_h:int_31; {maximum |h| value so far}
+@!out_stack:int_16u; {maximum stack depth}
+@!out_pages:int_16u; {total number of pages}
+
+@ @<Set ini...@>=
+out_loc:=0; out_back:=-1;
+out_max_v:=0; out_max_h:=0;
+out_stack:=0; out_pages:=0;
+
+@ To prepare |out_file| for output, we |rewrite| it.
+
+@<Open output file(s)@>=
+rewrite(out_file); {prepares to write packed bytes to |out_file|}
+
+@ For some operating systems it may be necessary to close |out_file|.
+
+@<Close output file(s)@>=
+
+@ Writing the |out_file| should be done as efficient as possible for a
+particular system; on many systems this means that a large number of
+bytes will be accumulated in a buffer and is then written from that
+buffer to |out_file|. In order to simplify such system dependent changes
+we use the \.{WEB} macro |out_byte| to write the next \.{DVI} byte. Here
+we give a simple minded definition for this macro in terms of standard
+\PASCAL.
+@^system dependencies@>
+@^optimization@>
+
+@d out_byte(#) == write(out_file,#) {write next \.{DVI} byte}
+
+@ The \.{WEB} macro |out_one| is used to write one byte and to update
+|out_loc|.
+
+@d out_one(#) == begin out_byte(#); incr(out_loc); @+ end
+
+@ First the |out_packet| procedure copies a packet to |out_file|.
+
+@<Declare typesetting procedures@>=
+procedure out_packet(@!p:pckt_pointer);
+var k:byte_pointer; {index into |byte_mem|}
+begin Incr(out_loc)(pckt_length(p));
+for k:=pckt_start[p] to pckt_start[p+1]-1 do out_byte(bo(byte_mem[k]));
+end;
+
+@ Next are the procedures used to write integer numbers or even complete
+\.{DVI} commands to |out_file|; they all keep |out_loc| up to date.
+
+The |out_four| procedure outputs four bytes in two's complement notation,
+without risking arithmetic overflow.
+
+@<Declare typesetting procedures@>=
+procedure out_four(@!x:int_32); {output four bytes}
+@!begin_four; comp_four(out_byte); Incr(out_loc)(4);
+end;
+
+@ The |out_char| procedure outputs a |set_char| or \\{set} command or, if
+|upd=false|, a |put| command.
+
+@<Declare typesetting procedures@>=
+procedure out_char(@!upd:boolean;@!ext:int_32;@!res:int_32);
+ {output \\{set} or |put|}
+@!begin_char; comp_char(out_one);
+end;
+
+@ The |out_unsigned| procedure outputs a |fnt|, |xxx|, or |fnt_def|
+command with its first parameter (normally unsigned); a |fnt| command
+is converted into |fnt_num| whenever this is possible.
+
+@<Declare typesetting procedures@>=
+procedure out_unsigned(@!o:eight_bits;@!x:int_32);
+ {output |fnt_num|, |fnt|, |xxx|, or |fnt_def|}
+@!begin_unsigned; comp_unsigned(out_one);
+end;
+
+@ The |out_signed| procedure outputs a movement (|right|, |w|,
+|x|, |down|, |y|, or |z|) command with its (signed) parameter.
+
+@<Declare typesetting procedures@>=
+procedure out_signed(@!o:eight_bits;@!x:int_32);
+ {output |right|, |w|, |x|, |down|, |y|, or |z|}
+@!begin_signed; comp_signed(out_one);
+end;
+
+@ For an output font we set |font_type(f):=out_font_type|; in this case
+|font_font(f)| is the font number used for font~|f| in |out_file|.
+@^font types@>
+
+The global variable |out_nf| is the number of fonts already used in
+|out_file| and the array |out_fnts| contains their internal font numbers;
+the current font in |out_file| is called |out_fnt|.
+
+@<Glob...@>=
+@!out_fnts:array[font_number] of font_number; {internal font numbers}
+@!out_nf:font_number; {number of fonts used in |out_file|}
+@!out_fnt:font_number; {internal font number of current output font}
+
+@ @<Set init...@>=
+out_nf:=0;
+
+@ @<Print more font usage statistics@>=
+print(out_nf:1,' out, ');
+
+@ The |out_fnt_def| procedure outputs a complete font definition
+command.
+
+@<Declare typesetting procedures@>=
+procedure out_fnt_def(@!f:font_number);
+var p:pckt_pointer; {the font name packet}
+@!k,@!l:byte_pointer; {indices into |byte_mem|}
+@!a:eight_bits; {length of area part}
+begin out_unsigned(fnt_def1,font_font(f)); out_four(font_check(f));
+out_four(font_scaled(f)); out_four(font_design(f));@/
+p:=font_name(f); k:=pckt_start[p]; l:=pckt_start[p+1]-1;
+a:=bo(byte_mem[k]);@/
+Incr(out_loc)(l-k+2); out_byte(a); out_byte(l-k-a);
+while k<l do
+ begin incr(k); out_byte(bo(byte_mem[k]));
+ end;
+end;
+
+@* Writing the output file.
+Here we define the device dependent parts of the typesetting routines
+described earlier in this program.
+
+First we define a few quantities required by the device dependent code
+for a real output device in order to demonstrate how they might be
+defined and in order to be able to compile \.{DVIcopy} with the device
+dependent code included.
+
+@d h_resolution==300 {horizontal resolution in pixels per inch (dpi)}
+@d v_resolution==300 {vertical resolution in pixels per inch (dpi)}
+
+@d max_h_drift==2 {we insist that |abs(hh-h_pixel_round(h))<=max_h_drift|}
+@d max_v_drift==2 {we insist that |abs(vv-v_pixel_round(v))<=max_v_drift|}
+
+@<Glob...@>=
+@!device
+@!h_conv:real; {converts \.{DVI} units to horizontal pixels}
+@!v_conv:real; {converts \.{DVI} units to vertical pixels}
+ecived
+
+@ These are the local variables (if any) needed for |do_pre|.
+
+@<OUT: Declare local variables (if any) for |do_pre|@>=
+var k:int_15; {general purpose variable}
+@!p,@!q,@!r:byte_pointer; {indices into |byte_mem|}
+@!comment:packed array[1..comm_length] of char; {preamble comment prefix}
+
+@ And here is the device dependent code for |do_pre|; the \.{DVI} preamble
+comment written to |out_file| is similar to the one produced by \.{GFtoPK},
+but we want to apply our preamble comment prefix only once.
+
+@<OUT: Process the |pre|@>=
+out_one(pre); out_one(dvi_id);
+out_four(dvi_num); out_four(dvi_den); out_four(out_mag);@/
+p:=pckt_start[pckt_ptr-1]; q:=byte_ptr; {location of old \.{DVI} comment}
+comment:=preamble_comment; pckt_room(comm_length);
+for k:=1 to comm_length do append_byte(xord[comment[k]]);
+while byte_mem[p]=bi(" ") do incr(p); {remove leading blanks}
+if p=q then Decr(byte_ptr)(from_length)
+else begin k:=0;
+ while (k<comm_length)and(byte_mem[p+k]=byte_mem[q+k]) do incr(k);
+ if k=comm_length then Incr(p)(comm_length);
+ end;
+k:=byte_ptr-p; {total length}
+if k>255 then
+ begin k:=255; q:=p+255-comm_length; {at most 255 bytes}
+ end;
+out_one(k); out_packet(new_packet); flush_packet;
+for r:=p to q-1 do out_one(bo(byte_mem[r]));
+
+@ These are the additional local variables (if any) needed for |do_bop|;
+the variables |@!i| and |@!j| are already declared.
+
+@<OUT: Declare additional local variables |do_bop|@>=
+var
+
+@ And here is the device dependent code for |do_bop|.
+
+@<OUT: Process a |bop|@>=
+out_one(bop); incr(out_pages);
+for i:=0 to 9 do out_four(count[i]);
+out_four(out_back); out_back:=out_loc-45;
+out_fnt:=invalid_font;
+
+@ These are the local variables (if any) needed for |do_eop|.
+
+@<OUT: Declare local variables (if any) for |do_eop|@>=
+
+@ And here is the device dependent code for |do_eop|.
+
+@<OUT: Process an |eop|@>=
+out_one(eop);
+
+@ These are the local variables (if any) needed for |do_push|.
+
+@<OUT: Declare local variables (if any) for |do_push|@>=
+
+@ And here is the device dependent code for |do_push|.
+
+@<OUT: Process a |push|@>=
+if stack_ptr>out_stack then out_stack:=stack_ptr;
+out_one(push);
+
+@ These are the local variables (if any) needed for |do_pop|.
+
+@<OUT: Declare local variables (if any) for |do_pop|@>=
+
+@ And here is the device dependent code for |do_pop|.
+
+@<OUT: Process a |pop|@>=
+out_one(pop);
+
+@ These are the additional local variables (if any) needed for |do_xxx|;
+the variable |@!p|, the pointer to the packet containing the special
+string, is already declared.
+
+@<OUT: Declare additional local variables for |do_xxx|@>=
+var
+
+@ And here is the device dependent code for |do_xxx|.
+
+@<OUT: Process an |xxx|@>=
+out_unsigned(xxx1,pckt_length(p)); out_packet(p);
+
+@ These are the local variables (if any) needed for |do_right|.
+
+@<OUT: Declare local variables (if any) for |do_right|@>=
+
+@ And here is the device dependent code for |do_right|.
+
+@<OUT: Process a |right| or |w| or |x|@>=
+if cur_class<right_cl then out_one(cur_cmd) {|w0| or |x0|}
+else out_signed(dvi_right_cmd[cur_class],cur_parm); {|right|, |w|, or |x|}
+
+@ Here we update the |out_max_h| value.
+
+@<OUT: Move right@>=
+if abs(cur_h)>out_max_h then out_max_h:=abs(cur_h);
+
+@ These are the local variables (if any) needed for |do_down|.
+
+@<OUT: Declare local variables (if any) for |do_down|@>=
+
+@ And here is the device dependent code for |do_down|.
+
+@<OUT: Process a |down| or |y| or |z|@>=
+if cur_class<down_cl then out_one(cur_cmd) {|y0| or |z0|}
+else out_signed(dvi_down_cmd[cur_class],cur_parm); {|down|, |y|, or |z|}
+
+@ Here we update the |out_max_v| value.
+
+@<OUT: Move down@>=
+if abs(cur_v)>out_max_v then out_max_v:=abs(cur_v);
+
+@ These are the local variables (if any) needed for |do_width|.
+
+@<OUT: Declare local variables (if any) for |do_width|@>=
+
+@ And here is the device dependent code for |do_width|.
+
+@<OUT: Typeset a |width|@>=
+out_one(set_rule);
+out_four(width_dimen); out_four(cur_h_dimen);
+
+@ These are the additional local variables (if any) needed for |do_rule|;
+the variable |@!visible| is already declared.
+
+@<OUT: Declare additional local variables |do_rule|@>=
+var
+
+@ And here is the device dependent code for |do_rule|.
+
+@<OUT: Typeset a visible |rule|@>=
+out_one(dvi_rule_cmd[cur_upd]);
+out_four(cur_v_dimen); out_four(cur_h_dimen);
+
+@ @<OUT: Typeset an invisible |rule|@>=
+@<OUT: Typeset a visible |rule|@>
+
+@ These are the additional local variables (if any) needed for |do_font|;
+the variable |@!p| is already declared.
+
+@<OUT: Declare additional local variables for |do_font|@>=
+var
+
+@ And here is the device dependent code for |do_font|; if the \.{VF} file
+for a font could not be found, we simply assume this must be a real font.
+
+@<OUT: Look for a font file before trying to read the \.{VF} file;
+ if found |goto done|@>=
+
+@ @<OUT: Look for a font file after trying to read the \.{VF} file@>=
+if(out_nf>=max_fonts) then overflow(str_fonts,max_fonts);
+print('OUT: font ',cur_fnt:1); d_print(' => ',out_nf:1);
+print_font(cur_fnt);
+d_print(' at ',font_scaled(cur_fnt):1,' DVI units'); print_ln('.');
+font_type(cur_fnt):=out_font_type; font_font(cur_fnt):=out_nf;
+out_fnts[out_nf]:=cur_fnt; incr(out_nf);
+out_fnt_def(cur_fnt);
+
+@ And here is some device dependent code used before each character.
+
+@<OUT: Prepare to use font |cur_fnt|@>=
+
+@ These are the local variables (if any) needed for |do_char|.
+
+@<OUT: Declare local variables (if any) for |do_char|@>=
+
+@ And here is the device dependent code for |do_char|.
+
+@<OUT: Typeset a |char|@>=
+@!debug if font_type(cur_fnt)<>out_font_type then confusion(str_fonts);
+gubed @;
+if cur_fnt<>out_fnt then
+ begin out_unsigned(fnt1,font_font(cur_fnt)); out_fnt:=cur_fnt;
+ end;
+out_char(cur_upd,cur_ext,cur_res);
+
+@ If the program terminates in the middle of a page, we write as many
+|pop|s as necessary and one |eop|.
+
+@<OUT: Finish incomplete page@>=
+begin while stack_ptr>0 do
+ begin out_one(pop); decr(stack_ptr);
+ end;
+ out_one(eop);
+end
+
+@ If the output file has been started, we write the postamble; in
+addition we print the number of bytes and pages written to |out_file|.
+
+@<OUT: Finish output file(s)@>=
+if out_loc>0 then
+ begin @<OUT: Write the postamble@>;
+ k:=7-((out_loc-1) mod 4); {the number of |dvi_pad| bytes}
+ while k>0 do
+ begin out_one(dvi_pad); decr(k);
+ end;
+ print('OUT file: ',out_loc:1,' bytes, ',out_pages:1,' page');
+ if out_pages<>1 then print('s');
+ end
+else print('OUT file: no output');
+print_ln(' written.');
+if out_pages=0 then mark_harmless;
+
+@ Here we simply write the values accumulated during the \.{DVI} output.
+
+@<OUT: Write the postamble@>=
+out_one(post); out_four(out_back); out_back:=out_loc-5;@/
+out_four(dvi_num); out_four(dvi_den); out_four(out_mag);@/
+out_four(out_max_v); out_four(out_max_h);@/
+out_one(out_stack div @"100); out_one(out_stack mod @"100);@/
+out_one(out_pages div @"100); out_one(out_pages mod @"100);@/
+k:=out_nf;
+while k>0 do
+ begin decr(k); out_fnt_def(out_fnts[k]);
+ end;
+out_one(post_post); out_four(out_back);@/
+out_one(dvi_id)
+
+@ Here we could print more memory usage statistics; this possibility is,
+however, not used for \.{DVIcopy}.
+
+@<Print more memory usage statistics@>=
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{DVIcopy} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.
+
diff --git a/Build/source/texk/web2c/omegaware/odvitype.ch b/Build/source/texk/web2c/omegaware/odvitype.ch
new file mode 100644
index 00000000000..a1e49ad1c6c
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/odvitype.ch
@@ -0,0 +1,767 @@
+% odvitype.ch: web2c changes for file odvitype.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original dvitype.ch.
+%
+% dvitype.ch for C compilation with web2c.
+%
+% 04/04/83 (PC) Merged with Pavel's change file and made to work with the
+% version 1.0 of DVItype released with version 0.95 of TeX in
+% February, 1983.
+% 04/18/83 (PC) Added changes to module 47 so that it would work the same
+% when input was a file (or pipe) as with a terminal.
+% 06/29/83 (HWT) Brought up to version 1.1 as released with version 0.99 of
+% TeX, with new change file format
+% 07/28/83 (HWT) Brought up to version 2 as released with version 0.999.
+% Only the banner changes.
+% 11/21/83 (HWT) Brought up to version 2.2 as released with version 1.0.
+% 02/19/84 (HWT) Made it use the TEXFONTS environment variable.
+% 03/23/84 (HWT) Brought up to version 2.3.
+% 07/11/84 (HWT) Brought up to version 2.6 as released with version 1.1.
+% 11/07/84 (ETM) Brought up to version 2.7 as released with version 1.2.
+% 03/09/88 (ETM) Brought up to version 2.9
+% 03/16/88 (ETM) Converted for use with WEB to C.
+% 11/30/89 (KB) To version 3.
+% 01/16/90 (SR) To version 3.2.
+% (more recent changes in the ChangeLog)
+
+@x [0] WEAVE: print changes only.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+\let\maybe=\iffalse
+\def\title{DVI$\,$\lowercase{type} changes for C}
+@z
+
+% [3] Specify the output file to simplify web2c, and don't print the
+% banner until later.
+@x
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+@y
+@d print(#)==write(stdout, #)
+@d print_ln(#)==write_ln(stdout, #)
+@z
+
+@x
+procedure initialize; {this procedure gets things started properly}
+ var i:integer; {loop index for initializations}
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ var i:integer; {loop index for initializations}
+ begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+ print (banner);
+ print_ln (version_string);
+@z
+
+@x [5] Allow more fonts, more widths, no arbitrary filename length.
+@!max_fonts=100; {maximum number of distinct fonts per \.{DVI} file}
+@!max_widths=100000; {maximum number of different characters among all fonts}
+@y
+@!max_fonts=500; {maximum number of distinct fonts per \.{DVI} file}
+@!max_widths=100000; {maximum number of different characters among all fonts}
+@z
+@x
+@!name_size=1000; {total length of all font file names}
+@!name_length=50; {a file name shouldn't be longer than this}
+@y
+@!name_size=10000; {total length of all font file names}
+@z
+
+@x [7] Remove non-local goto.
+@d abort(#)==begin print(' ',#); jump_out;
+ end
+@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
+@.Bad DVI file@>
+
+@p procedure jump_out;
+begin goto final_end;
+end;
+@y
+@d jump_out==uexit(1)
+@d abort(#)==begin write_ln(stderr,#); jump_out; end
+@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
+@.Bad DVI file@>
+@z
+
+@x [8] Permissive input.
+@!ASCII_code=" ".."~"; {a subrange of the integers}
+@y
+@!ASCII_code=0..255; {a subrange of the integers}
+@z
+
+% [9] The text_char type is used as an array index into `xord'. The
+% default type `char' produces signed integers, which are bad array
+% indices in C.
+@x
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=127 {ordinal number of the largest element of |text_char|}
+@y
+@d text_char == ASCII_code {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=255 {ordinal number of the largest element of |text_char|}
+@z
+
+@x [23] Fix up opening the files.
+@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
+begin reset(dvi_file);
+cur_loc:=0;
+end;
+@#
+procedure open_tfm_file; {prepares to read packed bytes in |tfm_file|}
+begin reset(tfm_file,cur_name);
+end;
+@y
+@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
+begin
+ cur_name := extend_filename (cmdline (optind), 'dvi');
+ resetbin (dvi_file, cur_name);
+ cur_loc := 0;
+end;
+@#
+procedure open_tfm_file; {prepares to read packed bytes in |tfm_file|}
+var full_name: ^char;
+begin
+ full_name := kpse_find_tfm (cur_name);
+ if full_name then begin
+ tfm_file := fopen (full_name, FOPEN_RBIN_MODE);
+ end else begin
+ full_name := kpse_find_ofm (cur_name);
+ if full_name then begin
+ tfm_file := fopen (full_name, FOPEN_RBIN_MODE);
+ end else begin
+ tfm_file := nil;
+ end;
+ end;
+end;
+@z
+
+@x [24] No arbitrary limit on filename length.
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+@y
+@!cur_name:^char; {external name}
+@z
+
+@x [27] Make get_n_bytes routines work with 16-bit math.
+get_two_bytes:=a*256+b;
+@y
+get_two_bytes:=intcast(a)*256+intcast(b);
+@z
+@x
+get_three_bytes:=(a*256+b)*256+c;
+@y
+get_three_bytes:=(intcast(a)*256+intcast(b))*256+intcast(c);
+@z
+@x
+if a<128 then signed_trio:=(a*256+b)*256+c
+else signed_trio:=((a-256)*256+b)*256+c;
+@y
+if a<128 then signed_trio:=(intcast(a)*256+b)*256+intcast(c)
+else signed_trio:=((intcast(a)-256)*256+intcast(b))*256+intcast(c);
+@z
+@x
+if a<128 then signed_quad:=((a*256+b)*256+c)*256+d
+else signed_quad:=(((a-256)*256+b)*256+c)*256+d;
+@y
+if a<128 then signed_quad:=((intcast(a)*256+b)*256+intcast(c))*256+intcast(d)
+else signed_quad:=(((intcast(a)-256)*256+intcast(b))*256+intcast(c))*256+intcast(d);
+@z
+
+@x [28] dvi_length and move_to_byte.
+@p function dvi_length:integer;
+begin set_pos(dvi_file,-1); dvi_length:=cur_pos(dvi_file);
+end;
+@#
+procedure move_to_byte(n:integer);
+begin set_pos(dvi_file,n); cur_loc:=n;
+end;
+@y
+@p function dvi_length:integer;
+begin
+ xfseek (dvi_file, 0, 2, 'odvitype');
+ cur_loc := xftell(dvi_file, 'odvitype');
+ dvi_length := cur_loc;
+end;
+@#
+procedure move_to_byte(n:integer);
+begin
+ xfseek (dvi_file, n, 0, 'odvitype');
+ cur_loc:=n;
+end;
+@z
+
+@x [35] Make 16-bit TFM calculations work.
+if (b0*256+b1)<>0 then begin {TFM file}
+ ofm_level:=-1;
+ lh:=b2*256+b3;
+ read_tfm_word; font_bc[nf]:=b0*256+b1; font_ec[nf]:=b2*256+b3;
+@y
+if (intcast(b0)*256+intcast(b1))<>0 then begin {TFM file}
+ ofm_level:=-1;
+ lh:=intcast(b2)*256+intcast(b3);
+ read_tfm_word; font_bc[nf]:=intcast(b0)*256+intcast(b1);
+ font_ec[nf]:=intcast(b2)*256+intcast(b3);
+@z
+@x
+ read_tfm_word; nw:=b0*256+b1;
+@y
+ read_tfm_word; nw:=intcast(b0)*256+intcast(b1);
+@z
+@x
+ if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
+ else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3
+@y
+ if b0<128 then tfm_check_sum:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3)
+ else tfm_check_sum:=(((intcast(b0)-256)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3)
+@z
+@x
+ ofm_level:=b2*256+b3;
+ read_tfm_word;
+ read_tfm_word; lh:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_bc[nf]:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_ec[nf]:=((b0*256+b1)*256+b2)*256+b3;
+@y
+ ofm_level:=intcast(b2)*256+intcast(b3);
+ read_tfm_word;
+ read_tfm_word; lh:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3);
+ read_tfm_word; font_bc[nf]:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3);
+ read_tfm_word; font_ec[nf]:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3);
+@z
+@x
+ read_tfm_word; nw:=((b0*256+b1)*256+b2)*256+b3;
+@y
+ read_tfm_word; nw:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3);
+@z
+@x
+ read_tfm_word; extra_words:=(((b0*256+b1)*256+b2)*256+b3) div 2;
+@y
+ read_tfm_word;
+ extra_words:=(((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3)) div 2;
+@z
+@x
+ if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
+ else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3
+@y
+ if b0<128 then tfm_check_sum:=((intcast(b0)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3)
+ else tfm_check_sum:=(((intcast(b0)-256)*256+intcast(b1))*256+intcast(b2))*256+intcast(b3)
+@z
+@x
+ if (b0*256+b1)>nw then goto 9997;
+ width[k]:=(b0*256+b1);
+@y
+ if (intcast(b0)*256+intcast(b1))>nw then goto 9997;
+ width[k]:=(intcast(b0)*256+intcast(b1));
+@z
+@x
+ if (b0*256+b1)>nw then goto 9997;
+ width[k]:=(b0*256+b1);
+ read_tfm_word; read_tfm_word;
+ kprime:=k+(b0*256+b1);
+@y
+ if (intcast(b0)*256+intcast(b1))>nw then goto 9997;
+ width[k]:=(intcast(b0)*256+intcast(b1));
+ read_tfm_word; read_tfm_word;
+ kprime:=k+(intcast(b0)*256+intcast(b1));
+@z
+
+@x [43] Initialize optional variables sooner.
+out_mode:=the_works; max_pages:=1000000; start_vals:=0; start_there[0]:=false;
+@y
+@ Initializations are done sooner now.
+@z
+
+@x [45] No dialog.
+@ The |input_ln| routine waits for the user to type a line at his or her
+terminal; then it puts ASCII-code equivalents for the characters on that line
+into the |buffer| array. The |term_in| file is used for terminal input,
+and |term_out| for terminal output.
+@^system dependencies@>
+
+@<Glob...@>=
+@!buffer:array[0..terminal_line_length] of ASCII_code;
+@!term_in:text_file; {the terminal, considered as an input file}
+@!term_out:text_file; {the terminal, considered as an output file}
+@y
+@ No dialog.
+@z
+
+@x [47] No input_ln.
+@p procedure input_ln; {inputs a line from the terminal}
+var k:0..terminal_line_length;
+begin update_terminal; reset(term_in);
+if eoln(term_in) then read_ln(term_in);
+k:=0;
+while (k<terminal_line_length)and not eoln(term_in) do
+ begin buffer[k]:=xord[term_in^]; incr(k); get(term_in);
+ end;
+buffer[k]:=" ";
+end;
+@y
+@z
+
+@x [48] No dialog.
+@ The global variable |buf_ptr| is used while scanning each line of input;
+it points to the first unread character in |buffer|.
+
+@<Glob...@>=
+@!buf_ptr:0..terminal_line_length; {the number of characters read}
+@y
+@ No dialog.
+@z
+
+@x [49] No dialog.
+@ Here is a routine that scans a (possibly signed) integer and computes
+the decimal value. If no decimal integer starts at |buf_ptr|, the
+value 0 is returned. The integer should be less than $2^{31}$ in
+absolute value.
+
+@p function get_integer:integer;
+var x:integer; {accumulates the value}
+@!negative:boolean; {should the value be negated?}
+begin if buffer[buf_ptr]="-" then
+ begin negative:=true; incr(buf_ptr);
+ end
+else negative:=false;
+x:=0;
+while (buffer[buf_ptr]>="0")and(buffer[buf_ptr]<="9") do
+ begin x:=10*x+buffer[buf_ptr]-"0"; incr(buf_ptr);
+ end;
+if negative then get_integer:=-x @+ else get_integer:=x;
+end;
+
+@y
+@ No dialog.
+@z
+
+@x [50-55] No dialog.
+@ The selected options are put into global variables by the |dialog|
+procedure, which is called just as \.{DVItype} begins.
+@^system dependencies@>
+
+@p procedure dialog;
+label 1,2,3,4,5;
+var k:integer; {loop variable}
+begin rewrite(term_out); {prepare the terminal for output}
+write_ln(term_out,banner);
+@<Determine the desired |out_mode|@>;
+@<Determine the desired |start_count| values@>;
+@<Determine the desired |max_pages|@>;
+@<Determine the desired |resolution|@>;
+@<Determine the desired |new_mag|@>;
+@<Print all the selected options@>;
+end;
+
+@ @<Determine the desired |out_mode|@>=
+1: write(term_out,'Output level (default=4, ? for help): ');
+out_mode:=the_works; input_ln;
+if buffer[0]<>" " then
+ if (buffer[0]>="0")and(buffer[0]<="4") then out_mode:=buffer[0]-"0"
+ else begin write(term_out,'Type 4 for complete listing,');
+ write(term_out,' 0 for errors only,');
+ write_ln(term_out,' 1 or 2 or 3 for something in between.');
+ goto 1;
+ end
+
+@ @<Determine the desired |start...@>=
+2: write(term_out,'Starting page (default=*): ');
+start_vals:=0; start_there[0]:=false;
+input_ln; buf_ptr:=0; k:=0;
+if buffer[0]<>" " then
+ repeat if buffer[buf_ptr]="*" then
+ begin start_there[k]:=false; incr(buf_ptr);
+ end
+ else begin start_there[k]:=true; start_count[k]:=get_integer;
+ end;
+ if (k<9)and(buffer[buf_ptr]=".") then
+ begin incr(k); incr(buf_ptr);
+ end
+ else if buffer[buf_ptr]=" " then start_vals:=k
+ else begin write(term_out,'Type, e.g., 1.*.-5 to specify the ');
+ write_ln(term_out,'first page with \count0=1, \count2=-5.');
+ goto 2;
+ end;
+ until start_vals=k
+
+@ @<Determine the desired |max_pages|@>=
+3: write(term_out,'Maximum number of pages (default=1000000): ');
+max_pages:=1000000; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ begin max_pages:=get_integer;
+ if max_pages<=0 then
+ begin write_ln(term_out,'Please type a positive number.');
+ goto 3;
+ end;
+ end
+
+@ @<Determine the desired |resolution|@>=
+4: write(term_out,'Assumed device resolution');
+write(term_out,' in pixels per inch (default=300/1): ');
+resolution:=300.0; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ begin k:=get_integer;
+ if (k>0)and(buffer[buf_ptr]="/")and
+ (buffer[buf_ptr+1]>"0")and(buffer[buf_ptr+1]<="9") then
+ begin incr(buf_ptr); resolution:=k/get_integer;
+ end
+ else begin write(term_out,'Type a ratio of positive integers;');
+ write_ln(term_out,' (1 pixel per mm would be 254/10).');
+ goto 4;
+ end;
+ end
+
+@ @<Determine the desired |new_mag|@>=
+5: write(term_out,'New magnification (default=0 to keep the old one): ');
+new_mag:=0; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ if (buffer[0]>="0")and(buffer[0]<="9") then new_mag:=get_integer
+ else begin write(term_out,'Type a positive integer to override ');
+ write_ln(term_out,'the magnification in the DVI file.');
+ goto 5;
+ end
+@y
+@ No dialog (50).
+@ No dialog (51).
+@ No dialog (52).
+@ No dialog (53).
+@ No dialog (54).
+@ No dialog (55).
+@z
+
+@x [56] Fix printing of floating point number.
+print_ln(' Resolution = ',resolution:12:8,' pixels per inch');
+if new_mag>0 then print_ln(' New magnification factor = ',new_mag/1000:8:3)
+@y
+print (' Resolution = ');
+print_real (resolution, 12, 8);
+print_ln (' pixels per inch');
+if new_mag > 0
+then begin
+ print (' New magnification factor = ');
+ print_real (new_mag / 1000.0, 8, 3);
+ print_ln('')
+end
+@z
+
+@x [59] We use r for something else.
+@!r:0..name_length; {index into |cur_name|}
+@y
+@!r:0..name_size; {current filename length}
+@z
+
+@x [62] <Load the new font...> close the file when we're done
+if out_mode=errors_only then print_ln(' ');
+@y
+if out_mode=errors_only then print_ln(' ');
+if tfm_file then
+ xfclose (tfm_file, cur_name); {should be the |kpse_find_tfm| result}
+free (cur_name); {We |xmalloc|'d this before we got called.}
+@z
+
+@x [64] Don't set default_directory_name.
+@d default_directory_name=='TeXfonts:' {change this to the correct name}
+@d default_directory_name_length=9 {change this to the correct length}
+
+@<Glob...@>=
+@!default_directory:packed array[1..default_directory_name_length] of char;
+@y
+Under Unix, users have a path searched for fonts, there's no single
+default directory.
+@z
+
+@x [65] Remove initialization of default_directory.
+@ @<Set init...@>=
+default_directory:=default_directory_name;
+@y
+@ (No initialization needs to be done. Keep this module to preserve
+numbering.)
+@z
+
+@x [66] Don't append `.tfm' here, and keep lowercase.
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{TFM} file for the current font. This usually means that we need to
+prepend the name of the default directory, and
+to append the suffix `\.{.TFM}'. Furthermore, we change lower case letters
+to upper case, since |cur_name| is a \PASCAL\ string.
+@^system dependencies@>
+
+@<Move font name into the |cur_name| string@>=
+for k:=1 to name_length do cur_name[k]:=' ';
+if p=0 then
+ begin for k:=1 to default_directory_name_length do
+ cur_name[k]:=default_directory[k];
+ r:=default_directory_name_length;
+ end
+else r:=0;
+for k:=font_name[nf] to font_name[nf+1]-1 do
+ begin incr(r);
+ if r+4>name_length then
+ abort('ODVItype capacity exceeded (max font name length=',
+ name_length:1,')!');
+@.ODVItype capacity exceeded...@>
+ if (names[k]>="a")and(names[k]<="z") then
+ cur_name[r]:=xchr[names[k]-@'40]
+ else cur_name[r]:=xchr[names[k]];
+ end;
+cur_name[r+1]:='.'; cur_name[r+2]:='T'; cur_name[r+3]:='F'; cur_name[r+4]:='M'
+@y
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{TFM} file for the current font. We do not impose a maximum limit
+here. It's too bad there is a limit on the total length of all
+filenames, but it doesn't seem worth reprogramming all that.
+@^system dependencies@>
+
+@d name_start == font_name[nf]
+@d name_end == font_name[nf+1]
+
+@<Move font name into the |cur_name| string@>=
+r := name_end - name_start;
+cur_name := xmalloc_array (char, r);
+{|strncpy| might be faster, but it's probably a good idea to keep the
+ |xchr| translation.}
+for k := name_start to name_end do begin
+ cur_name[k - name_start] := xchr[names[k]];
+end;
+cur_name[r] := 0; {Append null byte for C.}
+@z
+
+@x [80] (major,minor) optionally show opcode
+@d show(#)==begin flush_text; showing:=true; print(a:1,': ',#);
+ end
+@d major(#)==if out_mode>errors_only then show(#)
+@d minor(#)==if out_mode>terse then
+ begin showing:=true; print(a:1,': ',#);
+@y
+@d show(#)==begin flush_text; showing:=true; print(a:1,': ',#);
+ if show_opcodes and (o >= 128) then print (' {', o:1, '}');
+ end
+@d major(#)==if out_mode>errors_only then show(#)
+@d minor(#)==if out_mode>terse then
+ begin showing:=true; print(a:1,': ',#);
+ if show_opcodes and (o >= 128) then print (' {', o:1, '}');
+@z
+
+@x [106] (main) No dialog; remove unused label.
+dialog; {set up all the options}
+@y
+@<Print all the selected options@>;
+@z
+
+@x
+final_end:end.
+@y
+end.
+@z
+
+@x [109] Fix another floating point print.
+print_ln('magnification=',mag:1,'; ',conv:16:8,' pixels per DVI unit')
+@y
+print ('magnification=', mag:1, '; ');
+print_real (conv, 16, 8);
+print_ln (' pixels per DVI unit')
+@z
+
+@x [111] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{DVItype} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 8; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+ @!end_num:^char; {for \.{page-start}}
+begin
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('odvitype');
+
+ end else if argument_is ('help') then begin
+ usage_help (ODVITYPE_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end else if argument_is ('output-level') then begin
+ out_mode := atou (optarg);
+ if (out_mode = 0) or (out_mode > 4) then begin
+ write_ln (stderr, 'Value for --output-level must be >= 1 and <= 4.');
+ uexit (1);
+ end;
+
+ end else if argument_is ('page-start') then begin
+ @<Determine the desired |start_count| values from |optarg|@>;
+
+ end else if argument_is ('max-pages') then begin
+ max_pages := atou (optarg);
+
+ end else if argument_is ('dpi') then begin
+ resolution := atof (optarg);
+
+ end else if argument_is ('magnification') then begin
+ new_mag := atou (optarg);
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.}
+ if (optind + 1 <> argc) then begin
+ write_ln (stderr, 'odvitype: Need exactly one file argument.');
+ usage ('odvitype');
+ end;
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ How verbose to be.
+@.-output-level@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'output-level';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+out_mode := the_works; {default}
+
+@ What page to start at.
+@.-page-start@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'page-start';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Parsing the starting page specification is a bit complicated.
+
+@<Determine the desired |start_count|...@> =
+k := 0; {which \.{\\count} register we're on}
+m := 0; {position in |optarg|}
+while optarg[m] do begin
+ if optarg[m] = "*" then begin
+ start_there[k] := false;
+ incr (m);
+
+ end else if optarg[m] = "." then begin
+ incr (k);
+ if k >= 10 then begin
+ write_ln (stderr, 'odvitype: More than ten count registers specified.');
+ uexit (1);
+ end;
+ incr (m);
+
+ end else begin
+ start_count[k] := strtol (optarg + m, address_of (end_num), 10);
+ if end_num = optarg + m then begin
+ write_ln (stderr, 'odvitype: -page-start values must be numeric or *.');
+ uexit (1);
+ end;
+ start_there[k] := true;
+ m := m + end_num - (optarg + m);
+ end;
+end;
+start_vals := k;
+
+@ How many pages to do.
+@.-max-pages@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'max-pages';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+max_pages := 1000000; {default}
+
+@ Resolution, in pixels per inch.
+@.-dpi@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'dpi';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+resolution := 300.0; {default}
+
+@ Magnification to apply.
+@.-magnification@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'magnification';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+new_mag := 0; {default is to keep the old one}
+
+@ Whether to show numeric opcodes.
+@.-show-opcodes@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'show-opcodes';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := address_of (show_opcodes);
+long_options[current_option].val := 1;
+incr (current_option);
+new_mag := 0; {default is to keep the old one}
+
+@ @<Glob...@> =
+@!show_opcodes: c_int_type;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+@z
diff --git a/Build/source/texk/web2c/omegaware/odvitype.web b/Build/source/texk/web2c/omegaware/odvitype.web
new file mode 100644
index 00000000000..ef5136bb3f2
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/odvitype.web
@@ -0,0 +1,2594 @@
+% odvitype.web: Omega version of file dvitype.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original dvitype.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 1 was completed in September, 1982.
+% Slight changes were made in October, 1982, for version 0.7 of TeX.
+% Version 1.1 corrected minor bugs (May, 1983).
+% Version 2 was released with version 0.999 of TeX (July, 1983).
+% Version 2.1 corrected a bug when no fonts are present (September, 1983).
+% Version 2.2 corrected bugs in max_*_so_far and put1 (October, 1983).
+% Version 2.3 corrected spacing of accents (March, 1984).
+% Version 2.4 fixed rounding, changed oriental font conventions (April, 1984).
+% Version 2.5 improved the case of zero pages (May, 1984).
+% Version 2.6 introduced max_drift (June, 1984).
+% Version 2.7 had minor editorial changes (August, 1984).
+% Version 2.8 made default resolution 300/1 (April, 1985).
+% Version 2.9 changed negative scaling as in TeX version 2.7 (November, 1987).
+% Version 3 introduced an intermediate level of verbosity (October,1989).
+% Version 3.1 gave magnification info in final font list (November, 1989).
+% Version 3.2 doublechecked design size of each font (January, 1990).
+% Version 3.3 had more robust for loops in print_font, define_font (May, 1990).
+% Version 3.4 more robustness in presence of bad fonts (September, 1990).
+% Version 3.5 checked skipped material more strictly (March, 1995).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{ODVI$\,$\lowercase{type}}
+\def\contentspagenumber{401}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont ODVItype} processor}
+ \vskip 15pt
+ \centerline{(Version 1.5, March 1997)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ The preparation of this report
+ was supported in part by the National Science
+ Foundation under grants IST-8201926 and MCS-8300984,
+ and by the System Development Foundation. `\TeX' is a
+ trademark of the American Mathematical Society.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{DVItype} utility program reads binary device-independent (``\.{DVI}'')
+files that are produced by document compilers such as \TeX, and converts them
+into symbolic form. This program has two chief purposes: (1)~It can be used to
+determine whether a \.{DVI} file is valid or invalid, when diagnosing
+compiler errors; and (2)~it serves as an example of a program that reads
+\.{DVI} files correctly, for system programmers who are developing
+\.{DVI}-related software.
+
+Goal number (2) needs perhaps a bit more explanation. Programs for
+typesetting need to be especially careful about how they do arithmetic; if
+rounding errors accumulate, margins won't be straight, vertical rules
+won't line up, and so on. But if rounding is done everywhere, even in the
+midst of words, there will be uneven spacing between the letters, and that
+looks bad. Human eyes notice differences of a thousandth of an inch in the
+positioning of lines that are close together; on low resolution devices,
+where rounding produces effects four times as great as this, the problem
+is especially critical. Experience has shown that unusual care is needed
+even on high-resolution equipment; for example, a mistake in the sixth
+significant hexadecimal place of a constant once led to a difficult-to-find
+bug in some software for the Alphatype CRS, which has a resolution of 5333
+pixels per inch (make that 5333.33333333 pixels per inch). The document
+compilers that generate \.{DVI} files make certain assumptions about the
+arithmetic that will be used by \.{DVI}-reading software, and if these
+assumptions are violated the results will be of inferior quality.
+Therefore the present program is intended as a guide to proper procedure
+in the critical places where a bit of subtlety is involved.
+
+The first \.{DVItype} program was designed by David Fuchs in 1979, and it
+@^Fuchs, David Raymond@>
+went through several versions on different computers as the format of
+\.{DVI} files was evolving to its present form. Peter Breitenlohner
+helped with the latest revisions.
+@^Breitenlohner, Peter@>
+
+The |banner| string defined here should be changed whenever \.{DVItype}
+gets modified.
+
+@d banner=='This is ODVItype, Version 1.5' {printed when the program starts}
+
+@ This program is written in standard \PASCAL, except where it is necessary
+to use extensions; for example, \.{DVItype} must read files whose names
+are dynamically specified, and that would be impossible in pure \PASCAL.
+All places where nonstandard constructions are used have been listed in
+the index under ``system dependencies.''
+@!@^system dependencies@>
+
+One of the extensions to standard \PASCAL\ that we shall deal with is the
+ability to move to a random place in a binary file; another is to
+determine the length of a binary file. Such extensions are not necessary
+for reading \.{DVI} files, and they are not important for efficiency
+reasons either---an infrequently used program like \.{DVItype} does not
+have to be efficient. But they are included there because of \.{DVItype}'s
+r\^^Dole as a model of a \.{DVI} reading routine, since other \.{DVI}
+processors ought to be highly efficient. If \.{DVItype} is being used with
+\PASCAL s for which random file positioning is not efficiently available,
+the following definition should be changed from |true| to |false|; in such
+cases, \.{DVItype} will not include the optional feature that reads the
+postamble first.
+
+Another extension is to use a default |case| as in \.{TANGLE}, \.{WEAVE},
+etc.
+
+@d random_reading==true {should we skip around in the file?}
+@d othercases == others: {default for cases not listed explicitly}
+@d endcases == @+end {follows the default case in an extended |case| statement}
+@f othercases == else
+@f endcases == end
+
+@ The binary input comes from |dvi_file|, and the symbolic output is written
+on \PASCAL's standard |output| file. The term |print| is used instead of
+|write| when this program writes on |output|, so that all such output
+could easily be redirected if desired.
+
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+
+@p program DVI_type(@!dvi_file,@!output);
+label @<Labels in the outer block@>@/
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+procedure initialize; {this procedure gets things started properly}
+ var i:integer; {loop index for initializations}
+ begin print_ln(banner);@/
+ @<Set initial values@>@/
+ end;
+
+@ If the program has to stop prematurely, it goes to the
+`|final_end|'. Another label, |done|, is used when stopping normally.
+
+@d final_end=9999 {label for the end of it all}
+@d done=30 {go here when finished with a subtask}
+
+@<Labels...@>=final_end,done;
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{DVItype}'s capacity.
+
+@<Constants...@>=
+@!max_fonts=100; {maximum number of distinct fonts per \.{DVI} file}
+@!max_widths=100000; {maximum number of different characters among all fonts}
+@!line_length=79; {bracketed lines of output will be at most this long}
+@!terminal_line_length=150; {maximum number of characters input in a single
+ line of input from the terminal}
+@!stack_size=100; {\.{DVI} files shouldn't |push| beyond this depth}
+@!name_size=1000; {total length of all font file names}
+@!name_length=50; {a file name shouldn't be longer than this}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d do_nothing == {empty statement}
+
+@ If the \.{DVI} file is badly malformed, the whole process must be aborted;
+\.{DVItype} will give up, after issuing an error message about the symptoms
+that were noticed.
+
+Such errors might be discovered inside of subroutines inside of subroutines,
+so a procedure called |jump_out| has been introduced. This procedure, which
+simply transfers control to the label |final_end| at the end of the program,
+contains the only non-local |goto| statement in \.{DVItype}.
+@^system dependencies@>
+
+@d abort(#)==begin print(' ',#); jump_out;
+ end
+@d bad_dvi(#)==abort('Bad DVI file: ',#,'!')
+@.Bad DVI file@>
+
+@p procedure jump_out;
+begin goto final_end;
+end;
+
+@* The character set.
+Like all programs written with the \.{WEB} system, \.{DVItype} can be
+used with any character set. But it uses ASCII code internally, because
+the programming for portable input-output is easier when a fixed internal
+code is used, and because \.{DVI} files use ASCII code for file names
+and certain other strings.
+
+The next few sections of \.{DVItype} have therefore been copied from the
+analogous ones in the \.{WEB} system routines. They have been considerably
+simplified, since \.{DVItype} need not deal with the controversial
+ASCII codes less than @'40 or greater than @'176.
+If such codes appear in the \.{DVI} file,
+they will be printed as question marks.
+
+@<Types...@>=
+@!ASCII_code=" ".."~"; {a subrange of the integers}
+
+@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
+character sets were common, so it did not make provision for lower case
+letters. Nowadays, of course, we need to deal with both upper and lower case
+alphabets in a convenient way, especially in a program like \.{DVItype}.
+So we shall assume that the \PASCAL\ system being used for \.{DVItype}
+has a character set containing at least the standard visible characters
+of ASCII code (|"!"| through |"~"|).
+
+Some \PASCAL\ compilers use the original name |char| for the data type
+associated with the characters in text files, while other \PASCAL s
+consider |char| to be a 64-element subrange of a larger data type that has
+some other name. In order to accommodate this difference, we shall use
+the name |text_char| to stand for the data type of the characters in the
+output file. We shall also assume that |text_char| consists of
+the elements |chr(first_text_char)| through |chr(last_text_char)|,
+inclusive. The following definitions should be adjusted if necessary.
+@^system dependencies@>
+
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=127 {ordinal number of the largest element of |text_char|}
+
+@<Types...@>=
+@!text_file=packed file of text_char;
+
+@ The \.{DVItype} processor converts between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to \PASCAL's |ord| and |chr| functions.
+
+@<Globals...@>=
+@!xord: array [text_char] of ASCII_code;
+ {specifies conversion of input characters}
+@!xchr: array [0..255] of text_char;
+ {specifies conversion of output characters}
+
+@ Under our assumption that the visible characters of standard ASCII are
+all present, the following assignment statements initialize the
+|xchr| array properly, without needing any system-dependent changes.
+
+@<Set init...@>=
+for i:=0 to @'37 do xchr[i]:='?';
+xchr[@'40]:=' ';
+xchr[@'41]:='!';
+xchr[@'42]:='"';
+xchr[@'43]:='#';
+xchr[@'44]:='$';
+xchr[@'45]:='%';
+xchr[@'46]:='&';
+xchr[@'47]:='''';@/
+xchr[@'50]:='(';
+xchr[@'51]:=')';
+xchr[@'52]:='*';
+xchr[@'53]:='+';
+xchr[@'54]:=',';
+xchr[@'55]:='-';
+xchr[@'56]:='.';
+xchr[@'57]:='/';@/
+xchr[@'60]:='0';
+xchr[@'61]:='1';
+xchr[@'62]:='2';
+xchr[@'63]:='3';
+xchr[@'64]:='4';
+xchr[@'65]:='5';
+xchr[@'66]:='6';
+xchr[@'67]:='7';@/
+xchr[@'70]:='8';
+xchr[@'71]:='9';
+xchr[@'72]:=':';
+xchr[@'73]:=';';
+xchr[@'74]:='<';
+xchr[@'75]:='=';
+xchr[@'76]:='>';
+xchr[@'77]:='?';@/
+xchr[@'100]:='@@';
+xchr[@'101]:='A';
+xchr[@'102]:='B';
+xchr[@'103]:='C';
+xchr[@'104]:='D';
+xchr[@'105]:='E';
+xchr[@'106]:='F';
+xchr[@'107]:='G';@/
+xchr[@'110]:='H';
+xchr[@'111]:='I';
+xchr[@'112]:='J';
+xchr[@'113]:='K';
+xchr[@'114]:='L';
+xchr[@'115]:='M';
+xchr[@'116]:='N';
+xchr[@'117]:='O';@/
+xchr[@'120]:='P';
+xchr[@'121]:='Q';
+xchr[@'122]:='R';
+xchr[@'123]:='S';
+xchr[@'124]:='T';
+xchr[@'125]:='U';
+xchr[@'126]:='V';
+xchr[@'127]:='W';@/
+xchr[@'130]:='X';
+xchr[@'131]:='Y';
+xchr[@'132]:='Z';
+xchr[@'133]:='[';
+xchr[@'134]:='\';
+xchr[@'135]:=']';
+xchr[@'136]:='^';
+xchr[@'137]:='_';@/
+xchr[@'140]:='`';
+xchr[@'141]:='a';
+xchr[@'142]:='b';
+xchr[@'143]:='c';
+xchr[@'144]:='d';
+xchr[@'145]:='e';
+xchr[@'146]:='f';
+xchr[@'147]:='g';@/
+xchr[@'150]:='h';
+xchr[@'151]:='i';
+xchr[@'152]:='j';
+xchr[@'153]:='k';
+xchr[@'154]:='l';
+xchr[@'155]:='m';
+xchr[@'156]:='n';
+xchr[@'157]:='o';@/
+xchr[@'160]:='p';
+xchr[@'161]:='q';
+xchr[@'162]:='r';
+xchr[@'163]:='s';
+xchr[@'164]:='t';
+xchr[@'165]:='u';
+xchr[@'166]:='v';
+xchr[@'167]:='w';@/
+xchr[@'170]:='x';
+xchr[@'171]:='y';
+xchr[@'172]:='z';
+xchr[@'173]:='{';
+xchr[@'174]:='|';
+xchr[@'175]:='}';
+xchr[@'176]:='~';
+for i:=@'177 to 255 do xchr[i]:='?';
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|.
+
+@<Set init...@>=
+for i:=first_text_char to last_text_char do xord[chr(i)]:=@'40;
+for i:=" " to "~" do xord[xchr[i]]:=i;
+
+@* Device-independent file format.
+Before we get into the details of \.{DVItype}, we need to know exactly
+what \.{DVI} files are. The form of such files was designed by David R.
+@^Fuchs, David Raymond@>
+Fuchs in 1979. Almost any reasonable typesetting device can be driven by
+a program that takes \.{DVI} files as input, and dozens of such
+\.{DVI}-to-whatever programs have been written. Thus, it is possible to
+print the output of document compilers like \TeX\ on many different kinds
+of equipment.
+
+A \.{DVI} file is a stream of 8-bit bytes, which may be regarded as a
+series of commands in a machine-like language. The first byte of each command
+is the operation code, and this code is followed by zero or more bytes
+that provide parameters to the command. The parameters themselves may consist
+of several consecutive bytes; for example, the `|set_rule|' command has two
+parameters, each of which is four bytes long. Parameters are usually
+regarded as nonnegative integers; but four-byte-long parameters,
+and shorter parameters that denote distances, can be
+either positive or negative. Such parameters are given in two's complement
+notation. For example, a two-byte-long distance parameter has a value between
+$-2^{15}$ and $2^{15}-1$.
+@.DVI {\rm files}@>
+
+A \.{DVI} file consists of a ``preamble,'' followed by a sequence of one
+or more ``pages,'' followed by a ``postamble.'' The preamble is simply a
+|pre| command, with its parameters that define the dimensions used in the
+file; this must come first. Each ``page'' consists of a |bop| command,
+followed by any number of other commands that tell where characters are to
+be placed on a physical page, followed by an |eop| command. The pages
+appear in the order that they were generated, not in any particular
+numerical order. If we ignore |nop| commands and \\{fnt\_def} commands
+(which are allowed between any two commands in the file), each |eop|
+command is immediately followed by a |bop| command, or by a |post|
+command; in the latter case, there are no more pages in the file, and the
+remaining bytes form the postamble. Further details about the postamble
+will be explained later.
+
+Some parameters in \.{DVI} commands are ``pointers.'' These are four-byte
+quantities that give the location number of some other byte in the file;
+the first byte is number~0, then comes number~1, and so on. For example,
+one of the parameters of a |bop| command points to the previous |bop|;
+this makes it feasible to read the pages in backwards order, in case the
+results are being directed to a device that stacks its output face up.
+Suppose the preamble of a \.{DVI} file occupies bytes 0 to 99. Now if the
+first page occupies bytes 100 to 999, say, and if the second
+page occupies bytes 1000 to 1999, then the |bop| that starts in byte 1000
+points to 100 and the |bop| that starts in byte 2000 points to 1000. (The
+very first |bop|, i.e., the one that starts in byte 100, has a pointer of $-1$.)
+
+@ The \.{DVI} format is intended to be both compact and easily interpreted
+by a machine. Compactness is achieved by making most of the information
+implicit instead of explicit. When a \.{DVI}-reading program reads the
+commands for a page, it keeps track of several quantities: (a)~The current
+font |f| is an integer; this value is changed only
+by \\{fnt} and \\{fnt\_num} commands. (b)~The current position on the page
+is given by two numbers called the horizontal and vertical coordinates,
+|h| and |v|. Both coordinates are zero at the upper left corner of the page;
+moving to the right corresponds to increasing the horizontal coordinate, and
+moving down corresponds to increasing the vertical coordinate. Thus, the
+coordinates are essentially Cartesian, except that vertical directions are
+flipped; the Cartesian version of |(h,v)| would be |(h,-v)|. (c)~The
+current spacing amounts are given by four numbers |w|, |x|, |y|, and |z|,
+where |w| and~|x| are used for horizontal spacing and where |y| and~|z|
+are used for vertical spacing. (d)~There is a stack containing
+|(h,v,w,x,y,z)| values; the \.{DVI} commands |push| and |pop| are used to
+change the current level of operation. Note that the current font~|f| is
+not pushed and popped; the stack contains only information about
+positioning.
+
+The values of |h|, |v|, |w|, |x|, |y|, and |z| are signed integers having up
+to 32 bits, including the sign. Since they represent physical distances,
+there is a small unit of measurement such that increasing |h| by~1 means
+moving a certain tiny distance to the right. The actual unit of
+measurement is variable, as explained below.
+
+@ Here is a list of all the commands that may appear in a \.{DVI} file. Each
+command is specified by its symbolic name (e.g., |bop|), its opcode byte
+(e.g., 139), and its parameters (if any). The parameters are followed
+by a bracketed number telling how many bytes they occupy; for example,
+`|p[4]|' means that parameter |p| is four bytes long.
+
+\yskip\hang|set_char_0| 0. Typeset character number~0 from font~|f|
+such that the reference point of the character is at |(h,v)|. Then
+increase |h| by the width of that character. Note that a character may
+have zero or negative width, so one cannot be sure that |h| will advance
+after this command; but |h| usually does increase.
+
+\yskip\hang|set_char_1| through |set_char_127| (opcodes 1 to 127).
+Do the operations of |set_char_0|; but use the character whose number
+matches the opcode, instead of character~0.
+
+\yskip\hang|set1| 128 |c[1]|. Same as |set_char_0|, except that character
+number~|c| is typeset. \TeX82 uses this command for characters in the
+range |128<=c<256|.
+
+\yskip\hang|set2| 129 |c[2]|. Same as |set1|, except that |c|~is two
+bytes long, so it is in the range |0<=c<65536|. \TeX82 never uses this
+command, which is intended for processors that deal with oriental languages;
+but \.{DVItype} will allow character codes greater than 255, assuming that
+they all have the same width as the character whose code is $c \bmod 256$.
+@^oriental characters@>@^Chinese characters@>@^Japanese characters@>
+
+\yskip\hang|set3| 130 |c[3]|. Same as |set1|, except that |c|~is three
+bytes long, so it can be as large as $2^{24}-1$.
+
+\yskip\hang|set4| 131 |c[4]|. Same as |set1|, except that |c|~is four
+bytes long, possibly even negative. Imagine that.
+
+\yskip\hang|set_rule| 132 |a[4]| |b[4]|. Typeset a solid black rectangle
+of height |a| and width |b|, with its bottom left corner at |(h,v)|. Then
+set |h:=h+b|. If either |a<=0| or |b<=0|, nothing should be typeset. Note
+that if |b<0|, the value of |h| will decrease even though nothing else happens.
+Programs that typeset from \.{DVI} files should be careful to make the rules
+line up carefully with digitized characters, as explained in connection with
+the |rule_pixels| subroutine below.
+
+\yskip\hang|put1| 133 |c[1]|. Typeset character number~|c| from font~|f|
+such that the reference point of the character is at |(h,v)|. (The `put'
+commands are exactly like the `set' commands, except that they simply put out a
+character or a rule without moving the reference point afterwards.)
+
+\yskip\hang|put2| 134 |c[2]|. Same as |set2|, except that |h| is not changed.
+
+\yskip\hang|put3| 135 |c[3]|. Same as |set3|, except that |h| is not changed.
+
+\yskip\hang|put4| 136 |c[4]|. Same as |set4|, except that |h| is not changed.
+
+\yskip\hang|put_rule| 137 |a[4]| |b[4]|. Same as |set_rule|, except that
+|h| is not changed.
+
+\yskip\hang|nop| 138. No operation, do nothing. Any number of |nop|'s
+may occur between \.{DVI} commands, but a |nop| cannot be inserted between
+a command and its parameters or between two parameters.
+
+\yskip\hang|bop| 139 $c_0[4]$ $c_1[4]$ $\ldots$ $c_9[4]$ $p[4]$. Beginning
+of a page: Set |(h,v,w,x,y,z):=(0,0,0,0,0,0)| and set the stack empty. Set
+the current font |f| to an undefined value. The ten $c_i$ parameters can
+be used to identify pages, if a user wants to print only part of a \.{DVI}
+file; \TeX82 gives them the values of \.{\\count0} $\ldots$ \.{\\count9}
+at the time \.{\\shipout} was invoked for this page. The parameter |p|
+points to the previous |bop| command in the file, where the first |bop|
+has $p=-1$.
+
+\yskip\hang|eop| 140. End of page: Print what you have read since the
+previous |bop|. At this point the stack should be empty. (The \.{DVI}-reading
+programs that drive most output devices will have kept a buffer of the
+material that appears on the page that has just ended. This material is
+largely, but not entirely, in order by |v| coordinate and (for fixed |v|) by
+|h|~coordinate; so it usually needs to be sorted into some order that is
+appropriate for the device in question. \.{DVItype} does not do such sorting.)
+
+\yskip\hang|push| 141. Push the current values of |(h,v,w,x,y,z)| onto the
+top of the stack; do not change any of these values. Note that |f| is
+not pushed.
+
+\yskip\hang|pop| 142. Pop the top six values off of the stack and assign
+them to |(h,v,w,x,y,z)|. The number of pops should never exceed the number
+of pushes, since it would be highly embarrassing if the stack were empty
+at the time of a |pop| command.
+
+\yskip\hang|right1| 143 |b[1]|. Set |h:=h+b|, i.e., move right |b| units.
+The parameter is a signed number in two's complement notation, |-128<=b<128|;
+if |b<0|, the reference point actually moves left.
+
+\yskip\hang|right2| 144 |b[2]|. Same as |right1|, except that |b| is a
+two-byte quantity in the range |-32768<=b<32768|.
+
+\yskip\hang|right3| 145 |b[3]|. Same as |right1|, except that |b| is a
+three-byte quantity in the range |@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|right4| 146 |b[4]|. Same as |right1|, except that |b| is a
+four-byte quantity in the range |@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|w0| 147. Set |h:=h+w|; i.e., move right |w| units. With luck,
+this parameterless command will usually suffice, because the same kind of motion
+will occur several times in succession; the following commands explain how
+|w| gets particular values.
+
+\yskip\hang|w1| 148 |b[1]|. Set |w:=b| and |h:=h+b|. The value of |b| is a
+signed quantity in two's complement notation, |-128<=b<128|. This command
+changes the current |w|~spacing and moves right by |b|.
+
+\yskip\hang|w2| 149 |b[2]|. Same as |w1|, but |b| is a two-byte-long
+parameter, |-32768<=b<32768|.
+
+\yskip\hang|w3| 150 |b[3]|. Same as |w1|, but |b| is a three-byte-long
+parameter, |@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|w4| 151 |b[4]|. Same as |w1|, but |b| is a four-byte-long
+parameter, |@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|x0| 152. Set |h:=h+x|; i.e., move right |x| units. The `|x|'
+commands are like the `|w|' commands except that they involve |x| instead
+of |w|.
+
+\yskip\hang|x1| 153 |b[1]|. Set |x:=b| and |h:=h+b|. The value of |b| is a
+signed quantity in two's complement notation, |-128<=b<128|. This command
+changes the current |x|~spacing and moves right by |b|.
+
+\yskip\hang|x2| 154 |b[2]|. Same as |x1|, but |b| is a two-byte-long
+parameter, |-32768<=b<32768|.
+
+\yskip\hang|x3| 155 |b[3]|. Same as |x1|, but |b| is a three-byte-long
+parameter, |@t$-2^{23}$@><=b<@t$2^{23}$@>|.
+
+\yskip\hang|x4| 156 |b[4]|. Same as |x1|, but |b| is a four-byte-long
+parameter, |@t$-2^{31}$@><=b<@t$2^{31}$@>|.
+
+\yskip\hang|down1| 157 |a[1]|. Set |v:=v+a|, i.e., move down |a| units.
+The parameter is a signed number in two's complement notation, |-128<=a<128|;
+if |a<0|, the reference point actually moves up.
+
+\yskip\hang|down2| 158 |a[2]|. Same as |down1|, except that |a| is a
+two-byte quantity in the range |-32768<=a<32768|.
+
+\yskip\hang|down3| 159 |a[3]|. Same as |down1|, except that |a| is a
+three-byte quantity in the range |@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|down4| 160 |a[4]|. Same as |down1|, except that |a| is a
+four-byte quantity in the range |@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|y0| 161. Set |v:=v+y|; i.e., move down |y| units. With luck,
+this parameterless command will usually suffice, because the same kind of motion
+will occur several times in succession; the following commands explain how
+|y| gets particular values.
+
+\yskip\hang|y1| 162 |a[1]|. Set |y:=a| and |v:=v+a|. The value of |a| is a
+signed quantity in two's complement notation, |-128<=a<128|. This command
+changes the current |y|~spacing and moves down by |a|.
+
+\yskip\hang|y2| 163 |a[2]|. Same as |y1|, but |a| is a two-byte-long
+parameter, |-32768<=a<32768|.
+
+\yskip\hang|y3| 164 |a[3]|. Same as |y1|, but |a| is a three-byte-long
+parameter, |@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|y4| 165 |a[4]|. Same as |y1|, but |a| is a four-byte-long
+parameter, |@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|z0| 166. Set |v:=v+z|; i.e., move down |z| units. The `|z|' commands
+are like the `|y|' commands except that they involve |z| instead of |y|.
+
+\yskip\hang|z1| 167 |a[1]|. Set |z:=a| and |v:=v+a|. The value of |a| is a
+signed quantity in two's complement notation, |-128<=a<128|. This command
+changes the current |z|~spacing and moves down by |a|.
+
+\yskip\hang|z2| 168 |a[2]|. Same as |z1|, but |a| is a two-byte-long
+parameter, |-32768<=a<32768|.
+
+\yskip\hang|z3| 169 |a[3]|. Same as |z1|, but |a| is a three-byte-long
+parameter, |@t$-2^{23}$@><=a<@t$2^{23}$@>|.
+
+\yskip\hang|z4| 170 |a[4]|. Same as |z1|, but |a| is a four-byte-long
+parameter, |@t$-2^{31}$@><=a<@t$2^{31}$@>|.
+
+\yskip\hang|fnt_num_0| 171. Set |f:=0|. Font 0 must previously have been
+defined by a \\{fnt\_def} instruction, as explained below.
+
+\yskip\hang|fnt_num_1| through |fnt_num_63| (opcodes 172 to 234). Set
+|f:=1|, \dots, |f:=63|, respectively.
+
+\yskip\hang|fnt1| 235 |k[1]|. Set |f:=k|. \TeX82 uses this command for font
+numbers in the range |64<=k<256|.
+
+\yskip\hang|fnt2| 236 |k[2]|. Same as |fnt1|, except that |k|~is two
+bytes long, so it is in the range |0<=k<65536|. \TeX82 never generates this
+command, but large font numbers may prove useful for specifications of
+color or texture, or they may be used for special fonts that have fixed
+numbers in some external coding scheme.
+
+\yskip\hang|fnt3| 237 |k[3]|. Same as |fnt1|, except that |k|~is three
+bytes long, so it can be as large as $2^{24}-1$.
+
+\yskip\hang|fnt4| 238 |k[4]|. Same as |fnt1|, except that |k|~is four
+bytes long; this is for the really big font numbers (and for the negative ones).
+
+\yskip\hang|xxx1| 239 |k[1]| |x[k]|. This command is undefined in
+general; it functions as a $(k+2)$-byte |nop| unless special \.{DVI}-reading
+programs are being used. \TeX82 generates |xxx1| when a short enough
+\.{\\special} appears, setting |k| to the number of bytes being sent. It
+is recommended that |x| be a string having the form of a keyword followed
+by possible parameters relevant to that keyword.
+
+\yskip\hang|xxx2| 240 |k[2]| |x[k]|. Like |xxx1|, but |0<=k<65536|.
+
+\yskip\hang|xxx3| 241 |k[3]| |x[k]|. Like |xxx1|, but |0<=k<@t$2^{24}$@>|.
+
+\yskip\hang|xxx4| 242 |k[4]| |x[k]|. Like |xxx1|, but |k| can be ridiculously
+large. \TeX82 uses |xxx4| when |xxx1| would be incorrect.
+
+\yskip\hang|fnt_def1| 243 |k[1]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<256|; font definitions will be explained shortly.
+
+\yskip\hang|fnt_def2| 244 |k[2]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<65536|.
+
+\yskip\hang|fnt_def3| 245 |k[3]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<@t$2^{24}$@>|.
+
+\yskip\hang|fnt_def4| 246 |k[4]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |@t$-2^{31}$@><=k<@t$2^{31}$@>|.
+
+\yskip\hang|pre| 247 |i[1]| |num[4]| |den[4]| |mag[4]| |k[1]| |x[k]|.
+Beginning of the preamble; this must come at the very beginning of the
+file. Parameters |i|, |num|, |den|, |mag|, |k|, and |x| are explained below.
+
+\yskip\hang|post| 248. Beginning of the postamble, see below.
+
+\yskip\hang|post_post| 249. Ending of the postamble, see below.
+
+\yskip\noindent Commands 250--255 are undefined at the present time.
+
+@ @d set_char_0=0 {typeset character 0 and move right}
+@d set1=128 {typeset a character and move right}
+@d set_rule=132 {typeset a rule and move right}
+@d put1=133 {typeset a character}
+@d put_rule=137 {typeset a rule}
+@d nop=138 {no operation}
+@d bop=139 {beginning of page}
+@d eop=140 {ending of page}
+@d push=141 {save the current positions}
+@d pop=142 {restore previous positions}
+@d right1=143 {move right}
+@d w0=147 {move right by |w|}
+@d w1=148 {move right and set |w|}
+@d x0=152 {move right by |x|}
+@d x1=153 {move right and set |x|}
+@d down1=157 {move down}
+@d y0=161 {move down by |y|}
+@d y1=162 {move down and set |y|}
+@d z0=166 {move down by |z|}
+@d z1=167 {move down and set |z|}
+@d fnt_num_0=171 {set current font to 0}
+@d fnt1=235 {set current font}
+@d xxx1=239 {extension to \.{DVI} primitives}
+@d xxx4=242 {potentially long extension to \.{DVI} primitives}
+@d fnt_def1=243 {define the meaning of a font number}
+@d pre=247 {preamble}
+@d post=248 {postamble beginning}
+@d post_post=249 {postamble ending}
+@d undefined_commands==250,251,252,253,254,255
+
+@ The preamble contains basic information about the file as a whole. As
+stated above, there are six parameters:
+$$\hbox{|@!i[1]| |@!num[4]| |@!den[4]| |@!mag[4]| |@!k[1]| |@!x[k]|.}$$
+The |i| byte identifies \.{DVI} format; currently this byte is always set
+to~2. (The value |i=3| is currently used for an extended format that
+allows a mixture of right-to-left and left-to-right typesetting.
+Some day we will set |i=4|, when \.{DVI} format makes another
+incompatible change---perhaps in the year 2048.)
+
+The next two parameters, |num| and |den|, are positive integers that define
+the units of measurement; they are the numerator and denominator of a
+fraction by which all dimensions in the \.{DVI} file could be multiplied
+in order to get lengths in units of $10^{-7}$ meters. (For example, there are
+exactly 7227 \TeX\ points in 254 centimeters, and \TeX82 works with scaled
+points where there are $2^{16}$ sp in a point, so \TeX82 sets |num=25400000|
+and $|den|=7227\cdot2^{16}=473628672$.)
+@^sp@>
+
+The |mag| parameter is what \TeX82 calls \.{\\mag}, i.e., 1000 times the
+desired magnification. The actual fraction by which dimensions are
+multiplied is therefore $mn/1000d$. Note that if a \TeX\ source document
+does not call for any `\.{true}' dimensions, and if you change it only by
+specifying a different \.{\\mag} setting, the \.{DVI} file that \TeX\
+creates will be completely unchanged except for the value of |mag| in the
+preamble and postamble. (Fancy \.{DVI}-reading programs allow users to
+override the |mag|~setting when a \.{DVI} file is being printed.)
+
+Finally, |k| and |x| allow the \.{DVI} writer to include a comment, which is not
+interpreted further. The length of comment |x| is |k|, where |0<=k<256|.
+
+@d id_byte=2 {identifies the kind of \.{DVI} files described here}
+
+@ Font definitions for a given font number |k| contain further parameters
+$$\hbox{|c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.}$$
+The four-byte value |c| is the check sum that \TeX\ (or whatever program
+generated the \.{DVI} file) found in the \.{TFM} file for this font;
+|c| should match the check sum of the font found by programs that read
+this \.{DVI} file.
+@^check sum@>
+
+Parameter |s| contains a fixed-point scale factor that is applied to the
+character widths in font |k|; font dimensions in \.{TFM} files and other
+font files are relative to this quantity, which is always positive and
+less than $2^{27}$. It is given in the same units as the other dimensions
+of the \.{DVI} file. Parameter |d| is similar to |s|; it is the ``design
+size,'' and (like~|s|) it is given in \.{DVI} units. Thus, font |k| is to be
+used at $|mag|\cdot s/1000d$ times its normal size.
+
+The remaining part of a font definition gives the external name of the font,
+which is an ASCII string of length |a+l|. The number |a| is the length
+of the ``area'' or directory, and |l| is the length of the font name itself;
+the standard local system font area is supposed to be used when |a=0|.
+The |n| field contains the area in its first |a| bytes.
+
+Font definitions must appear before the first use of a particular font number.
+Once font |k| is defined, it must not be defined again; however, we
+shall see below that font definitions appear in the postamble as well as
+in the pages, so in this sense each font number is defined exactly twice,
+if at all. Like |nop| commands, font definitions can
+appear before the first |bop|, or between an |eop| and a |bop|.
+
+@ The last page in a \.{DVI} file is followed by `|post|'; this command
+introduces the postamble, which summarizes important facts that \TeX\ has
+accumulated about the file, making it possible to print subsets of the data
+with reasonable efficiency. The postamble has the form
+$$\vbox{\halign{\hbox{#\hfil}\cr
+ |post| |p[4]| |num[4]| |den[4]| |mag[4]| |l[4]| |u[4]| |s[2]| |t[2]|\cr
+ $\langle\,$font definitions$\,\rangle$\cr
+ |post_post| |q[4]| |i[1]| 223's$[{\G}4]$\cr}}$$
+Here |p| is a pointer to the final |bop| in the file. The next three
+parameters, |num|, |den|, and |mag|, are duplicates of the quantities that
+appeared in the preamble.
+
+Parameters |l| and |u| give respectively the height-plus-depth of the tallest
+page and the width of the widest page, in the same units as other dimensions
+of the file. These numbers might be used by a \.{DVI}-reading program to
+position individual ``pages'' on large sheets of film or paper; however,
+the standard convention for output on normal size paper is to position each
+page so that the upper left-hand corner is exactly one inch from the left
+and the top. Experience has shown that it is unwise to design \.{DVI}-to-printer
+software that attempts cleverly to center the output; a fixed position of
+the upper left corner is easiest for users to understand and to work with.
+Therefore |l| and~|u| are often ignored.
+
+Parameter |s| is the maximum stack depth (i.e., the largest excess of
+|push| commands over |pop| commands) needed to process this file. Then
+comes |t|, the total number of pages (|bop| commands) present.
+
+The postamble continues with font definitions, which are any number of
+\\{fnt\_def} commands as described above, possibly interspersed with |nop|
+commands. Each font number that is used in the \.{DVI} file must be defined
+exactly twice: Once before it is first selected by a \\{fnt} command, and once
+in the postamble.
+
+@ The last part of the postamble, following the |post_post| byte that
+signifies the end of the font definitions, contains |q|, a pointer to the
+|post| command that started the postamble. An identification byte, |i|,
+comes next; this currently equals~2, as in the preamble.
+
+The |i| byte is followed by four or more bytes that are all equal to
+the decimal number 223 (i.e., @'337 in octal). \TeX\ puts out four to seven of
+these trailing bytes, until the total length of the file is a multiple of
+four bytes, since this works out best on machines that pack four bytes per
+word; but any number of 223's is allowed, as long as there are at least four
+of them. In effect, 223 is a sort of signature that is added at the very end.
+@^Fuchs, David Raymond@>
+
+This curious way to finish off a \.{DVI} file makes it feasible for
+\.{DVI}-reading programs to find the postamble first, on most computers,
+even though \TeX\ wants to write the postamble last. Most operating
+systems permit random access to individual words or bytes of a file, so
+the \.{DVI} reader can start at the end and skip backwards over the 223's
+until finding the identification byte. Then it can back up four bytes, read
+|q|, and move to byte |q| of the file. This byte should, of course,
+contain the value 248 (|post|); now the postamble can be read, so the
+\.{DVI} reader discovers all the information needed for typesetting the
+pages. Note that it is also possible to skip through the \.{DVI} file at
+reasonably high speed to locate a particular page, if that proves
+desirable. This saves a lot of time, since \.{DVI} files used in production
+jobs tend to be large.
+
+Unfortunately, however, standard \PASCAL\ does not include the ability to
+@^system dependencies@>
+access a random position in a file, or even to determine the length of a file.
+Almost all systems nowadays provide the necessary capabilities, so \.{DVI}
+format has been designed to work most efficiently with modern operating systems.
+As noted above, \.{DVItype} will limit itself to the restrictions of standard
+\PASCAL\ if |random_reading| is defined to be |false|.
+
+@* Input from binary files.
+We have seen that a \.{DVI} file is a sequence of 8-bit bytes. The bytes
+appear physically in what is called a `|packed file of 0..255|'
+in \PASCAL\ lingo.
+
+Packing is system dependent, and many \PASCAL\ systems fail to implement
+such files in a sensible way (at least, from the viewpoint of producing
+good production software). For example, some systems treat all
+byte-oriented files as text, looking for end-of-line marks and such
+things. Therefore some system-dependent code is often needed to deal with
+binary files, even though most of the program in this section of
+\.{DVItype} is written in standard \PASCAL.
+@^system dependencies@>
+
+One common way to solve the problem is to consider files of |integer|
+numbers, and to convert an integer in the range $-2^{31}\L x<2^{31}$ to
+a sequence of four bytes $(a,b,c,d)$ using the following code, which
+avoids the controversial integer division of negative numbers:
+$$\vbox{\halign{#\hfil\cr
+|if x>=0 then a:=x div @'100000000|\cr
+|else begin x:=(x+@'10000000000)+@'10000000000; a:=x div @'100000000+128;|\cr
+\quad|end|\cr
+|x:=x mod @'100000000;|\cr
+|b:=x div @'200000; x:=x mod @'200000;|\cr
+|c:=x div @'400; d:=x mod @'400;|\cr}}$$
+The four bytes are then kept in a buffer and output one by one. (On 36-bit
+computers, an additional division by 16 is necessary at the beginning.
+Another way to separate an integer into four bytes is to use/abuse
+\PASCAL's variant records, storing an integer and retrieving bytes that are
+packed in the same place; {\sl caveat implementor!\/}) It is also desirable
+in some cases to read a hundred or so integers at a time, maintaining a
+larger buffer.
+
+We shall stick to simple \PASCAL\ in this program, for reasons of clarity,
+even if such simplicity is sometimes unrealistic.
+
+@<Types...@>=
+@!eight_bits=0..255; {unsigned one-byte quantity}
+@!byte_file=packed file of eight_bits; {files that contain binary data}
+
+@ The program deals with two binary file variables: |dvi_file| is the main
+input file that we are translating into symbolic form, and |tfm_file| is
+the current font metric file from which character-width information is
+being read.
+
+@<Glob...@>=
+@!dvi_file:byte_file; {the stuff we are \.{DVI}typing}
+@!tfm_file:byte_file; {a font metric file}
+
+@ To prepare these files for input, we |reset| them. An extension of
+\PASCAL\ is needed in the case of |tfm_file|, since we want to associate
+it with external files whose names are specified dynamically (i.e., not
+known at compile time). The following code assumes that `|reset(f,s)|'
+does this, when |f| is a file variable and |s| is a string variable that
+specifies the file name. If |eof(f)| is true immediately after
+|reset(f,s)| has acted, we assume that no file named |s| is accessible.
+@^system dependencies@>
+
+@p procedure open_dvi_file; {prepares to read packed bytes in |dvi_file|}
+begin reset(dvi_file);
+cur_loc:=0;
+end;
+@#
+procedure open_tfm_file; {prepares to read packed bytes in |tfm_file|}
+begin reset(tfm_file,cur_name);
+end;
+
+@ If you looked carefully at the preceding code, you probably asked,
+``What are |cur_loc| and |cur_name|?'' Good question. They're global
+variables: |cur_loc| is the number of the byte about to be read next from
+|dvi_file|, and |cur_name| is a string variable that will be set to the
+current font metric file name before |open_tfm_file| is called.
+
+@<Glob...@>=
+@!cur_loc:integer; {where we are about to look, in |dvi_file|}
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+
+@ It turns out to be convenient to read four bytes at a time, when we are
+inputting from \.{TFM} files. The input goes into global variables
+|b0|, |b1|, |b2|, and |b3|, with |b0| getting the first byte and |b3|
+the fourth.
+
+@<Glob...@>=
+@!b0,@!b1,@!b2,@!b3: eight_bits; {four bytes input at once}
+
+@ The |read_tfm_word| procedure sets |b0| through |b3| to the next
+four bytes in the current \.{TFM} file.
+@^system dependencies@>
+
+@p procedure read_tfm_word;
+begin read(tfm_file,b0); read(tfm_file,b1);
+read(tfm_file,b2); read(tfm_file,b3);
+end;
+
+@ We shall use another set of simple functions to read the next byte or
+bytes from |dvi_file|. There are seven possibilities, each of which is
+treated as a separate function in order to minimize the overhead for
+subroutine calls.
+@^system dependencies@>
+
+@p function get_byte:integer; {returns the next byte, unsigned}
+var b:eight_bits;
+begin if eof(dvi_file) then get_byte:=0
+else begin read(dvi_file,b); incr(cur_loc); get_byte:=b;
+ end;
+end;
+@#
+function signed_byte:integer; {returns the next byte, signed}
+var b:eight_bits;
+begin read(dvi_file,b); incr(cur_loc);
+if b<128 then signed_byte:=b @+ else signed_byte:=b-256;
+end;
+@#
+function get_two_bytes:integer; {returns the next two bytes, unsigned}
+var a,@!b:eight_bits;
+begin read(dvi_file,a); read(dvi_file,b);
+cur_loc:=cur_loc+2;
+get_two_bytes:=a*256+b;
+end;
+@#
+function signed_pair:integer; {returns the next two bytes, signed}
+var a,@!b:eight_bits;
+begin read(dvi_file,a); read(dvi_file,b);
+cur_loc:=cur_loc+2;
+if a<128 then signed_pair:=a*256+b
+else signed_pair:=(a-256)*256+b;
+end;
+@#
+function get_three_bytes:integer; {returns the next three bytes, unsigned}
+var a,@!b,@!c:eight_bits;
+begin read(dvi_file,a); read(dvi_file,b); read(dvi_file,c);
+cur_loc:=cur_loc+3;
+get_three_bytes:=(a*256+b)*256+c;
+end;
+@#
+function signed_trio:integer; {returns the next three bytes, signed}
+var a,@!b,@!c:eight_bits;
+begin read(dvi_file,a); read(dvi_file,b); read(dvi_file,c);
+cur_loc:=cur_loc+3;
+if a<128 then signed_trio:=(a*256+b)*256+c
+else signed_trio:=((a-256)*256+b)*256+c;
+end;
+@#
+function signed_quad:integer; {returns the next four bytes, signed}
+var a,@!b,@!c,@!d:eight_bits;
+begin read(dvi_file,a); read(dvi_file,b); read(dvi_file,c); read(dvi_file,d);
+cur_loc:=cur_loc+4;
+if a<128 then signed_quad:=((a*256+b)*256+c)*256+d
+else signed_quad:=(((a-256)*256+b)*256+c)*256+d;
+end;
+
+@ Finally we come to the routines that are used only if |random_reading| is
+|true|. The driver program below needs two such routines: |dvi_length| should
+compute the total number of bytes in |dvi_file|, possibly also
+causing |eof(dvi_file)| to be true; and |move_to_byte(n)|
+should position |dvi_file| so that the next |get_byte| will read byte |n|,
+starting with |n=0| for the first byte in the file.
+@^system dependencies@>
+
+Such routines are, of course, highly system dependent. They are implemented
+here in terms of two assumed system routines called |set_pos| and |cur_pos|.
+The call |set_pos(f,n)| moves to item |n| in file |f|, unless |n| is
+negative or larger than the total number of items in |f|; in the latter
+case, |set_pos(f,n)| moves to the end of file |f|.
+The call |cur_pos(f)| gives the total number of items in |f|, if
+|eof(f)| is true; we use |cur_pos| only in such a situation.
+
+@p function dvi_length:integer;
+begin set_pos(dvi_file,-1); dvi_length:=cur_pos(dvi_file);
+end;
+@#
+procedure move_to_byte(n:integer);
+begin set_pos(dvi_file,n); cur_loc:=n;
+end;
+
+@* Reading the font information.
+\.{DVI} file format does not include information about character widths, since
+that would tend to make the files a lot longer. But a program that reads
+a \.{DVI} file is supposed to know the widths of the characters that appear
+in \\{set\_char} commands. Therefore \.{DVItype} looks at the font metric
+(\.{TFM}) files for the fonts that are involved.
+@.TFM {\rm files}@>
+
+The character-width data appears also in other files (e.g., in \.{GF} files
+that specify bit patterns for digitized characters);
+thus, it is usually possible for \.{DVI} reading programs to get by with
+accessing only one file per font. \.{DVItype} has a comparatively easy
+task in this regard, since it needs only a few words of information from
+each font; other \.{DVI}-to-printer programs may have to go to some pains to
+deal with complications that arise when a large number of large font files
+all need to be accessed simultaneously.
+
+@ For purposes of this program, we need to know only two things about a
+given character |c| in a given font |f|: (1)~Is |c| a legal character
+in~|f|? (2)~If so, what is the width of |c|? We also need to know the
+symbolic name of each font, so it can be printed out, and we need to know
+the approximate size of inter-word spaces in each font.
+
+The answers to these questions appear implicitly in the following data
+structures. The current number of known fonts is |nf|. Each known font has
+an internal number |f|, where |0<=f<nf|; the external number of this font,
+i.e., its font identification number in the \.{DVI} file, is
+|font_num[f]|, and the external name of this font is the string that
+occupies positions |font_name[f]| through |font_name[f+1]-1| of the array
+|names|. The latter array consists of |ASCII_code| characters, and
+|font_name[nf]| is its first unoccupied position. A horizontal motion
+in the range |-4*font_space[f]<h<font_space[f]|
+will be treated as a `kern' that is not
+indicated in the printouts that \.{DVItype} produces between brackets. The
+legal characters run from |font_bc[f]| to |font_ec[f]|, inclusive; more
+precisely, a given character |c| is valid in font |f| if and only if
+|font_bc[f]<=c<=font_ec[f]| and |char_width(f)(c)<>invalid_width|.
+Finally, |char_width(f)(c)=width[width_base[f]+c]|, and |width_ptr| is the
+first unused position of the |width| array.
+
+@d char_width_end(#)==#]
+@d char_width(#)==width[width_base[#]+char_width_end
+@d invalid_width==@'17777777777
+@d invalid_font==max_fonts
+
+@<Glob...@>=
+@!font_num:array [0..max_fonts] of integer; {external font numbers}
+@!font_name:array [0..max_fonts] of 1..name_size; {starting positions
+ of external font names}
+@!names:array [1..name_size] of ASCII_code; {characters of names}
+@!font_check_sum:array [0..max_fonts] of integer; {check sums}
+@!font_scaled_size:array [0..max_fonts] of integer; {scale factors}
+@!font_design_size:array [0..max_fonts] of integer; {design sizes}
+@!font_space:array [0..max_fonts] of integer; {boundary between ``small''
+ and ``large'' spaces}
+@!font_bc:array [0..max_fonts] of integer; {beginning characters in fonts}
+@!font_ec:array [0..max_fonts] of integer; {ending characters in fonts}
+@!width_base:array [0..max_fonts] of integer; {index into |width| table}
+@!width:array [0..max_widths] of integer; {character widths, in \.{DVI} units}
+@!nf:0..max_fonts; {the number of known fonts}
+@!width_ptr:0..max_widths; {the number of known character widths}
+
+@ @<Set init...@>=
+nf:=0; width_ptr:=0; font_name[0]:=1;@/
+font_space[invalid_font]:=0; {for |out_space| and |out_vmove|}
+font_bc[invalid_font]:=1; font_ec[invalid_font]:=0;
+
+@ It is, of course, a simple matter to print the name of a given font.
+
+@p procedure print_font(@!f:integer); {|f| is an internal font number}
+var k:0..name_size; {index into |names|}
+begin if f=invalid_font then print('UNDEFINED!')
+@.UNDEFINED@>
+else begin for k:=font_name[f] to font_name[f+1]-1 do
+ print(xchr[names[k]]);
+ end;
+end;
+
+@ An auxiliary array |in_width| is used to hold the widths as they are
+input. The global variables |tfm_check_sum| and |tfm_design_size| are
+set to the check sum and design size that
+appear in the current \.{TFM} file.
+
+@<Glob...@>=
+@!in_width:array[0..65535] of integer; {\.{TFM} width data in \.{DVI} units}
+@!tfm_check_sum:integer; {check sum found in |tfm_file|}
+@!tfm_design_size:integer; {design size found in |tfm_file|, in \.{DVI} units}
+@!tfm_conv:real; {\.{DVI} units per absolute \.{TFM} unit}
+
+@ Here is a procedure that absorbs the necessary information from a
+\.{TFM} file, assuming that the file has just been successfully reset
+so that we are ready to read its first byte. (A complete description of
+\.{TFM} file format appears in the documentation of \.{TFtoPL} and will
+not be repeated here.) The procedure does not check the \.{TFM} file
+for validity, nor does it give explicit information about what is
+wrong with a \.{TFM} file that proves to be invalid; \.{DVI}-reading
+programs need not do this, since \.{TFM} files are almost always valid,
+and since the \.{TFtoPL} utility program has been specifically designed
+to diagnose \.{TFM} errors. The procedure simply returns |false| if it
+detects anything amiss in the \.{TFM} data.
+
+There is a parameter, |z|, which represents the scaling factor being
+used to compute the font dimensions; it must be in the range $0<z<2^{27}$.
+
+@p function in_TFM(@!z:integer):boolean; {input \.{TFM} data or return |false|}
+label 9997, {go here when the format is bad}
+ 9998, {go here when the information cannot be loaded}
+ 9999; {go here to exit}
+var k:integer; {index for loops}
+@!lh:integer; {length of the header data, in four-byte words}
+@!nw:integer; {number of words in the width table}
+@!wp:0..max_widths; {new value of |width_ptr| after successful input}
+@!alpha,@!beta:integer; {quantities used in the scaling computation}
+@!nco:integer; {offset to get to the characters}
+@!extra_words:integer; {no of extra words in |char_info| words}
+@!ofm_level:integer; {TFM, OFM level 0 or 1}
+@!j,kprime:integer; {extra counters}
+begin @<Read past the header data; |goto 9997| if there is a problem@>;
+@<Store character-width indices at the end of the |width| table@>;
+@<Read and convert the width values, setting up the |in_width| table@>;
+@<Move the widths from |in_width| to |width|, and append |pixel_width| values@>;
+width_ptr:=wp; in_TFM:=true; goto 9999;
+9997: print_ln('---not loaded, font metric file is bad');
+@.TFM file is bad@>
+9998: in_TFM:=false;
+9999: end;
+
+@ @<Read past the header...@>=
+read_tfm_word;
+if (b0*256+b1)<>0 then begin {TFM file}
+ ofm_level:=-1;
+ lh:=b2*256+b3;
+ read_tfm_word; font_bc[nf]:=b0*256+b1; font_ec[nf]:=b2*256+b3;
+ if font_ec[nf]<font_bc[nf] then font_bc[nf]:=font_ec[nf]+1;
+ if width_ptr+font_ec[nf]-font_bc[nf]+1>max_widths then
+ begin print_ln('---not loaded, ODVItype needs larger width table');
+@.ODVItype needs larger...@>
+ goto 9998;
+ end;
+ wp:=width_ptr+font_ec[nf]-font_bc[nf]+1;
+ read_tfm_word; nw:=b0*256+b1;
+ if (nw=0)or(nw>256) then goto 9997;
+ for k:=1 to 3+lh do
+ begin if eof(tfm_file) then goto 9997;
+ read_tfm_word;
+ if k=4 then
+ if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
+ else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3
+ else if k=5 then
+ if b0<128 then
+ tfm_design_size:=round(tfm_conv*(((b0*256+b1)*256+b2)*256+b3))
+ else goto 9997;
+ end;
+ end
+else begin
+ ofm_level:=b2*256+b3;
+ read_tfm_word;
+ read_tfm_word; lh:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_bc[nf]:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_ec[nf]:=((b0*256+b1)*256+b2)*256+b3;
+ if font_ec[nf]<font_bc[nf] then font_bc[nf]:=font_ec[nf]+1;
+ if width_ptr+font_ec[nf]-font_bc[nf]+1>max_widths then
+ begin print_ln('---not loaded, ODVItype needs larger width table');
+@.ODVItype needs larger...@>
+ goto 9998;
+ end;
+ wp:=width_ptr+font_ec[nf]-font_bc[nf]+1;
+ read_tfm_word; nw:=((b0*256+b1)*256+b2)*256+b3;
+ if (nw=0)or(nw>65536) then goto 9997;
+ for k:=1 to 8 do
+ begin if eof(tfm_file) then goto 9997;
+ read_tfm_word;
+ end;
+ if ofm_level=1 then begin
+ read_tfm_word; nco:=(((b0*256+b1)*256+b2)*256+b3) div 2;
+ read_tfm_word;
+ read_tfm_word; extra_words:=(((b0*256+b1)*256+b2)*256+b3) div 2;
+ for k:=1 to 12 do
+ begin if eof(tfm_file) then goto 9997;
+ read_tfm_word;
+ end;
+ end;
+ for k:=1 to lh do
+ begin if eof(tfm_file) then goto 9997;
+ read_tfm_word;
+ if k=1 then
+ if b0<128 then tfm_check_sum:=((b0*256+b1)*256+b2)*256+b3
+ else tfm_check_sum:=(((b0-256)*256+b1)*256+b2)*256+b3
+ else if k=2 then
+ if b0<128 then
+ tfm_design_size:=round(tfm_conv*(((b0*256+b1)*256+b2)*256+b3))
+ else goto 9997;
+ end;
+ if ofm_level=1 then
+ for k:=1 to (nco-29-lh) do
+ read_tfm_word;
+ end
+
+@ @<Store character-width indices...@>=
+case ofm_level of
+ -1:begin
+ if wp>0 then for k:=width_ptr to wp-1 do
+ begin read_tfm_word;
+ if b0>nw then goto 9997;
+ width[k]:=b0;
+ end;
+ end;
+ 0:begin
+ if wp>0 then for k:=width_ptr to wp-1 do
+ begin read_tfm_word;
+ if (b0*256+b1)>nw then goto 9997;
+ width[k]:=(b0*256+b1);
+ read_tfm_word;
+ end;
+ end;
+ 1:begin
+ if wp>0 then begin
+ k:=width_ptr;
+ while k<wp do begin
+ read_tfm_word;
+ if (b0*256+b1)>nw then goto 9997;
+ width[k]:=(b0*256+b1);
+ read_tfm_word; read_tfm_word;
+ kprime:=k+(b0*256+b1);
+ for j:=k+1 to kprime do
+ width[j]:=width[k];
+ k:=kprime;
+ for j:=1 to extra_words do
+ read_tfm_word;
+ end
+ end
+ end;
+end;
+
+
+@ The most important part of |in_TFM| is the width computation, which
+involves multiplying the relative widths in the \.{TFM} file by the
+scaling factor in the \.{DVI} file. This fixed-point multiplication
+must be done with precisely the same accuracy by all \.{DVI}-reading programs,
+in order to validate the assumptions made by \.{DVI}-writing programs
+like \TeX82.
+
+Let us therefore summarize what needs to be done. Each width in a \.{TFM}
+file appears as a four-byte quantity called a |fix_word|. A |fix_word|
+whose respective bytes are $(a,b,c,d)$ represents the number
+$$x=\left\{\vcenter{\halign{$#$,\hfil\qquad&if $#$\hfil\cr
+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=0;\cr
+-16+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=255.\cr}}\right.$$
+(No other choices of $a$ are allowed, since the magnitude of a \.{TFM}
+dimension must be less than 16.) We want to multiply this quantity by the
+integer~|z|, which is known to be less than $2^{27}$.
+If $|z|<2^{23}$, the individual multiplications $b\cdot z$, $c\cdot z$,
+$d\cdot z$ cannot overflow; otherwise we will divide |z| by 2, 4, 8, or
+16, to obtain a multiplier less than $2^{23}$, and we can compensate for
+this later. If |z| has thereby been replaced by $|z|^\prime=|z|/2^e$, let
+$\beta=2^{4-e}$; we shall compute
+$$\lfloor(b+c\cdot2^{-8}+d\cdot2^{-16})\,z^\prime/\beta\rfloor$$ if $a=0$,
+or the same quantity minus $\alpha=2^{4+e}z^\prime$ if $a=255$.
+This calculation must be
+done exactly, for the reasons stated above; the following program does the
+job in a system-independent way, assuming that arithmetic is exact on
+numbers less than $2^{31}$ in magnitude.
+
+@<Read and convert the width values...@>=
+@<Replace |z| by $|z|^\prime$ and compute $\alpha,\beta$@>;
+for k:=0 to nw-1 do
+ begin read_tfm_word;
+ in_width[k]:=(((((b3*z)div@'400)+(b2*z))div@'400)+(b1*z))div beta;
+ if b0>0 then if b0<255 then goto 9997
+ else in_width[k]:=in_width[k]-alpha;
+ end
+
+@ @<Replace |z|...@>=
+begin alpha:=16;
+while z>=@'40000000 do
+ begin z:=z div 2; alpha:=alpha+alpha;
+ end;
+beta:=256 div alpha; alpha:=alpha*z;
+end
+
+@ A \.{DVI}-reading program usually works with font files instead of
+\.{TFM} files, so \.{DVItype} is atypical in that respect. Font files
+should, however, contain exactly the same character width data that is
+found in the corresponding \.{TFM}s; check sums are used to help
+ensure this. In addition, font files usually also contain the widths of
+characters in pixels, since the device-independent character widths of
+\.{TFM} files are generally not perfect multiples of pixels.
+
+The |pixel_width| array contains this information; when |width[k]| is the
+device-independent width of some character in \.{DVI} units, |pixel_width[k]|
+is the corresponding width of that character in an actual font.
+The macro |char_pixel_width| is set up to be analogous to |char_width|.
+
+@d char_pixel_width(#)==pixel_width[width_base[#]+char_width_end
+
+@<Glob...@>=
+@!pixel_width:array[0..max_widths] of integer; {actual character widths,
+ in pixels}
+@!conv:real; {converts \.{DVI} units to pixels}
+@!true_conv:real; {converts unmagnified \.{DVI} units to pixels}
+@!numerator,@!denominator:integer; {stated conversion ratio}
+@!mag:integer; {magnification factor times 1000}
+
+@ The following code computes pixel widths by simply rounding the \.{TFM}
+widths to the nearest integer number of pixels, based on the conversion factor
+|conv| that converts \.{DVI} units to pixels. However, such a simple
+formula will not be valid for all fonts, and it will often give results that
+are off by $\pm1$ when a low-resolution font has been carefully
+hand-fitted. For example, a font designer often wants to make the letter `m'
+a pixel wider or narrower in order to make the font appear more consistent.
+\.{DVI}-to-printer programs should therefore input the correct pixel width
+information from font files whenever there is a chance that it may differ.
+A warning message may also be desirable in the case that at least one character
+is found whose pixel width differs from |conv*width| by more than a full pixel.
+@^system dependencies@>
+
+@d pixel_round(#)==round(conv*(#))
+
+@<Move the widths from |in_width| to |width|, and append |pixel_width| values@>=
+if in_width[0]<>0 then goto 9997; {the first width should be zero}
+width_base[nf]:=width_ptr-font_bc[nf];
+if wp>0 then for k:=width_ptr to wp-1 do
+ if width[k]=0 then
+ begin width[k]:=invalid_width; pixel_width[k]:=0;
+ end
+ else begin width[k]:=in_width[width[k]];
+ pixel_width[k]:=pixel_round(width[k]);
+ end
+
+@* Optional modes of output.
+\.{DVItype} will print different quantities of information based on some
+options that the user must specify: The |out_mode| level is set to one of
+five values (|errors_only|, |terse|, |mnemonics_only|,
+|verbose|, |the_works|), giving
+different degrees of output; and the typeout can be confined to a
+restricted subset of the pages by specifying the desired starting page and
+the maximum number of pages. Furthermore there is an option to specify the
+resolution of an assumed discrete output device, so that pixel-oriented
+calculations will be shown; and there is an option to override the
+magnification factor that is stated in the \.{DVI} file.
+
+The starting page is specified by giving a sequence of 1 to 10 numbers or
+asterisks separated by dots. For example, the specification `\.{1.*.-5}'
+can be used to refer to a page output by \TeX\ when $\.{\\count0}=1$
+and $\.{\\count2}=-5$. (Recall that |bop| commands in a \.{DVI} file
+are followed by ten `count' values.) An asterisk matches any number,
+so the `\.*' in `\.{1.*.-5}' means that \.{\\count1} is ignored when
+specifying the first page. If several pages match the given specification,
+\.{DVItype} will begin with the earliest such page in the file. The
+default specification `\.*' (which matches all pages) therefore denotes
+the page at the beginning of the file.
+
+When \.{DVItype} begins, it engages the user in a brief dialog so that the
+options will be specified. This part of \.{DVItype} requires nonstandard
+\PASCAL\ constructions to handle the online interaction; so it may be
+preferable in some cases to omit the dialog and simply to stick to the
+default options (|out_mode=the_works|, starting page `\.*',
+|max_pages=1000000|, |resolution=300.0|, |new_mag=0|). On other hand, the
+system-dependent routines that are needed are not complicated, so it will
+not be terribly difficult to introduce them.
+@^system dependencies@>
+
+@d errors_only=0 {value of |out_mode| when minimal printing occurs}
+@d terse=1 {value of |out_mode| for abbreviated output}
+@d mnemonics_only=2 {value of |out_mode| for medium-quantity output}
+@d verbose=3 {value of |out_mode| for detailed tracing}
+@d the_works=4 {|verbose|, plus check of postamble if |random_reading|}
+
+@<Glob...@>=
+@!out_mode:errors_only..the_works; {controls the amount of output}
+@!max_pages:integer; {at most this many |bop..eop| pages will be printed}
+@!resolution:real; {pixels per inch}
+@!new_mag:integer; {if positive, overrides the postamble's magnification}
+
+@ The starting page specification is recorded in two global arrays called
+|start_count| and |start_there|. For example, `\.{1.*.-5}' is represented
+by |start_there[0]=true|, |start_count[0]=1|, |start_there[1]=false|,
+|start_there[2]=true|, |start_count[2]=-5|.
+We also set |start_vals=2|, to indicate that count 2 was the last one
+mentioned. The other values of |start_count| and |start_there| are not
+important, in this example.
+
+@<Glob...@>=
+@!start_count:array[0..9] of integer; {count values to select starting page}
+@!start_there:array[0..9] of boolean; {is the |start_count| value relevant?}
+@!start_vals:0..9; {the last count considered significant}
+@!count:array[0..9] of integer; {the count values on the current page}
+
+@ @<Set init...@>=
+out_mode:=the_works; max_pages:=1000000; start_vals:=0; start_there[0]:=false;
+
+@ Here is a simple subroutine that tests if the current page might be the
+starting page.
+
+@p function start_match:boolean; {does |count| match the starting spec?}
+var k:0..9; {loop index}
+@!match:boolean; {does everything match so far?}
+begin match:=true;
+for k:=0 to start_vals do
+ if start_there[k]and(start_count[k]<>count[k]) then match:=false;
+start_match:=match;
+end;
+
+@ The |input_ln| routine waits for the user to type a line at his or her
+terminal; then it puts ASCII-code equivalents for the characters on that line
+into the |buffer| array. The |term_in| file is used for terminal input,
+and |term_out| for terminal output.
+@^system dependencies@>
+
+@<Glob...@>=
+@!buffer:array[0..terminal_line_length] of ASCII_code;
+@!term_in:text_file; {the terminal, considered as an input file}
+@!term_out:text_file; {the terminal, considered as an output file}
+
+@ Since the terminal is being used for both input and output, some systems
+need a special routine to make sure that the user can see a prompt message
+before waiting for input based on that message. (Otherwise the message
+may just be sitting in a hidden buffer somewhere, and the user will have
+no idea what the program is waiting for.) We shall invoke a system-dependent
+subroutine |update_terminal| in order to avoid this problem.
+@^system dependencies@>
+
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+
+@ During the dialog, \.{DVItype} will treat the first blank space in a
+line as the end of that line. Therefore |input_ln| makes sure that there
+is always at least one blank space in |buffer|.
+@^system dependencies@>
+
+@p procedure input_ln; {inputs a line from the terminal}
+var k:0..terminal_line_length;
+begin update_terminal; reset(term_in);
+if eoln(term_in) then read_ln(term_in);
+k:=0;
+while (k<terminal_line_length)and not eoln(term_in) do
+ begin buffer[k]:=xord[term_in^]; incr(k); get(term_in);
+ end;
+buffer[k]:=" ";
+end;
+
+@ The global variable |buf_ptr| is used while scanning each line of input;
+it points to the first unread character in |buffer|.
+
+@<Glob...@>=
+@!buf_ptr:0..terminal_line_length; {the number of characters read}
+
+@ Here is a routine that scans a (possibly signed) integer and computes
+the decimal value. If no decimal integer starts at |buf_ptr|, the
+value 0 is returned. The integer should be less than $2^{31}$ in
+absolute value.
+
+@p function get_integer:integer;
+var x:integer; {accumulates the value}
+@!negative:boolean; {should the value be negated?}
+begin if buffer[buf_ptr]="-" then
+ begin negative:=true; incr(buf_ptr);
+ end
+else negative:=false;
+x:=0;
+while (buffer[buf_ptr]>="0")and(buffer[buf_ptr]<="9") do
+ begin x:=10*x+buffer[buf_ptr]-"0"; incr(buf_ptr);
+ end;
+if negative then get_integer:=-x @+ else get_integer:=x;
+end;
+
+@ The selected options are put into global variables by the |dialog|
+procedure, which is called just as \.{DVItype} begins.
+@^system dependencies@>
+
+@p procedure dialog;
+label 1,2,3,4,5;
+var k:integer; {loop variable}
+begin rewrite(term_out); {prepare the terminal for output}
+write_ln(term_out,banner);
+@<Determine the desired |out_mode|@>;
+@<Determine the desired |start_count| values@>;
+@<Determine the desired |max_pages|@>;
+@<Determine the desired |resolution|@>;
+@<Determine the desired |new_mag|@>;
+@<Print all the selected options@>;
+end;
+
+@ @<Determine the desired |out_mode|@>=
+1: write(term_out,'Output level (default=4, ? for help): ');
+out_mode:=the_works; input_ln;
+if buffer[0]<>" " then
+ if (buffer[0]>="0")and(buffer[0]<="4") then out_mode:=buffer[0]-"0"
+ else begin write(term_out,'Type 4 for complete listing,');
+ write(term_out,' 0 for errors only,');
+ write_ln(term_out,' 1 or 2 or 3 for something in between.');
+ goto 1;
+ end
+
+@ @<Determine the desired |start...@>=
+2: write(term_out,'Starting page (default=*): ');
+start_vals:=0; start_there[0]:=false;
+input_ln; buf_ptr:=0; k:=0;
+if buffer[0]<>" " then
+ repeat if buffer[buf_ptr]="*" then
+ begin start_there[k]:=false; incr(buf_ptr);
+ end
+ else begin start_there[k]:=true; start_count[k]:=get_integer;
+ end;
+ if (k<9)and(buffer[buf_ptr]=".") then
+ begin incr(k); incr(buf_ptr);
+ end
+ else if buffer[buf_ptr]=" " then start_vals:=k
+ else begin write(term_out,'Type, e.g., 1.*.-5 to specify the ');
+ write_ln(term_out,'first page with \count0=1, \count2=-5.');
+ goto 2;
+ end;
+ until start_vals=k
+
+@ @<Determine the desired |max_pages|@>=
+3: write(term_out,'Maximum number of pages (default=1000000): ');
+max_pages:=1000000; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ begin max_pages:=get_integer;
+ if max_pages<=0 then
+ begin write_ln(term_out,'Please type a positive number.');
+ goto 3;
+ end;
+ end
+
+@ @<Determine the desired |resolution|@>=
+4: write(term_out,'Assumed device resolution');
+write(term_out,' in pixels per inch (default=300/1): ');
+resolution:=300.0; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ begin k:=get_integer;
+ if (k>0)and(buffer[buf_ptr]="/")and
+ (buffer[buf_ptr+1]>"0")and(buffer[buf_ptr+1]<="9") then
+ begin incr(buf_ptr); resolution:=k/get_integer;
+ end
+ else begin write(term_out,'Type a ratio of positive integers;');
+ write_ln(term_out,' (1 pixel per mm would be 254/10).');
+ goto 4;
+ end;
+ end
+
+@ @<Determine the desired |new_mag|@>=
+5: write(term_out,'New magnification (default=0 to keep the old one): ');
+new_mag:=0; input_ln; buf_ptr:=0;
+if buffer[0]<>" " then
+ if (buffer[0]>="0")and(buffer[0]<="9") then new_mag:=get_integer
+ else begin write(term_out,'Type a positive integer to override ');
+ write_ln(term_out,'the magnification in the DVI file.');
+ goto 5;
+ end
+
+@ After the dialog is over, we print the options so that the user
+can see what \.{DVItype} thought was specified.
+
+@<Print all the selected options@>=
+print_ln('Options selected:');
+@.Options selected@>
+print(' Starting page = ');
+for k:=0 to start_vals do
+ begin if start_there[k] then print(start_count[k]:1)
+ else print('*');
+ if k<start_vals then print('.')
+ else print_ln(' ');
+ end;
+print_ln(' Maximum number of pages = ',max_pages:1);
+print(' Output level = ',out_mode:1);
+case out_mode of
+errors_only: print_ln(' (showing bops, fonts, and error messages only)');
+terse: print_ln(' (terse)');
+mnemonics_only: print_ln(' (mnemonics)');
+verbose: print_ln(' (verbose)');
+the_works: if random_reading then print_ln(' (the works)')
+ else begin out_mode:=verbose;
+ print_ln(' (the works: same as level 3 in this DVItype)');
+ end;
+end;@/
+print_ln(' Resolution = ',resolution:12:8,' pixels per inch');
+if new_mag>0 then print_ln(' New magnification factor = ',new_mag/1000:8:3)
+
+@* Defining fonts.
+When |out_mode=the_works|, \.{DVItype} reads the postamble first and loads
+all of the fonts defined there; then it processes the pages. In this
+case, a \\{fnt\_def} command should match a previous definition if and only
+if the \\{fnt\_def} being processed is not in the postamble. But if
+|out_mode<the_works|, \.{DVItype} reads the pages first and the postamble
+last, so the conventions are reversed: a \\{fnt\_def} should match a previous
+\\{fnt\_def} if and only if the current one is a part of the postamble.
+
+A global variable |in_postamble| is provided to tell whether we are
+processing the postamble or not.
+
+@<Glob...@>=
+@!in_postamble:boolean; {are we reading the postamble?}
+
+@ @<Set init...@>=
+in_postamble:=false;
+
+@ The following subroutine does the necessary things when a \\{fnt\_def}
+command is being processed.
+
+@p procedure define_font(@!e:integer); {|e| is an external font number}
+var f:0..max_fonts;
+@!p:integer; {length of the area/directory spec}
+@!n:integer; {length of the font name proper}
+@!c,@!q,@!d,@!m:integer; {check sum, scaled size, design size, magnification}
+@!r:0..name_length; {index into |cur_name|}
+@!j,@!k:0..name_size; {indices into |names|}
+@!mismatch:boolean; {do names disagree?}
+begin if nf=max_fonts then abort('DVItype capacity exceeded (max fonts=',
+ max_fonts:1,')!');
+@.DVItype capacity exceeded...@>
+font_num[nf]:=e; f:=0;
+while font_num[f]<>e do incr(f);
+@<Read the font parameters into position for font |nf|, and
+ print the font name@>;
+if ((out_mode=the_works)and in_postamble)or@|
+ ((out_mode<the_works)and not in_postamble) then
+ begin if f<nf then print_ln('---this font was already defined!');
+@.this font was already defined@>
+ end
+else begin if f=nf then print_ln('---this font wasn''t loaded before!');
+@.this font wasn't loaded before@>
+ end;
+if f=nf then @<Load the new font, unless there are problems@>
+else @<Check that the current font definition matches the old one@>;
+end;
+
+@ @<Check that the current...@>=
+begin if font_check_sum[f]<>c then
+ print_ln('---check sum doesn''t match previous definition!');
+@.check sum doesn't match@>
+if font_scaled_size[f]<>q then
+ print_ln('---scaled size doesn''t match previous definition!');
+@.scaled size doesn't match@>
+if font_design_size[f]<>d then
+ print_ln('---design size doesn''t match previous definition!');
+@.design size doesn't match@>
+j:=font_name[f]; k:=font_name[nf];
+if font_name[f+1]-j<>font_name[nf+1]-k then mismatch:=true
+else begin mismatch:=false;
+ while j<font_name[f+1] do
+ begin if names[j]<>names[k] then mismatch:=true;
+ incr(j); incr(k);
+ end;
+ end;
+if mismatch then print_ln('---font name doesn''t match previous definition!');
+@.font name doesn't match@>
+end
+
+@ @<Read the font parameters into position for font |nf|...@>=
+c:=signed_quad; font_check_sum[nf]:=c;@/
+q:=signed_quad; font_scaled_size[nf]:=q;@/
+d:=signed_quad; font_design_size[nf]:=d;@/
+if (q<=0) or (d<=0) then m:=1000
+else m:=round((1000.0*conv*q)/(true_conv*d));
+p:=get_byte; n:=get_byte;
+if font_name[nf]+n+p>name_size then
+ abort('DVItype capacity exceeded (name size=',name_size:1,')!');
+@.DVItype capacity exceeded...@>
+font_name[nf+1]:=font_name[nf]+n+p;
+if showing then print(': ')
+ {when |showing| is true, the font number has already been printed}
+else print('Font ',e:1,': ');
+if n+p=0 then print('null font name!')
+@.null font name@>
+else for k:=font_name[nf] to font_name[nf+1]-1 do names[k]:=get_byte;
+print_font(nf);
+if not showing then if m<>1000 then print(' scaled ',m:1)
+@.scaled@>
+
+@ @<Load the new font, unless there are problems@>=
+begin @<Move font name into the |cur_name| string@>;
+open_tfm_file;
+if eof(tfm_file) then
+ print('---not loaded, TFM file can''t be opened!')
+@.TFM file can\'t be opened@>
+else begin if (q<=0)or(q>=@'1000000000) then
+ print('---not loaded, bad scale (',q:1,')!')
+@.bad scale@>
+ else if (d<=0)or(d>=@'1000000000) then
+ print('---not loaded, bad design size (',d:1,')!')
+@.bad design size@>
+ else if in_TFM(q) then @<Finish loading the new font info@>;
+ end;
+if out_mode=errors_only then print_ln(' ');
+end
+
+@ @<Finish loading...@>=
+begin font_space[nf]:=q div 6; {this is a 3-unit ``thin space''}
+if (c<>0)and(tfm_check_sum<>0)and(c<>tfm_check_sum) then
+ begin print_ln('---beware: check sums do not agree!');
+@.beware: check sums do not agree@>
+@.check sums do not agree@>
+ print_ln(' (',c:1,' vs. ',tfm_check_sum:1,')');
+ print(' ');
+ end;
+if abs(tfm_design_size-d)>2 then
+ begin print_ln('---beware: design sizes do not agree!');
+@.beware: design sizes do not agree@>
+@.design sizes do not agree@>
+ print_ln(' (',d:1,' vs. ',tfm_design_size:1,')');
+ print(' ');
+ end;
+print('---loaded at size ',q:1,' DVI units');
+d:=round((100.0*conv*q)/(true_conv*d));
+if d<>100 then
+ begin print_ln(' '); print(' (this font is magnified ',d:1,'%)');
+ end;
+@.this font is magnified@>
+incr(nf); {now the new font is officially present}
+end
+
+@ If |p=0|, i.e., if no font directory has been specified, \.{DVItype}
+is supposed to use the default font directory, which is a
+system-dependent place where the standard fonts are kept.
+The string variable |default_directory| contains the name of this area.
+@^system dependencies@>
+
+@d default_directory_name=='TeXfonts:' {change this to the correct name}
+@d default_directory_name_length=9 {change this to the correct length}
+
+@<Glob...@>=
+@!default_directory:packed array[1..default_directory_name_length] of char;
+
+@ @<Set init...@>=
+default_directory:=default_directory_name;
+
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{TFM} file for the current font. This usually means that we need to
+prepend the name of the default directory, and
+to append the suffix `\.{.TFM}'. Furthermore, we change lower case letters
+to upper case, since |cur_name| is a \PASCAL\ string.
+@^system dependencies@>
+
+@<Move font name into the |cur_name| string@>=
+for k:=1 to name_length do cur_name[k]:=' ';
+if p=0 then
+ begin for k:=1 to default_directory_name_length do
+ cur_name[k]:=default_directory[k];
+ r:=default_directory_name_length;
+ end
+else r:=0;
+for k:=font_name[nf] to font_name[nf+1]-1 do
+ begin incr(r);
+ if r+4>name_length then
+ abort('ODVItype capacity exceeded (max font name length=',
+ name_length:1,')!');
+@.ODVItype capacity exceeded...@>
+ if (names[k]>="a")and(names[k]<="z") then
+ cur_name[r]:=xchr[names[k]-@'40]
+ else cur_name[r]:=xchr[names[k]];
+ end;
+cur_name[r+1]:='.'; cur_name[r+2]:='T'; cur_name[r+3]:='F'; cur_name[r+4]:='M'
+
+@* Low level output routines.
+Simple text in the \.{DVI} file is saved in a buffer until |line_length-2|
+characters have accumulated, or until some non-simple \.{DVI} operation
+occurs. Then the accumulated text is printed on a line, surrounded by
+brackets. The global variable |text_ptr| keeps track of the number of
+characters currently in the buffer.
+
+@<Glob...@>=
+@!text_ptr:0..line_length; {the number of characters in |text_buf|}
+@!text_buf:array[1..line_length] of ASCII_code; {saved characters}
+
+@ @<Set init...@>=
+text_ptr:=0;
+
+@ The |flush_text| procedure will empty the buffer if there is something in it.
+
+@p procedure flush_text;
+var k:0..line_length; {index into |text_buf|}
+begin if text_ptr>0 then
+ begin if out_mode>errors_only then
+ begin print('[');
+ for k:=1 to text_ptr do print(xchr[text_buf[k]]);
+ print_ln(']');
+ end;
+ text_ptr:=0;
+ end;
+end;
+
+@ And the |out_text| procedure puts something in it.
+
+@p procedure out_text(c:ASCII_code);
+begin if text_ptr=line_length-2 then flush_text;
+incr(text_ptr); text_buf[text_ptr]:=c;
+end;
+
+@* Translation to symbolic form.
+The main work of \.{DVItype} is accomplished by the |do_page| procedure,
+which produces the output for an entire page, assuming that the |bop|
+command for that page has already been processed. This procedure is
+essentially an interpretive routine that reads and acts on the \.{DVI}
+commands.
+
+@ The definition of \.{DVI} files refers to six registers,
+$(h,v,w,x,y,z)$, which hold integer values in \.{DVI} units. In practice,
+we also need registers |hh| and |vv|, the pixel analogs of $h$ and $v$,
+since it is not always true that |hh=pixel_round(h)| or
+|vv=pixel_round(v)|.
+
+The stack of $(h,v,w,x,y,z)$ values is represented by eight arrays
+called |hstack|, \dots, |zstack|, |hhstack|, and |vvstack|.
+
+@<Glob...@>=
+@!h,@!v,@!w,@!x,@!y,@!z,@!hh,@!vv:integer; {current state values}
+@!hstack,@!vstack,@!wstack,@!xstack,@!ystack,@!zstack:
+ array [0..stack_size] of integer; {pushed down values in \.{DVI} units}
+@!hhstack,@!vvstack:
+ array [0..stack_size] of integer; {pushed down values in pixels}
+
+@ Three characteristics of the pages (their |max_v|, |max_h|, and
+|max_s|) are specified in the postamble, and a warning message
+is printed if these limits are exceeded. Actually |max_v| is set to
+the maximum height plus depth of a page, and |max_h| to the maximum width,
+for purposes of page layout. Since characters can legally be set outside
+of the page boundaries, it is not an error when |max_v| or |max_h| is
+exceeded. But |max_s| should not be exceeded.
+
+The postamble also specifies the total number of pages; \.{DVItype}
+checks to see if this total is accurate.
+
+@<Glob...@>=
+@!max_v:integer; {the value of |abs(v)| should probably not exceed this}
+@!max_h:integer; {the value of |abs(h)| should probably not exceed this}
+@!max_s:integer; {the stack depth should not exceed this}
+@!max_v_so_far,@!max_h_so_far,@!max_s_so_far:integer; {the record high levels}
+@!total_pages:integer; {the stated total number of pages}
+@!page_count:integer; {the total number of pages seen so far}
+
+@ @<Set init...@>=
+max_v:=@'17777777777-99; max_h:=@'17777777777-99; max_s:=stack_size+1;@/
+max_v_so_far:=0; max_h_so_far:=0; max_s_so_far:=0; page_count:=0;
+
+@ Before we get into the details of |do_page|, it is convenient to
+consider a simpler routine that computes the first parameter of each
+opcode.
+
+@d four_cases(#)==#,#+1,#+2,#+3
+@d eight_cases(#)==four_cases(#),four_cases(#+4)
+@d sixteen_cases(#)==eight_cases(#),eight_cases(#+8)
+@d thirty_two_cases(#)==sixteen_cases(#),sixteen_cases(#+16)
+@d sixty_four_cases(#)==thirty_two_cases(#),thirty_two_cases(#+32)
+
+@p function first_par(o:eight_bits):integer;
+begin case o of
+sixty_four_cases(set_char_0),sixty_four_cases(set_char_0+64):
+ first_par:=o-set_char_0;
+set1,put1,fnt1,xxx1,fnt_def1: first_par:=get_byte;
+set1+1,put1+1,fnt1+1,xxx1+1,fnt_def1+1: first_par:=get_two_bytes;
+set1+2,put1+2,fnt1+2,xxx1+2,fnt_def1+2: first_par:=get_three_bytes;
+right1,w1,x1,down1,y1,z1: first_par:=signed_byte;
+right1+1,w1+1,x1+1,down1+1,y1+1,z1+1: first_par:=signed_pair;
+right1+2,w1+2,x1+2,down1+2,y1+2,z1+2: first_par:=signed_trio;
+set1+3,set_rule,put1+3,put_rule,right1+3,w1+3,x1+3,down1+3,y1+3,z1+3,
+ fnt1+3,xxx1+3,fnt_def1+3: first_par:=signed_quad;
+nop,bop,eop,push,pop,pre,post,post_post,undefined_commands: first_par:=0;
+w0: first_par:=w;
+x0: first_par:=x;
+y0: first_par:=y;
+z0: first_par:=z;
+sixty_four_cases(fnt_num_0): first_par:=o-fnt_num_0;
+end;
+end;
+
+@ Here is another subroutine that we need: It computes the number of
+pixels in the height or width of a rule. Characters and rules will line up
+properly if the sizes are computed precisely as specified here. (Since
+|conv| is computed with some floating-point roundoff error, in a
+machine-dependent way, format designers who are tailoring something for a
+particular resolution should not plan their measurements to come out to an
+exact integer number of pixels; they should compute things so that the
+rule dimensions are a little less than an integer number of pixels, e.g.,
+4.99 instead of 5.00.)
+
+@p function rule_pixels(x:integer):integer;
+ {computes $\lceil|conv|\cdot x\rceil$}
+var n:integer;
+begin n:=trunc(conv*x);
+if n<conv*x then rule_pixels:=n+1 @+ else rule_pixels:=n;
+end;
+
+@ Strictly speaking, the |do_page| procedure is really a function with
+side effects, not a `\&{procedure}'\thinspace; it returns the value |false|
+if \.{DVItype} should be aborted because of some unusual happening. The
+subroutine is organized as a typical interpreter, with a multiway branch
+on the command code followed by |goto| statements leading to routines that
+finish up the activities common to different commands. We will use the
+following labels:
+
+@d fin_set=41 {label for commands that set or put a character}
+@d fin_rule=42 {label for commands that set or put a rule}
+@d move_right=43 {label for commands that change |h|}
+@d move_down=44 {label for commands that change |v|}
+@d show_state=45 {label for commands that change |s|}
+@d change_font=46 {label for commands that change |cur_font|}
+
+@ Some \PASCAL\ compilers severely restrict the length of procedure bodies,
+so we shall split |do_page| into two parts, one of which is
+called |special_cases|. The different parts communicate with each other
+via the global variables mentioned above, together with the following ones:
+
+@<Glob...@>=
+@!s:integer; {current stack size}
+@!ss:integer; {stack size to print}
+@!cur_font:integer; {current internal font number}
+@!showing:boolean; {is the current command being translated in full?}
+
+@ Here is the overall setup.
+
+@p @t\4@>@<Declare the function called |special_cases|@>@;
+function do_page:boolean;
+label fin_set,fin_rule,move_right,show_state,done,9998,9999;
+var o:eight_bits; {operation code of the current command}
+@!p,@!q:integer; {parameters of the current command}
+@!a:integer; {byte number of the current command}
+@!hhh:integer; {|h|, rounded to the nearest pixel}
+begin cur_font:=invalid_font; {set current font undefined}
+s:=0; h:=0; v:=0; w:=0; x:=0; y:=0; z:=0; hh:=0; vv:=0;
+ {initialize the state variables}
+while true do @<Translate the next command in the \.{DVI} file;
+ |goto 9999| with |do_page=true| if it was |eop|;
+ |goto 9998| if premature termination is needed@>;
+9998: print_ln('!'); do_page:=false;
+9999: end;
+
+@ Commands are broken down into ``major'' and ``minor'' categories:
+A major command is always shown in full, while a minor one is
+put into the buffer in abbreviated form. Minor commands, which
+account for the bulk of most \.{DVI} files, involve horizontal spacing
+and the typesetting of characters in a line; these are shown in full
+only if |out_mode>=verbose|.
+
+@d show(#)==begin flush_text; showing:=true; print(a:1,': ',#);
+ end
+@d major(#)==if out_mode>errors_only then show(#)
+@d minor(#)==if out_mode>terse then
+ begin showing:=true; print(a:1,': ',#);
+ end
+@d error(#)==if not showing then show(#) else print(' ',#)
+
+@<Translate the next command...@>=
+begin a:=cur_loc; showing:=false;
+o:=get_byte; p:=first_par(o);
+if eof(dvi_file) then bad_dvi('the file ended prematurely');
+@.the file ended prematurely@>
+@<Start translation of command |o| and |goto| the appropriate label to
+ finish the job@>;
+fin_set: @<Finish a command that either sets or puts a character, then
+ |goto move_right| or |done|@>;
+fin_rule: @<Finish a command that either sets or puts a rule, then
+ |goto move_right| or |done|@>;
+move_right: @<Finish a command that sets |h:=h+q|, then |goto done|@>;
+show_state: @<Show the values of |ss|, |h|, |v|, |w|, |x|, |y|, |z|,
+ |hh|, and |vv|; then |goto done|@>;
+done: if showing then print_ln(' ');
+end
+
+@ The multiway switch in |first_par|, above, was organized by the length
+of each command; the one in |do_page| is organized by the semantics.
+
+@<Start translation...@>=
+if o<set_char_0+128 then @<Translate a |set_char| command@>
+else case o of
+ four_cases(set1): begin major('set',o-set1+1:1,' ',p:1); goto fin_set;
+ end;
+ four_cases(put1): begin major('put',o-put1+1:1,' ',p:1); goto fin_set;
+ end;
+ set_rule: begin major('setrule'); goto fin_rule;
+ end;
+ put_rule: begin major('putrule'); goto fin_rule;
+ end;
+ @t\4@>@<Cases for commands |nop|, |bop|, \dots, |pop|@>@;
+ @t\4@>@<Cases for horizontal motion@>@;
+ othercases if special_cases(o,p,a) then goto done@+else goto 9998
+ endcases
+
+@ @<Declare the function called |special_cases|@>=
+function special_cases(@!o:eight_bits;@!p,@!a:integer):boolean;
+label change_font,move_down,done,9998;
+var q:integer; {parameter of the current command}
+@!k:integer; {loop index}
+@!bad_char:boolean; {has a non-ASCII character code appeared in this \\{xxx}?}
+@!pure:boolean; {is the command error-free?}
+@!vvv:integer; {|v|, rounded to the nearest pixel}
+begin pure:=true;
+case o of
+@t\4@>@<Cases for vertical motion@>@;
+@t\4@>@<Cases for fonts@>@;
+four_cases(xxx1): @<Translate an |xxx| command and |goto done|@>;
+pre: begin error('preamble command within a page!'); goto 9998;
+ end;
+@.preamble command within a page@>
+post,post_post: begin error('postamble command within a page!'); goto 9998;
+@.postamble command within a page@>
+ end;
+othercases begin error('undefined command ',o:1,'!');
+ goto done;
+@.undefined command@>
+ end
+endcases;
+move_down: @<Finish a command that sets |v:=v+p|, then |goto done|@>;
+change_font: @<Finish a command that changes the current font,
+ then |goto done|@>;
+9998: pure:=false;
+done: special_cases:=pure;
+end;
+
+@ @<Cases for commands |nop|, |bop|, \dots, |pop|@>=
+nop: begin minor('nop'); goto done;
+ end;
+bop: begin error('bop occurred before eop!'); goto 9998;
+@.bop occurred before eop@>
+ end;
+eop: begin major('eop');
+ if s<>0 then error('stack not empty at end of page (level ',
+ s:1,')!');
+@.stack not empty...@>
+ do_page:=true; print_ln(' '); goto 9999;
+ end;
+push: begin major('push');
+ if s=max_s_so_far then
+ begin max_s_so_far:=s+1;
+ if s=max_s then error('deeper than claimed in postamble!');
+@.deeper than claimed...@>
+@.push deeper than claimed...@>
+ if s=stack_size then
+ begin error('DVItype capacity exceeded (stack size=',
+ stack_size:1,')'); goto 9998;
+ end;
+ end;
+ hstack[s]:=h; vstack[s]:=v; wstack[s]:=w;
+ xstack[s]:=x; ystack[s]:=y; zstack[s]:=z;
+ hhstack[s]:=hh; vvstack[s]:=vv; incr(s); ss:=s-1; goto show_state;
+ end;
+pop: begin major('pop');
+ if s=0 then error('(illegal at level zero)!')
+ else begin decr(s); hh:=hhstack[s]; vv:=vvstack[s];
+ h:=hstack[s]; v:=vstack[s]; w:=wstack[s];
+ x:=xstack[s]; y:=ystack[s]; z:=zstack[s];
+ end;
+ ss:=s; goto show_state;
+ end;
+
+@ Rounding to the nearest pixel is best done in the manner shown here, so as
+to be inoffensive to the eye: When the horizontal motion is small, like a
+kern, |hh| changes by rounding the kern; but when the motion is large, |hh|
+changes by rounding the true position |h| so that accumulated rounding errors
+disappear. We allow a larger space in the negative direction than in
+the positive one, because \TeX\ makes comparatively
+large backspaces when it positions accents.
+
+@d out_space(#)==if (p>=font_space[cur_font])or(p<=-4*font_space[cur_font]) then
+ begin out_text(" "); hh:=pixel_round(h+p);
+ end
+ else hh:=hh+pixel_round(p);
+ minor(#,' ',p:1); q:=p; goto move_right
+
+@<Cases for horizontal motion@>=
+four_cases(right1):begin out_space('right',o-right1+1:1);
+ end;
+w0,four_cases(w1):begin w:=p; out_space('w',o-w0:1);
+ end;
+x0,four_cases(x1):begin x:=p; out_space('x',o-x0:1);
+ end;
+
+@ Vertical motion is done similarly, but with the threshold between
+``small'' and ``large'' increased by a factor of five. The idea is to make
+fractions like ``$1\over2$'' round consistently, but to absorb accumulated
+rounding errors in the baseline-skip moves.
+
+@d out_vmove(#)==if abs(p)>=5*font_space[cur_font] then vv:=pixel_round(v+p)
+ else vv:=vv+pixel_round(p);
+ major(#,' ',p:1); goto move_down
+
+@<Cases for vertical motion@>=
+four_cases(down1):begin out_vmove('down',o-down1+1:1);
+ end;
+y0,four_cases(y1):begin y:=p; out_vmove('y',o-y0:1);
+ end;
+z0,four_cases(z1):begin z:=p; out_vmove('z',o-z0:1);
+ end;
+
+@ @<Cases for fonts@>=
+sixty_four_cases(fnt_num_0): begin major('fntnum',p:1);
+ goto change_font;
+ end;
+four_cases(fnt1): begin major('fnt',o-fnt1+1:1,' ',p:1);
+ goto change_font;
+ end;
+four_cases(fnt_def1): begin major('fntdef',o-fnt_def1+1:1,' ',p:1);
+ define_font(p); goto done;
+ end;
+
+@ @<Translate an |xxx| command and |goto done|@>=
+begin major('xxx '''); bad_char:=false;
+if p<0 then error('string of negative length!');
+@.string of negative length@>
+for k:=1 to p do
+ begin q:=get_byte;
+ if (q<" ")or(q>"~") then bad_char:=true;
+ if showing then print(xchr[q]);
+ end;
+if showing then print('''');
+if bad_char then error('non-ASCII character in xxx command!');
+@.non-ASCII character...@>
+goto done;
+end
+
+@ @<Translate a |set_char|...@>=
+begin if (o>" ")and(o<="~") then
+ begin out_text(p); minor('setchar',p:1);
+ end
+else major('setchar',p:1);
+goto fin_set;
+end
+
+@ @<Finish a command that either sets or puts a character...@>=
+{if p<0 then p:=255-((-1-p) mod 256)
+ else if p>=256 then p:=p mod 256;} {width computation for oriental fonts}
+@^oriental characters@>@^Chinese characters@>@^Japanese characters@>
+if (p<font_bc[cur_font])or(p>font_ec[cur_font]) then q:=invalid_width
+else q:=char_width(cur_font)(p);
+if q=invalid_width then
+ begin error('character ',p:1,' invalid in font ');
+@.character $c$ invalid...@>
+ print_font(cur_font);
+ if cur_font<>invalid_font then
+ print('!'); {the invalid font has `\.!' in its name}
+ end;
+if o>=put1 then goto done;
+if q=invalid_width then q:=0
+else hh:=hh+char_pixel_width(cur_font)(p);
+goto move_right
+
+@ @<Finish a command that either sets or puts a rule...@>=
+q:=signed_quad;
+if showing then
+ begin print(' height ',p:1,', width ',q:1);
+ if out_mode>mnemonics_only then
+ if (p<=0)or(q<=0) then print(' (invisible)')
+ else print(' (',rule_pixels(p):1,'x',rule_pixels(q):1,' pixels)');
+ end;
+if o=put_rule then goto done;
+if showing then if out_mode>mnemonics_only then print_ln(' ');
+hh:=hh+rule_pixels(q); goto move_right
+
+@ A sequence of consecutive rules, or consecutive characters in a fixed-width
+font whose width is not an integer number of pixels, can cause |hh| to drift
+far away from a correctly rounded value. \.{DVItype} ensures that the
+amount of drift will never exceed |max_drift| pixels.
+
+Since \.{DVItype} is intended to diagnose strange errors, it checks
+carefully to make sure that |h| and |v| do not get out of range.
+Normal \.{DVI}-reading programs need not do this.
+
+@d infinity==@'17777777777 {$\infty$ (approximately)}
+@d max_drift=2 {we insist that abs|(hh-pixel_round(h))<=max_drift|}
+
+@<Finish a command that sets |h:=h+q|, then |goto done|@>=
+if (h>0)and(q>0) then if h>infinity-q then
+ begin error('arithmetic overflow! parameter changed from ',
+@.arithmetic overflow...@>
+ q:1,' to ',infinity-h:1);
+ q:=infinity-h;
+ end;
+if (h<0)and(q<0) then if -h>q+infinity then
+ begin error('arithmetic overflow! parameter changed from ',
+ q:1, ' to ',(-h)-infinity:1);
+ q:=(-h)-infinity;
+ end;
+hhh:=pixel_round(h+q);
+if abs(hhh-hh)>max_drift then
+ if hhh>hh then hh:=hhh-max_drift
+ else hh:=hhh+max_drift;
+if showing then if out_mode>mnemonics_only then
+ begin print(' h:=',h:1);
+ if q>=0 then print('+');
+ print(q:1,'=',h+q:1,', hh:=',hh:1);
+ end;
+h:=h+q;
+if abs(h)>max_h_so_far then
+ begin if abs(h)>max_h+99 then
+ begin error('warning: |h|>',max_h:1,'!');
+@.warning: |h|...@>
+ max_h:=abs(h);
+ end;
+ max_h_so_far:=abs(h);
+ end;
+goto done
+
+@ @<Finish a command that sets |v:=v+p|, then |goto done|@>=
+if (v>0)and(p>0) then if v>infinity-p then
+ begin error('arithmetic overflow! parameter changed from ',
+@.arithmetic overflow...@>
+ p:1,' to ',infinity-v:1);
+ p:=infinity-v;
+ end;
+if (v<0)and(p<0) then if -v>p+infinity then
+ begin error('arithmetic overflow! parameter changed from ',
+ p:1, ' to ',(-v)-infinity:1);
+ p:=(-v)-infinity;
+ end;
+vvv:=pixel_round(v+p);
+if abs(vvv-vv)>max_drift then
+ if vvv>vv then vv:=vvv-max_drift
+ else vv:=vvv+max_drift;
+if showing then if out_mode>mnemonics_only then
+ begin print(' v:=',v:1);
+ if p>=0 then print('+');
+ print(p:1,'=',v+p:1,', vv:=',vv:1);
+ end;
+v:=v+p;
+if abs(v)>max_v_so_far then
+ begin if abs(v)>max_v+99 then
+ begin error('warning: |v|>',max_v:1,'!');
+@.warning: |v|...@>
+ max_v:=abs(v);
+ end;
+ max_v_so_far:=abs(v);
+ end;
+goto done
+
+@ @<Show the values of |ss|, |h|, |v|, |w|, |x|, |y|, |z|...@>=
+if showing then if out_mode>mnemonics_only then
+ begin print_ln(' ');
+ print('level ',ss:1,':(h=',h:1,',v=',v:1,
+ ',w=',w:1,',x=',x:1,',y=',y:1,',z=',z:1,
+ ',hh=',hh:1,',vv=',vv:1,')');
+ end;
+goto done
+
+@ @<Finish a command that changes the current font...@>=
+font_num[nf]:=p; cur_font:=0;
+while font_num[cur_font]<>p do incr(cur_font);
+if cur_font=nf then
+ begin cur_font:=invalid_font;
+ error('invalid font selection: font ',p:1,' was never defined!');
+ end;
+if showing then if out_mode>mnemonics_only then
+ begin print(' current font is '); print_font(cur_font);
+ end;
+goto done
+
+@* Skipping pages.
+A routine that's much simpler than |do_page| is used to pass over
+pages that are not being translated. The |skip_pages| subroutine
+is assumed to begin just after the preamble has been read, or just
+after a |bop| has been processed. It continues until either finding a
+|bop| that matches the desired starting page specifications, or until
+running into the postamble.
+
+@p @t\4@>@<Declare the procedure called |scan_bop|@>@;
+procedure skip_pages(@!bop_seen:boolean);
+label 9999; {end of this subroutine}
+var p:integer; {a parameter}
+@!k:0..255; {command code}
+@!down_the_drain:integer; {garbage}
+begin showing:=false;
+while true do
+ begin if not bop_seen then
+ begin scan_bop;
+ if in_postamble then goto 9999;
+ if not started then if start_match then
+ begin started:=true; goto 9999;
+ end;
+ end;
+ @<Skip until finding |eop|@>;
+ bop_seen:=false;
+ end;
+9999:end;
+
+@ @<Skip until finding |eop|@>=
+repeat if eof(dvi_file) then bad_dvi('the file ended prematurely');
+@.the file ended prematurely@>
+ k:=get_byte;
+ p:=first_par(k);
+ case k of
+ set_rule,put_rule: down_the_drain:=signed_quad;
+ four_cases(fnt_def1): begin define_font(p);
+ print_ln(' ');
+ end;
+ four_cases(xxx1): while p>0 do
+ begin down_the_drain:=get_byte; decr(p);
+ end;
+ bop,pre,post,post_post,undefined_commands:
+ bad_dvi('illegal command at byte ',cur_loc-1:1);
+@.illegal command at byte n@>
+ othercases do_nothing
+ endcases;
+until k=eop;
+
+@ Global variables called |old_backpointer| and |new_backpointer|
+are used to check whether the back pointers are properly set up.
+Another one tells whether we have already found the starting page.
+
+@<Glob...@>=
+@!old_backpointer:integer; {the previous |bop| command location}
+@!new_backpointer:integer; {the current |bop| command location}
+@!started:boolean; {has the starting page been found?}
+
+@ @<Set init...@>=
+old_backpointer:=-1; started:=false;
+
+@ The |scan_bop| procedure reads \.{DVI} commands following the preamble
+or following |eop|, until finding either |bop| or the postamble.
+
+@<Declare the procedure called |scan_bop|@>=
+procedure scan_bop;
+var k:0..255; {command code}
+begin repeat if eof(dvi_file) then bad_dvi('the file ended prematurely');
+@.the file ended prematurely@>
+ k:=get_byte;
+ if (k>=fnt_def1)and(k<fnt_def1+4) then
+ begin define_font(first_par(k)); k:=nop;
+ end;
+until k<>nop;
+if k=post then in_postamble:=true
+else begin if k<>bop then bad_dvi('byte ',cur_loc-1:1,' is not bop');
+@.byte n is not bop@>
+ new_backpointer:=cur_loc-1; incr(page_count);
+ for k:=0 to 9 do count[k]:=signed_quad;
+ if signed_quad<>old_backpointer
+ then print_ln('backpointer in byte ',cur_loc-4:1,
+ ' should be ',old_backpointer:1,'!');
+@.backpointer...should be p@>
+ old_backpointer:=new_backpointer;
+ end;
+end;
+
+@* Using the backpointers.
+The routines in this section of the program are brought into play only
+if |random_reading| is |true| (and only if |out_mode=the_works|).
+First comes a routine that illustrates how to find the postamble quickly.
+
+@<Find the postamble, working back from the end@>=
+n:=dvi_length;
+if n<53 then bad_dvi('only ',n:1,' bytes long');
+@.only n bytes long@>
+m:=n-4;
+repeat if m=0 then bad_dvi('all 223s');
+@.all 223s@>
+move_to_byte(m); k:=get_byte; decr(m);
+until k<>223;
+if k<>id_byte then bad_dvi('ID byte is ',k:1);
+@.ID byte is wrong@>
+move_to_byte(m-3); q:=signed_quad;
+if (q<0)or(q>m-33) then bad_dvi('post pointer ',q:1,' at byte ',m-3:1);
+@.post pointer is wrong@>
+move_to_byte(q); k:=get_byte;
+if k<>post then bad_dvi('byte ',q:1,' is not post');
+@.byte n is not post@>
+post_loc:=q; first_backpointer:=signed_quad
+
+@ Note that the last steps of the above code save the locations of the
+the |post| byte and the final |bop|. We had better declare these global
+variables, together with two more that we will need shortly.
+
+@<Glob...@>=
+@!post_loc:integer; {byte location where the postamble begins}
+@!first_backpointer:integer; {the pointer following |post|}
+@!start_loc:integer; {byte location of the first page to process}
+@!after_pre:integer; {byte location immediately following the preamble}
+
+@ The next little routine shows how the backpointers can be followed
+to move through a \.{DVI} file in reverse order. Ordinarily a \.{DVI}-reading
+program would do this only if it wants to print the pages backwards or
+if it wants to find a specified starting page that is not necessarily the
+first page in the file; otherwise it would of course be simpler and faster
+just to read the whole file from the beginning.
+
+@<Count the pages and move to the starting page@>=
+q:=post_loc; p:=first_backpointer; start_loc:=-1;
+if p<0 then in_postamble:=true
+else begin repeat
+ {now |q| points to a |post| or |bop| command; |p>=0| is prev pointer}
+ if p>q-46 then
+ bad_dvi('page link ',p:1,' after byte ',q:1);
+@.page link wrong...@>
+ q:=p; move_to_byte(q); k:=get_byte;
+ if k=bop then incr(page_count)
+ else bad_dvi('byte ',q:1,' is not bop');
+@.byte n is not bop@>
+ for k:=0 to 9 do count[k]:=signed_quad;
+ p:=signed_quad;
+ if start_match then
+ begin start_loc:=q; old_backpointer:=p;
+ end;
+ until p<0;
+ if start_loc<0 then abort('starting page number could not be found!');
+@.starting page number...@>
+ if old_backpointer<0 then start_loc:=after_pre; {we want to check everything}
+ move_to_byte(start_loc);
+ end;
+if page_count<>total_pages then
+ print_ln('there are really ',page_count:1,' pages, not ',total_pages:1,'!')
+@.there are really n pages@>
+
+@* Reading the postamble.
+Now imagine that we are reading the \.{DVI} file and positioned just
+four bytes after the |post| command. That, in fact, is the situation,
+when the following part of \.{DVItype} is called upon to read, translate,
+and check the rest of the postamble.
+
+@p procedure read_postamble;
+var k:integer; {loop index}
+@!p,@!q,@!m:integer; {general purpose registers}
+begin showing:=false; post_loc:=cur_loc-5;
+print_ln('Postamble starts at byte ',post_loc:1,'.');
+@.Postamble starts at byte n@>
+if signed_quad<>numerator then
+ print_ln('numerator doesn''t match the preamble!');
+@.numerator doesn't match@>
+if signed_quad<>denominator then
+ print_ln('denominator doesn''t match the preamble!');
+@.denominator doesn't match@>
+if signed_quad<>mag then if new_mag=0 then
+ print_ln('magnification doesn''t match the preamble!');
+@.magnification doesn't match@>
+max_v:=signed_quad; max_h:=signed_quad;@/
+print('maxv=',max_v:1,', maxh=',max_h:1);@/
+max_s:=get_two_bytes; total_pages:=get_two_bytes;@/
+print_ln(', maxstackdepth=',max_s:1,', totalpages=',total_pages:1);
+if out_mode<the_works then
+ @<Compare the \\{lust} parameters with the accumulated facts@>;
+@<Process the font definitions of the postamble@>;
+@<Make sure that the end of the file is well-formed@>;
+end;
+
+@ No warning is given when |max_h_so_far| exceeds |max_h| by less than~100,
+since 100 units is invisibly small; it's approximately the wavelength of
+visible light, in the case of \TeX\ output. Rounding errors can be expected
+to make |h| and |v| slightly more than |max_h| and |max_v|, every once in
+a~while; hence small discrepancies are not cause for alarm.
+
+@<Compare the \\{lust}...@>=
+begin if max_v+99<max_v_so_far then
+ print_ln('warning: observed maxv was ',max_v_so_far:1);
+@.warning: observed maxv...@>
+@.observed maxv was x@>
+if max_h+99<max_h_so_far then
+ print_ln('warning: observed maxh was ',max_h_so_far:1);
+@.warning: observed maxh...@>
+@.observed maxh was x@>
+if max_s<max_s_so_far then
+ print_ln('warning: observed maxstackdepth was ',max_s_so_far:1);
+@.warning: observed maxstack...@>
+@.observed maxstackdepth was x@>
+if page_count<>total_pages then
+ print_ln('there are really ',page_count:1,' pages, not ',total_pages:1,'!');
+end
+@.there are really n pages@>
+
+@ When we get to the present code, the |post_post| command has
+just been read.
+
+@<Make sure that the end of the file is well-formed@>=
+q:=signed_quad;
+if q<>post_loc then
+ print_ln('bad postamble pointer in byte ',cur_loc-4:1,'!');
+@.bad postamble pointer@>
+m:=get_byte;
+if m<>id_byte then print_ln('identification in byte ',cur_loc-1:1,
+@.identification...should be n@>
+ ' should be ',id_byte:1,'!');
+k:=cur_loc; m:=223;
+while (m=223)and not eof(dvi_file) do m:=get_byte;
+if not eof(dvi_file) then bad_dvi('signature in byte ',cur_loc-1:1,
+@.signature...should be...@>
+ ' should be 223')
+else if cur_loc<k+4 then
+ print_ln('not enough signature bytes at end of file (',
+@.not enough signature bytes...@>
+ cur_loc-k:1,')');
+
+@ @<Process the font definitions...@>=
+repeat k:=get_byte;
+if (k>=fnt_def1)and(k<fnt_def1+4) then
+ begin p:=first_par(k); define_font(p); print_ln(' '); k:=nop;
+ end;
+until k<>nop;
+if k<>post_post then
+ print_ln('byte ',cur_loc-1:1,' is not postpost!')
+@.byte n is not postpost@>
+
+@* The main program.
+Now we are ready to put it all together. This is where \.{DVItype} starts,
+and where it ends.
+
+@p begin initialize; {get all variables initialized}
+dialog; {set up all the options}
+@<Process the preamble@>;
+if out_mode=the_works then {|random_reading=true|}
+ begin @<Find the postamble, working back from the end@>;
+ in_postamble:=true; read_postamble; in_postamble:=false;
+ @<Count the pages and move to the starting page@>;
+ end;
+skip_pages(false);
+if not in_postamble then @<Translate up to |max_pages| pages@>;
+if out_mode<the_works then
+ begin if not in_postamble then skip_pages(true);
+ if signed_quad<>old_backpointer then
+ print_ln('backpointer in byte ',cur_loc-4:1,
+ ' should be ',old_backpointer:1,'!');
+@.backpointer...should be p@>
+ read_postamble;
+ end;
+final_end:end.
+
+@ The main program needs a few global variables in order to do its work.
+
+@<Glob...@>=
+@!k,@!m,@!n,@!p,@!q:integer; {general purpose registers}
+
+@ A \.{DVI}-reading program that reads the postamble first need not look at the
+preamble; but \.{DVItype} looks at the preamble in order to do error
+checking, and to display the introductory comment.
+
+@<Process the preamble@>=
+open_dvi_file;
+p:=get_byte; {fetch the first byte}
+if p<>pre then bad_dvi('First byte isn''t start of preamble!');
+@.First byte isn't...@>
+p:=get_byte; {fetch the identification byte}
+if p<>id_byte then
+ print_ln('identification in byte 1 should be ',id_byte:1,'!');
+@.identification...should be n@>
+@<Compute the conversion factors@>;
+p:=get_byte; {fetch the length of the introductory comment}
+print('''');
+while p>0 do
+ begin decr(p); print(xchr[get_byte]);
+ end;
+print_ln('''');
+after_pre:=cur_loc
+
+@ The conversion factor |conv| is figured as follows: There are exactly
+|n/d| decimicrons per \.{DVI} unit, and 254000 decimicrons per inch,
+and |resolution| pixels per inch. Then we have to adjust this
+by the stated amount of magnification.
+
+@<Compute the conversion factors@>=
+numerator:=signed_quad; denominator:=signed_quad;
+if numerator<=0 then bad_dvi('numerator is ',numerator:1);
+@.numerator is wrong@>
+if denominator<=0 then bad_dvi('denominator is ',denominator:1);
+@.denominator is wrong@>
+print_ln('numerator/denominator=',numerator:1,'/',denominator:1);
+tfm_conv:=(25400000.0/numerator)*(denominator/473628672)/16.0;
+conv:=(numerator/254000.0)*(resolution/denominator);
+mag:=signed_quad;
+if new_mag>0 then mag:=new_mag
+else if mag<=0 then bad_dvi('magnification is ',mag:1);
+@.magnification is wrong@>
+true_conv:=conv; conv:=true_conv*(mag/1000.0);
+print_ln('magnification=',mag:1,'; ',conv:16:8,' pixels per DVI unit')
+
+@ The code shown here uses a convention that has proved to be useful:
+If the starting page was specified as, e.g., `\.{1.*.-5}', then
+all page numbers in the file are displayed by showing the values of
+counts 0, 1, and~2, separated by dots. Such numbers can, for example,
+be displayed on the console of a printer when it is working on that
+page.
+
+@<Translate up to...@>=
+begin while max_pages>0 do
+ begin decr(max_pages);
+ print_ln(' '); print(cur_loc-45:1,': beginning of page ');
+ for k:=0 to start_vals do
+ begin print(count[k]:1);
+ if k<start_vals then print('.')
+ else print_ln(' ');
+ end;
+ if not do_page then bad_dvi('page ended unexpectedly');
+@.page ended unexpectedly@>
+ scan_bop;
+ if in_postamble then goto done;
+ end;
+done:end
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{DVItype} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.
diff --git a/Build/source/texk/web2c/omegaware/ofm2opl.ch b/Build/source/texk/web2c/omegaware/ofm2opl.ch
new file mode 100644
index 00000000000..830fee4d04c
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ofm2opl.ch
@@ -0,0 +1,461 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tftopl.ch.
+%
+% tftopl.ch for C compilation with web2c.
+%
+% 04/04/83 (PC) Original version, made to work with version 1.0 of TFtoPL,
+% released with version 0.96 of TeX in February, 1983.
+% 04/16/83 (PC) Brought up to version 1.0 released with version 0.97 of TeX
+% in April, 1983.
+% 06/30/83 (HWT) Revised changefile format, for use with version 1.7 Tangle.
+% 07/28/83 (HWT) Brought up to version 2
+% 11/21/83 (HWT) Brought up to version 2.1
+% 03/24/84 (HWT) Brought up to version 2.2
+% 07/12/84 (HWT) Brought up to version 2.3
+% 07/05/87 (ETM) Brought up to version 2.5
+% 03/22/88 (ETM) Converted for use with WEB to C.
+% 11/30/89 (KB) Version 3.
+% 01/16/90 (SR) Version 3.1.
+% (more recent changes in the ChangeLog)
+
+@x [0] WEAVE: print changes only.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+%\let\maybe=\iffalse
+%\def\title{TF\lowercase{to}PL changes for C}
+@z
+
+% [2] Fix files in program statement. We need to tell web2c about one
+% special variable. Perhaps it would be better to allow @define's
+% anywhere in a source file, but that seemed just as painful as this.
+@x
+@p program OFM2OPL(@!tfm_file,@!pl_file,@!output);
+@y
+@p
+{Tangle doesn't recognize @@ when it's right after the \.=.}
+@\@= @@define var tfm;@>@\
+program OFM2OPL(@!tfm_file,@!pl_file,@!output);
+@z
+
+@x [still 2] Don't print banner until later (and unless verbose).
+procedure initialize; {this procedure gets things started properly}
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ begin
+ kpse_set_progname (argv[0]);
+ kpse_init_prog ('OFM2OPL', 0, nil, nil);
+ {We |xrealloc| when we know how big the file is. The 1000 comes
+ from the negative lower bound.}
+ tfm_file_array := cast_to_byte_pointer (xmalloc (2000000));
+ parse_arguments;
+@z
+
+%@x [5] Increase sizes to match vptovf.
+%@!tfm_size=30000; {maximum length of |tfm| data, in bytes}
+%@!lig_size=5000; {maximum length of |lig_kern| program, in words}
+%@!hash_size=5003; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@y
+%@!tfm_size=40000; {maximum length of |tfm| data, in bytes}
+%@!lig_size=8000; {maximum length of |lig_kern| program, in words ($<2^{15}$)}
+%@!hash_size=8009; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@z
+
+@x [7] Open the TFM file.
+@ On some systems you may have to do something special to read a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+reset(tfm_file);
+@y
+@ On some systems you may have to do something special to read a
+packed file of bytes. With C under Unix, we just open the file by name
+and read characters from it.
+
+@<Set init...@>=
+tfm_file := kpse_open_file (tfm_name, kpse_ofm_format);
+if verbose then begin
+ print (banner);
+ print_ln (version_string);
+end;
+@z
+
+@x [17] Open the PL file.
+@!pl_file:text;
+
+@ @<Set init...@>=
+rewrite(pl_file);
+@y
+@!pl_file:text;
+
+@ If an explicit filename isn't given, we write to |stdout|.
+
+@<Set init...@>=
+if optind + 1 = argc then begin
+ pl_file := stdout;
+end else begin
+ pl_name := extend_filename (cmdline (optind + 1), 'opl');
+ rewrite (pl_file, pl_name);
+end;
+@z
+
+@x [18,19] Make |tfm| be dynamically allocated, and rename `index'.
+@<Types...@>=
+@!byte=0..255; {unsigned eight-bit quantity}
+@!index=-1000..tfm_size; {address of a byte in |tfm|}
+@!char_type=0..65535;
+@!xchar_type=0..65536;
+@!xxchar_type=0..65537;
+@!xxxchar_type=0..65538;
+
+@
+@<Glob...@>=
+@!tfm:array [-1000..tfm_size] of byte; {the input data all goes here}
+@y
+@d index == index_type
+
+@<Types...@>=
+@!byte=0..255; {unsigned eight-bit quantity}
+@!index=integer; {address of a byte in |tfm|}
+@!char_type=0..65535;
+@!xchar_type=0..65536;
+@!xxchar_type=0..65537;
+@!xxxchar_type=0..65538;
+
+@ CHECK OUT tfm array ranges.
+@<Glob...@>=
+{Kludge here to define |tfm| as a macro which takes care of the negative
+ lower bound. We've defined |tfm| for the benefit of web2c above.}
+@=#define tfm (tfmfilearray + 1001);@>@\
+@!tfm_file_array: pointer_to_byte; {the input data all goes here}
+@z
+
+@x [20] Send error output to stderr.
+@d abort(#)==begin print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OFM?');
+@y
+@d abort(#)==begin write_ln(stderr, #);
+ write_ln(stderr, 'Sorry, but I can''t go on; are you sure this is a OFM?');
+@z
+
+@x [20] Allow arbitrarily large input files.
+if 4*lf-1>tfm_size then abort('The file is bigger than I can handle!');
+@.The file is bigger...@>
+@y
+{|tfm_file_array
+ := cast_to_byte_pointer (xrealloc (tfm_file_array, 4 * lf - 1 + 1108));|}
+@z
+
+% [27, 28] Change strings to C char pointers. The Pascal strings are
+% indexed starting at 1, so we pad with a blank.
+@x
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+@y
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: c_string;
+ {strings for output in the user's external character set}
+@!ASCII_all: packed array[0..256] of char;
+@!MBL_string,@!RI_string,@!RCE_string: c_string;
+ {handy string constants for |face| codes}
+@z
+
+@x
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:='0123456789ABCDEF';@/
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+@y
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:=' @@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:=' `abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:=' 0123456789ABCDEF';@/
+strcpy (ASCII_all, ASCII_04);
+strcat (ASCII_all, '@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_');
+strcat (ASCII_all, '`abcdefghijklmnopqrstuvwxyz{|}~');@/
+MBL_string:=' MBL'; RI_string:=' RI '; RCE_string:=' RCE';
+@z
+
+% [38] How we output the character code depends on |charcode_format|.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+begin if font_type>vanilla then
+ out_hex_char(c)
+else if (c>="0")and(c<="9") then
+ out(' C ',c-"0":1)
+else if (c>="A")and(c<="Z") then
+ out(' C ',ASCII_10[c-"A"+2])
+else if (c>="a")and(c<="z") then
+ out(' C ',ASCII_14[c-"a"+2])
+else out_hex_char(c);
+@y
+begin if (font_type > vanilla) or (charcode_format = charcode_hex) then
+ out_hex_char(c)
+else if (charcode_format = charcode_ascii) and (c > " ") and (c <= "~")
+ and (c <> "(") and (c <> ")") then
+ out(' C ', ASCII_all[c - " " + 1])
+{default case, use hex}
+else out_hex_char(c);
+@z
+
+% [39] Don't output the face code as an integer.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+ out(MBL_string[1+(b mod 3)]);
+ out(RI_string[1+s]);
+ out(RCE_string[1+(b div 3)]);
+@y
+ put_byte(MBL_string[1+(b mod 3)], pl_file);
+ put_byte(RI_string[1+s], pl_file);
+ put_byte(RCE_string[1+(b div 3)], pl_file);
+@z
+
+@x [40] Force 32-bit constant arithmetic for 16-bit machines.
+f:=((tfm[k+1] mod 16)*@'400+tfm[k+2])*@'400+tfm[k+3];
+@y
+f:=((tfm[k+1] mod 16)*intcast(@'400)+tfm[k+2])*@'400+tfm[k+3];
+@z
+
+% [78] No progress reports unless verbose.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+ incr(chars_on_line);
+ end;
+ if no_repeats(c)>0 then begin
+ print_hex(c); print('-'); print_hex(c+no_repeats(c));
+ left; out('CHARREPEAT'); out_char(c); out_char(no_repeats(c)); out_ln;
+ end
+ else begin
+ print_hex(c); {progress report}
+ left; out('CHARACTER'); out_char(c); out_ln;
+ end;
+@y
+ if verbose then incr(chars_on_line);
+ end;
+ if no_repeats(c)>0 then begin
+ if verbose then begin
+ print_hex(c); print('-'); print_hex(c+no_repeats(c));
+ end;
+ left; out('CHARREPEAT'); out_char(c); out_char(no_repeats(c)); out_ln;
+ end
+ else begin
+ if verbose then print_hex(c); {progress report}
+ left; out('CHARACTER'); out_char(c); out_ln;
+ end;
+@z
+
+% [89] Change the name of the variable `class', since AIX 3.1's <math.h>
+% defines a function by that name.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@d pending=4 {$f(x,y)$ is being evaluated}
+@y
+@d pending=4 {$f(x,y)$ is being evaluated}
+
+@d class == class_var
+@z
+
+% [90] Change name of the function `f'.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+ r:=f(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+@y
+ r:=f_fn(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+@z
+
+% [94] web2c can't handle these mutually recursive procedures.
+% But let's do a fake definition of f here, so that it gets into web2c's
+% symbol table. We also have to change the name, because there is also a
+% variable named `f', and some C compilers can't deal with that.
+@x
+@p function f(@!h,@!x,@!y:index):index; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+@y
+@p
+ifdef('notdef')
+function f_fn(@!h,@!x,@!y:index):index; begin end;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+endif('notdef')
+@z
+@x
+else eval:=f(h,x,y);
+@y
+else eval:=f_fn(h,x,y);
+@z
+
+% [95] The real definition of f.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@p function f;
+@y
+@p function f_fn(@!h,@!x,@!y:index):index;
+@z
+@x
+f:=lig_z[h];
+@y
+f_fn:=lig_z[h];
+@z
+
+% [99] No final newline unless verbose.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+do_characters; print_ln('.');@/
+@y
+do_characters; if verbose then print_ln('.');@/
+@z
+
+@x [100] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TFtoPL} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 4; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Initialize the option variables@>;
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('ofm2opl');
+
+ end else if argument_is ('help') then begin
+ usage_help (OFM2OPL_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end else if argument_is ('charcode-format') then begin
+ if strcmp (optarg, 'ascii') = 0 then
+ charcode_format := charcode_ascii
+ else if strcmp (optarg, 'hex') = 0 then
+ charcode_format := charcode_hex
+ else
+ write_ln (stderr, 'Bad character code format', optarg, '.');
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc) then begin
+ write_ln (stderr, 'ofm2opl: Need one or two file arguments.');
+ usage ('ofm2opl');
+ end;
+
+ tfm_name := cmdline (optind);
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Print progress information?
+@.-verbose@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'verbose';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := address_of (verbose);
+long_options[current_option].val := 1;
+incr (current_option);
+
+@
+@<Glob...@> =
+@!verbose: c_int_type;
+
+@
+@<Initialize the option...@> =
+verbose := false;
+
+@ This option changes how we output character codes.
+@.-charcode-format@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'charcode-format';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ We use an ``enumerated'' type to store the information.
+
+@<Type...@> =
+@!charcode_format_type = charcode_ascii..charcode_default;
+
+@
+@<Const...@> =
+@!charcode_ascii = 0;
+@!charcode_hex = 1;
+@!charcode_default = 2;
+
+@
+@<Global...@> =
+@!charcode_format: charcode_format_type;
+
+@ It starts off as the default, which is hex for OFM2OPL.
+
+@<Initialize the option...@> =
+charcode_format := charcode_default;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Global...@> =
+@!tfm_name, @!pl_name:c_string;
+@z
diff --git a/Build/source/texk/web2c/omegaware/ofm2opl.web b/Build/source/texk/web2c/omegaware/ofm2opl.web
new file mode 100644
index 00000000000..d18931fd3a9
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ofm2opl.web
@@ -0,0 +1,2322 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--2000 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tftopl.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 0 was implemented in January 1982.
+% In February 1982 a new restriction on ligature steps was added.
+% In June 1982 the routines were divided into smaller pieces for IBM people,
+% and the result was designated "Version 1" in September 1982.
+% Slight changes were made in October, 1982, for version 0.6 of TeX.
+% Version 2 (July 1983) was released with TeX version 0.999.
+% Version 2.1 (September 1983) changed TEXINFO to FONTDIMEN.
+% Version 2.2 (February 1984) simplified decimal fraction output.
+% Version 2.3 (May 1984) fixed a bug when lh=17.
+% Version 2.4 (July 1984) fixed a bug involving unused ligature code.
+% Version 2.5 (September 1985) updated the standard codingscheme names.
+% Version 3 (October 1989) introduced new ligature capabilities.
+% Version 3.1 (November 1989) renamed z[] to lig_z[] for better portability.
+
+% Version 1.0 of OFM2OPL (December 1995) allows one to read OFM files.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{OFM2OPL}
+\def\contentspagenumber{201}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont OFM2OPL} processor}
+ \vskip 15pt
+ \centerline{(Version 1.11, February 2000)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ The preparation of the original report
+ by D. E. Knuth
+ was supported in part by the National Science
+ Foundation under grants IST-8201926 and MCS-8300984,
+ and by the System Development Foundation. `\TeX' is a
+ trademark of the American Mathematical Society.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{OFM2OPL} utility program converts $\Omega$ and \TeX\ font
+metric (``\.{TFM}'' and ``\.{OFM}'') files into equivalent
+property-list (``\.{PL}'' and ``\.{OPL}'') files. It also
+makes a thorough check of the given \.{TFM} or \.{OFM} file,
+using essentially the same algorithm as \TeX\ or $\Omega$. Thus
+if \TeX\ or $\Omega$ complains that a \.{TFM} or an \.{OFM}
+file is ``bad,'' this program will pinpoint the source or sources of
+badness. A \.{PL} or \.{OPL} file output by this program can be edited
+with a normal text editor, and the result can be converted back to \.{TFM}
+or \.{OFM} format using the companion program \.{OPLtoOFM}.
+
+The first \.{TFtoPL} program was designed by Leo Guibas in the summer of
+1978. Contributions by Frank Liang, Doug Wyatt, and Lyle Ramshaw
+also had a significant effect on the evolution of the present code.
+
+Extensions for an enhanced ligature mechanism were added by
+D. E. Knuth in 1989.
+
+Extensions to handle extended font metric files (``\.{OFM}'') were
+added by John Plaice in December 1995 and January 1996, resulting in
+the new program \.{OFM2OPL}. In the following documentation, all
+unchanged references to the \.{TFtoPL} program and to \.{TFM} and
+\.{PL} files also apply to the \.{OFM2OPL} program and to \.{OFM}
+and \.{OPL} files.
+
+The |banner| string defined here should be changed whenever \.{OFM2OPL}
+gets modified.
+
+@d banner=='This is OFM2OPL, Version 1.11'
+
+@ This program is written entirely in standard \PASCAL, except that
+it occasionally has lower case letters in strings that are output.
+Such letters can be converted to upper case if necessary. The input is read
+from |tfm_file|, and the output is written on |pl_file|; error messages and
+other remarks are written on the |output| file, which the user may
+choose to assign to the terminal if the system permits it.
+@^system dependencies@>
+
+The term |print| is used instead of |write| when this program writes on
+the |output| file, so that all such output can be easily deflected.
+
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+
+@p program OFM2OPL(@!tfm_file,@!pl_file,@!output);
+label @<Labels in the outer block@>@/
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+procedure initialize; {this procedure gets things started properly}
+ begin print_ln(banner);@/
+ @<Set initial values@>@/
+ end;
+
+@ If the program has to stop prematurely, it goes to the
+`|final_end|'.
+
+@d final_end=9999 {label for the end of it all}
+
+@<Labels...@>=final_end;
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{TFtoPL}'s capacity.
+
+@<Constants...@>=
+@!tfm_size=2000000; {maximum length of |tfm| data, in bytes}
+@!lig_size=800000; {maximum length of |lig_kern| program, in words}
+@!hash_size=130003; {preferably a prime number, a bit larger than the number
+ of character pairs in lig/kern steps}
+@!hash_mult=16007; {another prime}
+@!max_char=65535; {the largest character number in a font}
+@!xmax_char=65536; {|max_char|+1}
+@!xxmax_char=65537;{|max_char|+2}
+@!xmax_label=80001;{must be greater than |max_lig_steps|}
+@!mem_size=262152; {|max_char|*4+8}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d do_nothing == {empty statement}
+
+@* Font metric data.
+The following description of \.{TFM} files is not sufficient for
+\.{OFM} files. The additional documentation necessary for the
+\.{OFM} files can be found in another file, such as the $\Omega$
+change files.
+
+The idea behind \.{TFM} files is that typesetting routines like \TeX\
+need a compact way to store the relevant information about several
+dozen fonts, and computer centers need a compact way to store the
+relevant information about several hundred fonts. \.{TFM} files are
+compact, and most of the information they contain is highly relevant,
+so they provide a solution to the problem.
+
+The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
+Since the number of bytes is always a multiple of 4, we could
+also regard the file as a sequence of 32-bit words; but \TeX\ uses the
+byte interpretation, and so does \.{TFtoPL}. Note that the bytes
+are considered to be unsigned numbers.
+
+@<Glob...@>=
+@!tfm_file:packed file of 0..255;
+
+@ On some systems you may have to do something special to read a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+reset(tfm_file);
+
+@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
+integers that give the lengths of the various subsequent portions
+of the file. These twelve integers are, in order:
+$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
+|@!lf|&length of the entire file, in words;\cr
+|@!lh|&length of the header data, in words;\cr
+|@!bc|&smallest character code in the font;\cr
+|@!ec|&largest character code in the font;\cr
+|@!nw|&number of words in the width table;\cr
+|@!nh|&number of words in the height table;\cr
+|@!nd|&number of words in the depth table;\cr
+|@!ni|&number of words in the italic correction table;\cr
+|@!nl|&number of words in the lig/kern table;\cr
+|@!nk|&number of words in the kern table;\cr
+|@!ne|&number of words in the extensible character table;\cr
+|@!np|&number of font parameter words.\cr}}$$
+They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
+|ne<=256|, and
+$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
+and as few as 0 characters (if |bc=ec+1|).
+
+Incidentally, when two or more 8-bit bytes are combined to form an integer of
+16 or more bits, the most significant bytes appear first in the file.
+This is called BigEndian order.
+
+@<Glob...@>=
+@!ofm_level,
+@!nco,@!ncw,@!npc,@!nki,@!nwi,@!nkf,@!nwf,@!nkr,@!nwr,@!nkg,@!nwg,@!nkp,@!nwp,
+@!nkm,@!nwm,@!real_lf,
+@!lf,@!lh,@!bc,@!ec,@!nw,@!nh,@!nd,@!ni,@!nl,@!nk,@!ne,@!np,@!font_dir:integer;
+ {subfile sizes}
+@!ofm_on:boolean;
+
+@ @<Set init...@>=
+ofm_on:=false; ofm_level:=-1; lf:=0; lh:=0;
+nco:=0; ncw:=0; npc:=0; bc:=0; ec:=0; nw:=0; nh:=0; nd:=0; ni:=0;
+nl:=0; nk:=0; ne:=0; np:=0;
+nki:=0; nwi:=0; nkf:=0; nwf:=0;
+nkm:=0; nwm:=0; real_lf:=0;
+nkr:=0; nwr:=0; nkg:=0; nwg:=0;
+nkp:=0; nwp:=0; font_dir:=0;
+
+@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
+arrays having the informal specification
+$$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2}
+\vbox{\halign{\hfil\\{#}&$\,:\,$\arr#\hfil\cr
+header&|[0..lh-1]stuff|\cr
+char\_info&|[bc..ec]char_info_word|\cr
+width&|[0..nw-1]fix_word|\cr
+height&|[0..nh-1]fix_word|\cr
+depth&|[0..nd-1]fix_word|\cr
+italic&|[0..ni-1]fix_word|\cr
+lig\_kern&|[0..nl-1]lig_kern_command|\cr
+kern&|[0..nk-1]fix_word|\cr
+exten&|[0..ne-1]extensible_recipe|\cr
+param&|[1..np]fix_word|\cr}}$$
+The most important data type used here is a |@!fix_word|, which is
+a 32-bit representation of a binary fraction. A |fix_word| is a signed
+quantity, with the two's complement of the entire word used to represent
+negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
+binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
+the smallest is $-2048$. We will see below, however, that all but one of
+the |fix_word| values will lie between $-16$ and $+16$.
+
+@ The first data array is a block of header information, which contains
+general facts about the font. The header must contain at least two words,
+and for \.{TFM} files to be used with Xerox printing software it must
+contain at least 18 words, allocated as described below. When different
+kinds of devices need to be interfaced, it may be necessary to add further
+words to the header block.
+
+\yskip\hang|header[0]| is a 32-bit check sum that \TeX\ will copy into the
+\.{DVI} output file whenever it uses the font. Later on when the \.{DVI}
+file is printed, possibly on another computer, the actual font that gets
+used is supposed to have a check sum that agrees with the one in the
+\.{TFM} file used by \TeX. In this way, users will be warned about
+potential incompatibilities. (However, if the check sum is zero in either
+the font file or the \.{TFM} file, no check is made.) The actual relation
+between this check sum and the rest of the \.{TFM} file is not important;
+the check sum is simply an identification number with the property that
+incompatible fonts almost always have distinct check sums.
+@^check sum@>
+
+\yskip\hang|header[1]| is a |fix_word| containing the design size of the
+font, in units of \TeX\ points (7227 \TeX\ points = 254 cm). This number
+must be at least 1.0; it is fairly arbitrary, but usually the design size
+is 10.0 for a ``10 point'' font, i.e., a font that was designed to look
+best at a 10-point size, whatever that really means. When a \TeX\ user
+asks for a font `\.{at} $\delta$ \.{pt}', the effect is to override the
+design size and replace it by $\delta$, and to multiply the $x$ and~$y$
+coordinates of the points in the font image by a factor of $\delta$
+divided by the design size. {\sl All other dimensions in the\/\ \.{TFM}
+file are |fix_word|\kern-1pt\ numbers in design-size units.} Thus, for example,
+the value of |param[6]|, one \.{em} or \.{\\quad}, is often the |fix_word|
+value $2^{20}=1.0$, since many fonts have a design size equal to one em.
+The other dimensions must be less than 16 design-size units in absolute
+value; thus, |header[1]| and |param[1]| are the only |fix_word| entries in
+the whole \.{TFM} file whose first byte might be something besides 0 or
+255. @^design size@>
+
+\yskip\hang|header[2..11]|, if present, contains 40 bytes that identify
+the character coding scheme. The first byte, which must be between 0 and
+39, is the number of subsequent ASCII bytes actually relevant in this
+string, which is intended to specify what character-code-to-symbol
+convention is present in the font. Examples are \.{ASCII} for standard
+ASCII, \.{TeX text} for fonts like \.{cmr10} and \.{cmti9}, \.{TeX math
+extension} for \.{cmex10}, \.{XEROX text} for Xerox fonts, \.{GRAPHIC} for
+special-purpose non-alphabetic fonts, \.{UNSPECIFIED} for the default case
+when there is no information. Parentheses should not appear in this name.
+(Such a string is said to be in {\mc BCPL} format.)
+@^coding scheme@>
+
+\yskip\hang|header[12..16]|, if present, contains 20 bytes that name the
+font family (e.g., \.{CMR} or \.{HELVETICA}), in {\mc BCPL} format.
+This field is also known as the ``font identifier.''
+@^family name@>
+@^font identifier@>
+
+\yskip\hang|header[17]|, if present, contains a first byte called the
+|seven_bit_safe_flag|, then two bytes that are ignored, and a fourth byte
+called the |face|. If the value of the fourth byte is less than 18, it has
+the following interpretation as a ``weight, slope, and expansion'': Add 0
+or 2 or 4 (for medium or bold or light) to 0 or 1 (for roman or italic) to
+0 or 6 or 12 (for regular or condensed or extended). For example, 13 is
+0+1+12, so it represents medium italic extended. A three-letter code
+(e.g., \.{MIE}) can be used for such |face| data.
+
+\yskip\hang|header[18..@twhatever@>]| might also be present; the individual
+words are simply called |header[18]|, |header[19]|, etc., at the moment.
+
+@ Next comes the |char_info| array, which contains one |char_info_word|
+per character. Each |char_info_word| contains six fields packed into
+four bytes as follows.
+
+\yskip\hang first byte: |width_index| (8 bits)\par
+\hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
+ (4~bits)\par
+\hang third byte: |italic_index| (6 bits) times 4, plus |tag|
+ (2~bits)\par
+\hang fourth byte: |remainder| (8 bits)\par
+\yskip\noindent
+The actual width of a character is |width[width_index]|, in design-size
+units; this is a device for compressing information, since many characters
+have the same width. Since it is quite common for many characters
+to have the same height, depth, or italic correction, the \.{TFM} format
+imposes a limit of 16 different heights, 16 different depths, and
+64 different italic corrections.
+
+Incidentally, the relation |width[0]=height[0]=depth[0]=italic[0]=0|
+should always hold, so that an index of zero implies a value of zero.
+The |width_index| should never be zero unless the character does
+not exist in the font, since a character is valid if and only if it lies
+between |bc| and |ec| and has a nonzero |width_index|.
+
+@ The |tag| field in a |char_info_word| has four values that explain how to
+interpret the |remainder| field.
+
+\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
+\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
+program starting at |lig_kern[remainder]|.\par
+\hang|tag=2| (|list_tag|) means that this character is part of a chain of
+characters of ascending sizes, and not the largest in the chain. The
+|remainder| field gives the character code of the next larger character.\par
+\hang|tag=3| (|ext_tag|) means that this character code represents an
+extensible character, i.e., a character that is built up of smaller pieces
+so that it can be made arbitrarily large. The pieces are specified in
+|exten[remainder]|.\par
+
+@d no_tag=0 {vanilla character}
+@d lig_tag=1 {character has a ligature/kerning program}
+@d list_tag=2 {character has a successor in a charlist}
+@d ext_tag=3 {character is extensible}
+
+@ The |lig_kern| array contains instructions in a simple programming language
+that explains what to do for special letter pairs. Each word is a
+|lig_kern_command| of four bytes.
+
+\yskip\hang first byte: |skip_byte|, indicates that this is the final program
+ step if the byte is 128 or more, otherwise the next step is obtained by
+ skipping this number of intervening steps.\par
+\hang second byte: |next_char|, ``if |next_char| follows the current character,
+ then perform the operation and stop, otherwise continue.''\par
+\hang third byte: |op_byte|, indicates a ligature step if less than~128,
+ a kern step otherwise.\par
+\hang fourth byte: |remainder|.\par
+\yskip\noindent
+In a kern step, an
+additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
+between the current character and |next_char|. This amount is
+often negative, so that the characters are brought closer together
+by kerning; but it might be positive.
+
+There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
+$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
+|remainder| is inserted between the current character and |next_char|;
+then the current character is deleted if $b=0$, and |next_char| is
+deleted if $c=0$; then we pass over $a$~characters to reach the next
+current character (which may have a ligature/kerning program of its own).
+
+Notice that if $a=0$ and $b=1$, the current character is unchanged; if
+$a=b$ and $c=1$, the current character is changed but the next character is
+unchanged. \.{TFtoPL} will check to see that infinite loops are avoided.
+
+If the very first instruction of the |lig_kern| array has |skip_byte=255|,
+the |next_char| byte is the so-called right boundary character of this font;
+the value of |next_char| need not lie between |bc| and~|ec|.
+If the very last instruction of the |lig_kern| array has |skip_byte=255|,
+there is a special ligature/kerning program for a left boundary character,
+beginning at location |256*op_byte+remainder|.
+The interpretation is that \TeX\ puts implicit boundary characters
+before and after each consecutive string of characters from the same font.
+These implicit characters do not appear in the output, but they can affect
+ligatures and kerning.
+
+If the very first instruction of a character's |lig_kern| program has
+|skip_byte>128|, the program actually begins in location
+|256*op_byte+remainder|. This feature allows access to large |lig_kern|
+arrays, because the first instruction must otherwise
+appear in a location |<=255|.
+
+Any instruction with |skip_byte>128| in the |lig_kern| array must have
+|256*op_byte+remainder<nl|. If such an instruction is encountered during
+normal program execution, it denotes an unconditional halt; no ligature
+command is performed.
+
+@d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program}
+@d kern_flag=128 {op code for a kern step}
+
+@ Extensible characters are specified by an |extensible_recipe|,
+which consists of four bytes called |top|, |mid|,
+|bot|, and |rep| (in this order). These bytes are the character codes
+of individual pieces used to build up a large symbol.
+If |top|, |mid|, or |bot| are zero,
+they are not present in the built-up result. For example, an extensible
+vertical line is like an extensible bracket, except that the top and
+bottom pieces are missing.
+
+
+@ The final portion of a \.{TFM} file is the |param| array, which is another
+sequence of |fix_word| values.
+
+\yskip\hang|param[1]=@!slant| is the amount of italic slant, which is used
+to help position accents. For example, |slant=.25| means that when you go
+up one unit, you also go .25 units to the right. The |slant| is a pure
+number; it's the only |fix_word| other than the design size itself that is
+not scaled by the design size.
+
+\hang|param[2]=space| is the normal spacing between words in text.
+Note that character |" "| in the font need not have anything to do with
+blank spaces.
+
+\hang|param[3]=space_stretch| is the amount of glue stretching between words.
+
+\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
+
+\hang|param[5]=x_height| is the height of letters for which accents don't
+have to be raised or lowered.
+
+\hang|param[6]=quad| is the size of one em in the font.
+
+\hang|param[7]=extra_space| is the amount added to |param[2]| at the
+ends of sentences.
+
+When the character coding scheme is \.{TeX math symbols}, the font is
+supposed to have 15 additional parameters called |num1|, |num2|, |num3|,
+|denom1|, |denom2|, |sup1|, |sup2|, |sup3|, |sub1|, |sub2|, |supdrop|,
+|subdrop|, |delim1|, |delim2|, and |axis_height|, respectively. When the
+character coding scheme is \.{TeX math extension}, the font is supposed to
+have six additional parameters called |default_rule_thickness| and
+|big_op_spacing1| through |big_op_spacing5|.
+
+@ So that is what \.{TFM} files hold. The next question is, ``What about
+\.{PL} files?'' A complete answer to that question appears in the
+documentation of the companion program, \.{PLtoTF}, so it will not
+be repeated here. Suffice it to say that a \.{PL} file is an ordinary
+\PASCAL\ text file, and that the output of \.{TFtoPL} uses only a
+subset of the possible constructions that might appear in a \.{PL} file.
+Furthermore, hardly anybody really wants to look at the formal
+definition of \.{PL} format, because it is almost self-explanatory when
+you see an example or two.
+
+@<Glob...@>=
+@!pl_file:text;
+
+@ @<Set init...@>=
+rewrite(pl_file);
+
+@* Unpacked representation.
+The first thing \.{TFtoPL} does is read the entire |tfm_file| into an array of
+bytes, |tfm[0..(4*lf-1)]|.
+
+@<Types...@>=
+@!byte=0..255; {unsigned eight-bit quantity}
+@!index=-1000..tfm_size; {address of a byte in |tfm|}
+@!char_type=0..65535;
+@!xchar_type=0..65536;
+@!xxchar_type=0..65537;
+@!xxxchar_type=0..65538;
+
+@
+@<Glob...@>=
+@!tfm:array [-1000..tfm_size] of byte; {the input data all goes here}
+ {the negative addresses avoid range checks for invalid characters}
+@!top_char,@!top_width,@!top_height,@!top_depth,@!top_italic:integer;
+@!start_ptr,@!check_sum,@!design_size,@!scheme,@!family,@!random_word:integer;
+@!header_length,@!char_ptr,@!copies,@!j:integer;
+
+@ The input may, of course, be all screwed up and not a \.{TFM} file
+at all. So we begin cautiously.
+
+@d abort(#)==begin print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OFM?');
+ goto final_end;
+ end
+
+@<Read the whole input file@>=
+read(tfm_file,tfm[0]);
+if tfm[0]>127 then abort('The first byte of the input file exceeds 127!');
+@.The first byte...@>
+if eof(tfm_file) then abort('The input file is only one byte long!');
+@.The input...one byte long@>
+read(tfm_file,tfm[1]); lf:=tfm[0]*@'400+tfm[1];
+if lf=0 then begin
+ for i:=2 to 7 do
+ begin
+ if eof(tfm_file)
+ then abort('The input file is too short to designate its length!');
+ read(tfm_file, tfm[i]);
+ end;
+ ofm_on := true; ofm_level := tfm[2]*@"100+tfm[3];
+ if tfm[4]>127 then abort('The fifth byte of the input file exceeds 127!');
+ lf := tfm[4]*@"1000000 + tfm[5]*@"10000 + tfm[6]*@"100 + tfm[7];
+end
+else
+begin
+ ofm_on := false;
+end;
+case ofm_level of
+-1: begin start_ptr:=2; check_sum:=24; end;
+ 0: begin start_ptr:=8; check_sum:=56; end;
+ 1: begin start_ptr:=8; check_sum:=116; end;
+end;
+design_size:=check_sum+4;
+scheme:=design_size+4;
+family:=scheme+40;
+random_word:=family+20;
+if lf=0 then
+ abort('The file claims to have length zero, but that''s impossible!');
+@.The file claims...@>
+if 4*lf-1>tfm_size then abort('The file is bigger than I can handle!');
+@.The file is bigger...@>
+for tfm_ptr:=start_ptr to 4*lf-1 do
+ begin if eof(tfm_file) then
+ abort('The file has fewer bytes than it claims!');
+@.The file has fewer bytes...@>
+ read(tfm_file,tfm[tfm_ptr]);
+ end;
+if not eof(tfm_file) then
+ begin print_ln('There''s some extra junk at the end of the OFM file,');
+@.There's some extra junk...@>
+ print_ln('but I''ll proceed as if it weren''t there.');
+ end
+
+@ After the file has been read successfully, we look at the subfile sizes
+to see if they check out.
+
+@d eval_two_bytes(#)==begin if tfm[tfm_ptr]>127 then
+ abort('One of the subfile sizes is negative!');
+@.One of the subfile sizes...@>
+ #:=tfm[tfm_ptr]*@'400+tfm[tfm_ptr+1];
+ tfm_ptr:=tfm_ptr+2;
+ end
+@d eval_four_bytes(#)==begin if tfm[tfm_ptr]>127 then
+ abort('One of the subfile sizes is negative!');
+@.One of the subfile sizes...@>
+ #:=tfm[tfm_ptr]*@"1000000+tfm[tfm_ptr+1]*@"10000+
+ tfm[tfm_ptr+2]*@"100+tfm[tfm_ptr+3];
+ tfm_ptr:=tfm_ptr+4;
+ end
+
+@<Set subfile sizes |lh|, |bc|, \dots, |np|@>=
+begin
+if not ofm_on then begin
+ tfm_ptr:=2;
+ eval_two_bytes(lh);
+ eval_two_bytes(bc);
+ eval_two_bytes(ec);
+ eval_two_bytes(nw);
+ eval_two_bytes(nh);
+ eval_two_bytes(nd);
+ eval_two_bytes(ni);
+ eval_two_bytes(nl);
+ eval_two_bytes(nk);
+ eval_two_bytes(ne);
+ eval_two_bytes(np);
+ ncw:=(ec-bc+1);
+ header_length:=6;
+ top_char:=255;
+ top_width:=255;
+ top_height:=15;
+ top_depth:=15;
+ top_italic:=63;
+ end
+else begin
+ tfm_ptr:=8;
+ eval_four_bytes(lh);
+ eval_four_bytes(bc);
+ eval_four_bytes(ec);
+ eval_four_bytes(nw);
+ eval_four_bytes(nh);
+ eval_four_bytes(nd);
+ eval_four_bytes(ni);
+ eval_four_bytes(nl);
+ eval_four_bytes(nk);
+ eval_four_bytes(ne);
+ eval_four_bytes(np);
+ eval_four_bytes(font_dir);
+ top_char:=65535;
+ top_width:=65535;
+ top_height:=255;
+ top_depth:=255;
+ top_italic:=255;
+ if ofm_level=0 then begin
+ header_length:=14;
+ ncw:=2*(ec-bc+1);
+ end
+ else begin
+ header_length:=29;
+ eval_four_bytes(nco);
+ eval_four_bytes(ncw);
+ eval_four_bytes(npc);
+ eval_four_bytes(nki); {Kinds of font ivalues}
+ eval_four_bytes(nwi); {Words of font ivalues}
+ eval_four_bytes(nkf); {Kinds of font fvalues}
+ eval_four_bytes(nwf); {Words of font fvalues}
+ eval_four_bytes(nkm); {Kinds of font mvalues}
+ eval_four_bytes(nwm); {Words of font mvalues}
+ eval_four_bytes(nkr); {Kinds of font rules}
+ eval_four_bytes(nwr); {Words of font rules}
+ eval_four_bytes(nkg); {Kinds of font glues}
+ eval_four_bytes(nwg); {Words of font glues}
+ eval_four_bytes(nkp); {Kinds of font penalties}
+ eval_four_bytes(nwp); {Words of font penalties}
+ end;
+ end;
+if lf<>(header_length+lh+ncw+nw+nh+nd+ni+2*nl+nk+2*ne+np+
+ nki+nwi+nkf+nwf+nkm+nwm+nkr+nwr+nkg+nwg+nkp+nwp) then
+ abort('Subfile sizes don''t add up to the stated total!');
+@.Subfile sizes don't add up...@>
+if lh<2 then abort('The header length is only ',lh:1,'!');
+@.The header length...@>
+if (2*nl)>(4*lig_size) then
+ abort('The lig/kern program is longer than I can handle!');
+@.The lig/kern program...@>
+if (bc>ec+1)or(ec>top_char) then abort('The character code range ',
+@.The character code range...@>
+ bc:1,'..',ec:1,'is illegal!');
+if ec>max_char then
+ abort('Character ',ec:1,'is too large. Ask a wizard to enlarge me.');
+if (nw=0)or(nh=0)or(nd=0)or(ni=0) then
+ abort('Incomplete subfiles for character dimensions!');
+@.Incomplete subfiles...@>
+if ne>(top_char+1) then abort('There are ',ne:1,' extensible recipes!');
+@.There are ... recipes@>
+end
+
+@ Once the input data successfully passes these basic checks,
+\.{TFtoPL} believes that it is a \.{TFM} file, and the conversion
+to \.{PL} format will take place. Access to the various subfiles
+is facilitated by computing the following base addresses. For example,
+the |char_info| for character |c| in a \.{TFM} file will start in location
+|4*(char_base+c)| of the |tfm| array.
+
+@<Globals...@>=
+@!ivalues_start,@!fvalues_start,@!mvalues_start,
+@!rules_start,@!glues_start,@!penalties_start:
+integer;
+@!ivalues_base,@!fvalues_base,@!mvalues_base,
+@!rules_base,@!glues_base,@!penalties_base:
+integer;
+@!char_base,@!width_base,@!height_base,@!depth_base,@!italic_base: integer;
+@!lig_kern_base,@!kern_base,@!exten_base,@!param_base:integer;
+ {base addresses for the subfiles}
+@!char_start:array [0..max_char] of integer;
+@!bytes_per_entry:integer;
+
+@ @<Compute the base addresses@>=
+begin
+ivalues_start:=header_length+lh;
+fvalues_start:=ivalues_start+nki;
+mvalues_start:=fvalues_start+nkf;
+rules_start:=mvalues_start+nkm;
+glues_start:=rules_start+nkr;
+penalties_start:=glues_start+nkg;
+ivalues_base:=penalties_start+nkp;
+fvalues_base:=ivalues_base+nwi;
+mvalues_base:=fvalues_base+nwf;
+rules_base:=mvalues_base+nwm;
+glues_base:=rules_base+nwr;
+penalties_base:=glues_base+nwg;
+char_base:=penalties_base+nwp;
+bytes_per_entry:=(12 + 2*npc) div 4 * 4;
+if not ofm_on then begin
+ for i:=bc to ec do begin
+ char_start[i]:=4*char_base+4*(i-bc);
+ end;
+ end
+else if ofm_level=0 then begin
+ for i:=bc to ec do begin
+ char_start[i]:=4*char_base+8*(i-bc);
+ end;
+ end
+else begin
+ char_ptr:=4*char_base;
+ i:=bc;
+ while i<=ec do begin
+ copies:=1+256*tfm[char_ptr+8]+tfm[char_ptr+9];
+ for j:=1 to copies do begin
+ char_start[i]:=char_ptr;
+ i:=i+1;
+ end;
+ char_ptr:=char_ptr + bytes_per_entry;
+ end;
+ if char_ptr<>(4*(char_base+ncw)) then
+ abort('Length of char info table does not correspond to specification');
+ end;
+width_base:=char_base+ncw;
+height_base:=width_base+nw;
+depth_base:=height_base+nh;
+italic_base:=depth_base+nd;
+lig_kern_base:=italic_base+ni;
+kern_base:=lig_kern_base+2*nl;
+exten_base:=kern_base+nk;
+param_base:=exten_base+2*ne-1;
+end
+
+@ Of course we want to define macros that suppress the detail of how the
+font information is actually encoded. Each word will be referred to by
+the |tfm| index of its first byte. For example, if |c| is a character
+code between |bc| and |ec|, then |tfm[char_info(c)]| will be the
+first byte of its |char_info|, i.e., the |width_index|; furthermore
+|width(c)| will point to the |fix_word| for |c|'s width.
+
+@d char_info(#)==char_start[#]
+@d nonexistent(#)==((#<bc)or(#>ec)or(width_index(#)=0))
+@d width(#)==4*(width_base+width_index(#))
+@d height(#)==4*(height_base+height_index(#))
+@d depth(#)==4*(depth_base+depth_index(#))
+@d italic(#)==4*(italic_base+italic_index(#))
+@d kern(#)==4*(kern_base+#) {here \#\ is an index, not a character}
+@d param(#)==4*(param_base+#) {likewise}
+
+@p function width_index(c:char_type):integer;
+begin if not ofm_on then
+ width_index:=tfm[char_info(c)]
+else
+ width_index:=256*tfm[char_info(c)]+tfm[char_info(c)+1];
+end;
+
+function height_index(c:char_type):integer;
+begin if not ofm_on then
+ height_index:=tfm[char_info(c)+1] div 16
+else
+ height_index:=tfm[char_info(c)+2];
+end;
+
+function depth_index(c:char_type):integer;
+begin if not ofm_on then
+ depth_index:=tfm[char_info(c)+1] mod 16
+else
+ depth_index:=tfm[char_info(c)+3];
+end;
+
+function italic_index(c:char_type):integer;
+begin if not ofm_on then
+ italic_index:=tfm[char_info(c)+2] div 4
+else if ofm_level=0 then
+ italic_index:=tfm[char_info(c)+4]*64 + tfm[char_info(c)+5] div 4
+else
+ italic_index:=tfm[char_info(c)+4];
+end;
+
+function tag(c:char_type):integer;
+begin if not ofm_on then
+ tag:=tfm[char_info(c)+2] mod 4
+else
+ tag:=tfm[char_info(c)+5] mod 4;
+end;
+
+procedure set_no_tag(c:char_type);
+begin if not ofm_on then
+ tfm[char_info(c)+2] := (tfm[char_info(c)+2] div 64)*64 + no_tag
+else
+ tfm[char_info(c)+5] := (tfm[char_info(c)+5] div 64)*64 + no_tag;
+end;
+
+function ctag(c:char_type):boolean;
+begin if not (ofm_level=1) then
+ ctag:=false
+else
+ ctag:=tfm[char_info(c)+5] div 4 mod 2;
+end;
+
+procedure set_no_ctag(c:char_type);
+begin if not (ofm_level=1) then
+ tfm[char_info(c)+5] :=
+ tfm[char_info(c)+5] div 8 * 8 + tfm[char_info(c)+5] mod 4;
+end;
+
+function no_repeats(c:char_type):integer;
+begin if ofm_level<=0 then
+ no_repeats:=0
+else
+ no_repeats:=256*tfm[char_info(c)+8]+tfm[char_info(c)+9];
+end;
+
+function char_param(c:char_type; i:integer):integer;
+begin
+ char_param:=256*tfm[char_info(c)+2*i+10]+tfm[char_info(c)+2*i+11];
+end;
+
+function rremainder(c:char_type):integer;
+begin if not ofm_on then
+ rremainder:=tfm[char_info(c)+3]
+else
+ rremainder:=256*tfm[char_info(c)+6]+tfm[char_info(c)+7];
+end;
+
+function lig_step(c:char_type):integer;
+begin if not ofm_on then
+ lig_step:=4*(lig_kern_base+c)
+else
+ lig_step:=4*(lig_kern_base+2*c);
+end;
+
+function exten(c:char_type):integer;
+begin if not ofm_on then
+ exten:=4*(exten_base+rremainder(c))
+else
+ exten:=4*(exten_base+2*rremainder(c));
+end;
+
+function l_skip_byte(c:integer):integer;
+begin if not ofm_on then
+ l_skip_byte:=tfm[c]
+else
+ l_skip_byte:=256*tfm[c]+tfm[c+1];
+end;
+
+procedure set_l_skip_byte(c:integer; newc:integer);
+begin if not ofm_on then
+ tfm[c]:=newc
+else begin
+ tfm[c]:=newc div 256;
+ tfm[c+1]:=newc mod 256
+ end
+end;
+
+function l_next_char(c:integer):integer;
+begin if not ofm_on then
+ l_next_char:=tfm[c+1]
+else
+ l_next_char:=256*tfm[c+2]+tfm[c+3];
+end;
+
+procedure set_l_next_char(c:integer; newc:char_type);
+begin if not ofm_on then
+ tfm[c+1]:=newc
+else begin
+ tfm[c+2]:=newc div 256;
+ tfm[c+3]:=newc mod 256
+ end
+end;
+
+function l_op_byte(c:integer):integer;
+begin if not ofm_on then
+ l_op_byte:=tfm[c+2]
+else
+ l_op_byte:=256*tfm[c+4]+tfm[c+5];
+end;
+
+procedure set_l_op_byte(c:integer; newc:integer);
+begin if not ofm_on then
+ tfm[c+2]:=newc
+else begin
+ tfm[c+2]:=newc div 256;
+ tfm[c+3]:=newc mod 256
+ end
+end;
+
+function l_remainder(c:integer):integer;
+begin if not ofm_on then
+ l_remainder:=tfm[c+3]
+else
+ l_remainder:=256*tfm[c+6]+tfm[c+7];
+end;
+
+procedure set_l_remainder(c:integer; newc:char_type);
+begin if not ofm_on then
+ tfm[c+3]:=newc
+else begin
+ tfm[c+6]:=newc div 256;
+ tfm[c+7]:=newc mod 256
+ end
+end;
+
+@ One of the things we would like to do is take cognizance of fonts whose
+character coding scheme is \.{TeX math symbols} or \.{TeX math extension};
+we will set the |font_type| variable to one of the three choices
+|vanilla|, |mathsy|, or |mathex|.
+
+@d vanilla=0 {not a special scheme}
+@d mathsy=1 {\.{TeX math symbols} scheme}
+@d mathex=2 {\.{TeX math extension} scheme}
+
+@<Glob...@>=
+@!font_type:vanilla..mathex; {is this font special?}
+
+@* Basic output subroutines.
+Let us now define some procedures that will reduce the rest of \.{TFtoPL}'s
+work to a triviality.
+
+First of all, it is convenient to have an abbreviation for output to the
+\.{PL} file:
+
+@d out(#)==write(pl_file,#)
+
+@ In order to stick to standard \PASCAL, we use three strings called
+|ASCII_04|, |ASCII_10|, and |ASCII_14|, in terms of which we can do the
+appropriate conversion of ASCII codes. Three other little strings are
+used to produce |face| codes like \.{MIE}.
+
+@<Glob...@>=
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+
+@ @<Set init...@>=
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:='0123456789ABCDEF';@/
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+
+@ The array |dig| will hold a sequence of digits to be output.
+
+@<Glob...@>=
+@!dig:array[0..32] of integer;
+
+@ Here, in fact, are two procedures that output
+|dig[j-1]|$\,\ldots\,$|dig[0]|, given $j>0$.
+
+@p procedure out_digs(j:integer); {outputs |j| digits}
+begin repeat decr(j); out(HEX[1+dig[j]]);
+ until j=0;
+end;
+@#
+procedure print_digs(j:integer); {prints |j| digits}
+begin repeat decr(j); print(HEX[1+dig[j]]);
+ until j=0;
+end;
+
+@ The |print_number| procedure indicates how |print_digs| can be used.
+This procedure can print in octal, decimal or hex notation.
+
+@d print_hex(#)==print_number(#,16)
+@d print_octal(#)==print_number(#,8)
+@d print_decimal(#)==print_number(#,10)
+
+@p procedure print_number(c:integer; form:integer); {prints value of |c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0;
+ end;
+if form=8 then
+ print('''') {an apostrophe indicates the octal notation}
+else if form=16 then
+ print('"') { a double apostrophe indicates the hexadecimal notation}
+else if form<>10 then begin
+ print_ln('Internal error: print_number (form)');
+ form:=16;
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+print_digs(j);
+end;
+
+@ A \.{PL} file has nested parentheses, and we want to format the output
+so that its structure is clear. The |level| variable keeps track of the
+depth of nesting.
+
+@<Glob...@>=
+@!level:0..5;
+
+@ @<Set init...@>=
+level:=0;
+
+@ Three simple procedures suffice to produce the desired structure in the
+output.
+
+@p procedure out_ln; {finishes one line, indents the next}
+var l:0..5;
+begin write_ln(pl_file);
+for l:=1 to level do out(' ');
+end;
+@#
+procedure left; {outputs a left parenthesis}
+begin incr(level); out('(');
+end;
+@#
+procedure right; {outputs a right parenthesis and finishes a line}
+begin decr(level); out(')'); out_ln;
+end;
+
+@ The value associated with a property can be output in a variety of
+ways. For example, we might want to output a {\mc BCPL} string that
+begins in |tfm[k]|:
+
+@p procedure out_BCPL(@!k:index); {outputs a string, preceded by a blank space}
+var l:0..39; {the number of bytes remaining}
+begin out(' '); l:=tfm[k];
+while l>0 do
+ begin incr(k); decr(l);
+ case tfm[k] div @'40 of
+ 1: out(ASCII_04[1+(tfm[k] mod @'40)]);
+ 2: out(ASCII_10[1+(tfm[k] mod @'40)]);
+ 3: out(ASCII_14[1+(tfm[k] mod @'40)]);
+ end;
+ end;
+end;
+
+@ The property value might also be a sequence of |l| bytes, beginning
+in |tfm[k]|, that we would like to output in hex notation.
+The following procedure assumes that |l<=4|, but larger values of |l|
+could be handled easily by enlarging the |dig| array and increasing
+the upper bounds on |b| and |j|.
+
+@d out_octal_number(#)==out_number(#,8)
+@d out_decimal_number(#)==out_number(#,10)
+@d out_hex_number(#)==out_number(#,16)
+@d out_dec(#)==out_decimal_number(#)
+@d out_hex_char(#)==out_hex_number(#)
+
+@p procedure out_number(c:integer; form:integer); {outputs value of |c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0;
+ end;
+if form=8 then
+ out(' O ')
+else if form=10 then
+ out(' D ')
+else if form=16 then
+ out(' H ')
+else begin
+ print_ln('Internal error: print_number (form)');
+ form:=16;
+ out(' H ')
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+out_digs(j);
+end;
+@#
+procedure out_hex(@!k,@!l:index);
+ {outputs |l| bytes in hex}
+var a:0..@"7FFFFFFF; {accumulator for bits not yet output}
+@!b:0..32; {the number of significant bits in |a|}
+@!j:0..11; {the number of digits of output}
+begin
+out(' H ');
+a:=0; b:=0; j:=0;
+while l>0 do @<Reduce \(1)|l| by one, preserving the invariants@>;
+while (a>0)or(j=0) do begin
+ dig[j]:=a mod 16; a:=a div 16; incr(j);
+ end;
+out_digs(j);
+end;
+
+@ @<Reduce \(1)|l|...@>=
+begin decr(l);
+if tfm[k+l]<>0 then begin
+ while b>3 do begin
+ dig[j]:=a mod 16; a:=a div 16; b:=b-4; incr(j);
+ end;
+ case b of
+ 0: a:=tfm[k+l];
+ 1:a:=a+2*tfm[k+l];
+ 2:a:=a+4*tfm[k+l];
+ 3:a:=a+8*tfm[k+l];
+ end;
+ end;
+b:=b+8;
+end
+
+@ The property value may be a character, which is output in hex
+unless it is a letter or a digit. This procedure is the only place
+where a lowercase letter will be output to the \.{PL} file.
+@^system dependencies@>
+
+@p procedure out_char(@!c:integer); {outputs a character}
+begin if font_type>vanilla then
+ out_hex_char(c)
+else if (c>="0")and(c<="9") then
+ out(' C ',c-"0":1)
+else if (c>="A")and(c<="Z") then
+ out(' C ',ASCII_10[c-"A"+2])
+else if (c>="a")and(c<="z") then
+ out(' C ',ASCII_14[c-"a"+2])
+else out_hex_char(c);
+end;
+
+@ The property value might be a ``face'' byte, which is output in the
+curious code mentioned earlier, provided that it is less than 18.
+
+@p procedure out_face(@!k:index); {outputs a |face|}
+var s:0..1; {the slope}
+@!b:0..8; {the weight and expansion}
+begin if tfm[k]>=18 then out_hex(k,1)
+else begin out(' F '); {specify face-code format}
+ s:=tfm[k] mod 2; b:=tfm[k] div 2;
+ out(MBL_string[1+(b mod 3)]);
+ out(RI_string[1+s]);
+ out(RCE_string[1+(b div 3)]);
+ end;
+end;
+
+@ And finally, the value might be a |fix_word|, which is output in
+decimal notation with just enough decimal places for \.{PLtoTF}
+to recover every bit of the given |fix_word|.
+
+All of the numbers involved in the intermediate calculations of
+this procedure will be nonnegative and less than $10\cdot2^{24}$.
+
+@p procedure out_fix(@!k:index); {outputs a |fix_word|}
+var a:0..@'7777; {accumulator for the integer part}
+@!f:integer; {accumulator for the fraction part}
+@!j:0..12; {index into |dig|}
+@!delta:integer; {amount if allowable inaccuracy}
+begin out(' R '); {specify real format}
+a:=(tfm[k]*16)+(tfm[k+1] div 16);
+f:=((tfm[k+1] mod 16)*@'400+tfm[k+2])*@'400+tfm[k+3];
+if a>@'3777 then @<Reduce \(2)negative to positive@>;
+@<Output the integer part, |a|, in decimal notation@>;
+@<Output the fraction part, $|f|/2^{20}$, in decimal notation@>;
+end;
+
+@ The following code outputs at least one digit even if |a=0|.
+
+@<Output the integer...@>=
+begin j:=0;
+repeat dig[j]:=a mod 10; a:=a div 10; incr(j);
+until a=0;
+out_digs(j);
+end
+
+@ And the following code outputs at least one digit to the right
+of the decimal point.
+
+@<Output the fraction...@>=
+begin out('.'); f:=10*f+5; delta:=10;
+repeat if delta>@'4000000 then f:=f+@'2000000-(delta div 2);
+out(f div @'4000000:1); f:=10*(f mod @'4000000); delta:=delta*10;
+until f<=delta;
+end;
+
+@ @<Reduce \(2)negative to positive@>=
+begin out('-'); a:=@'10000-a;
+if f>0 then begin
+ f:=@'4000000-f; decr(a);
+ end;
+end
+
+@* Doing it.
+\TeX\ checks the information of a \.{TFM} file for validity as the
+file is being read in, so that no further checks will be needed when
+typesetting is going on. And when it finds something wrong, it justs
+calls the file ``bad,'' without identifying the nature of the problem,
+since \.{TFM} files are supposed to be good almost all of the time.
+
+Of course, a bad file shows up every now and again, and that's where
+\.{TFtoPL} comes in. This program wants to catch at least as many errors as
+\TeX\ does, and to give informative error messages besides.
+All of the errors are corrected, so that the \.{PL} output will
+be correct (unless, of course, the \.{TFM} file was so loused up
+that no attempt is being made to fathom it).
+
+@ Just before each character is processed, its code is printed in hex
+notation. Up to eight such codes appear on a line; so we have a variable
+to keep track of how many are currently there. We also keep track of
+whether or not any errors have had to be corrected.
+
+@<Glob...@>=
+@!chars_on_line:0..8; {the number of characters printed on the current line}
+@!perfect:boolean; {was the file free of errors?}
+
+@ @<Set init...@>=
+chars_on_line:=0;@/
+perfect:=true; {innocent until proved guilty}
+
+@ Error messages are given with the help of the |bad| and |range_error|
+and |bad_char| macros:
+
+@d bad(#)==begin perfect:=false; if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print_ln('Bad OFM file: ',#);
+ end
+@.Bad OFM file@>
+@d range_error(#)==begin perfect:=false; print_ln(' ');
+ print(#,' index for character ');
+ print_hex(c); print_ln(' is too large;');
+ print_ln('so I reset it to zero.');
+ end
+@d bad_char_tail(#)==print_hex(#); print_ln('.');
+ end
+@d bad_char(#)==begin perfect:=false; if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print('Bad OFM file: ',#,' nonexistent character ');
+ bad_char_tail
+@d correct_bad_char_tail(#)==#(k,0)
+ end
+@d correct_bad_char_middle(#)==print_hex(#(k)); print_ln('.');
+ correct_bad_char_tail
+@d correct_bad_char(#)== begin perfect:=false;
+ if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print('Bad OFM file: ',#,' nonexistent character ');
+ correct_bad_char_middle
+
+@<Glob...@>=
+@!i:integer; {an index to words of a subfile}
+@!c:xchar_type; {a random character}
+@!d:0..3; {byte number in a word}
+@!k:index; {a random index}
+@!r:0..65535; {a random two-byte value}
+@!count:0..127; {for when we need to enumerate a small set}
+
+@ There are a lot of simple things to do, and they have to be done one
+at a time, so we might as well get down to business. The first things
+that \.{TFtoPL} will put into the \.{PL} file appear in the header part.
+
+@<Do the header@>=
+begin
+case ofm_level of
+0: begin out('(OFMLEVEL H 0)'); out_ln; end;
+1: begin out('(OFMLEVEL H 1)'); out_ln; end;
+end;
+if ofm_on then begin
+ left;
+ if font_dir<=7 then out('FONTDIR')
+ else out('NFONTDIR');
+ case font_dir mod 8 of
+ 0: out(' TL');
+ 1: out(' LT');
+ 2: out(' TR');
+ 3: out(' LB');
+ 4: out(' BL');
+ 5: out(' RT');
+ 6: out(' BR');
+ 7: out(' RB');
+ end;
+ right
+ end;
+font_type:=vanilla;
+if lh>=12 then begin
+ @<Set the true |font_type|@>;
+ if lh>=17 then begin
+ @<Output the family name@>;
+ if lh>=18 then @<Output the rest of the header@>;
+ end;
+ @<Output the character coding scheme@>;
+ end;
+@<Output the design size@>;
+@<Output the check sum@>;
+@<Output the |seven_bit_safe_flag|@>;
+end
+
+@ @<Output the check sum@>=
+left; out('CHECKSUM'); out_hex(check_sum,4);
+right
+
+@ Incorrect design sizes are changed to 10 points.
+
+@d bad_design(#)==begin bad('Design size ',#,'!');
+@.Design size wrong@>
+ print_ln('I''ve set it to 10 points.');
+ out(' D 10');
+ end
+
+@ @<Output the design size@>=
+left; out('DESIGNSIZE');
+if tfm[design_size]>127 then bad_design('negative')
+else if (tfm[design_size]=0)and(tfm[design_size+1]<16) then
+ bad_design('too small')
+else out_fix(design_size);
+right;
+out('(COMMENT DESIGNSIZE IS IN POINTS)'); out_ln;
+out('(COMMENT OTHER SIZES ARE MULTIPLES OF DESIGNSIZE)'); out_ln
+@.DESIGNSIZE IS IN POINTS@>
+
+@ Since we have to check two different {\mc BCPL} strings for validity,
+we might as well write a subroutine to make the check.
+
+@p procedure check_BCPL(@!k,@!l:index); {checks a string of length |<l|}
+var j:index; {runs through the string}
+@!c:integer; {character being checked}
+begin if tfm[k]>=l then
+ begin bad('String is too long; I''ve shortened it drastically.');
+@.String is too long...@>
+ tfm[k]:=1;
+ end;
+for j:=k+1 to k+tfm[k] do
+ begin c:=tfm[j];
+ if (c="(")or(c=")") then
+ begin bad('Parenthesis in string has been changed to slash.');
+@.Parenthesis...changed to slash@>
+ tfm[j]:="/";
+ end
+ else if (c<" ")or(c>"~") then
+ begin bad('Nonstandard ASCII code has been blotted out.');
+@.Nonstandard ASCII code...@>
+ tfm[j]:="?";
+ end
+ else if (c>="a")and(c<="z") then tfm[j]:=c+"A"-"a"; {upper-casify letters}
+ end;
+end;
+
+@ The |font_type| starts out |vanilla|; possibly we need to reset it.
+
+@<Set the true |font_type|@>=
+begin check_BCPL(scheme,40);
+if (tfm[scheme]>=11)and@|(tfm[scheme+1]="T")and@|
+ (tfm[scheme+2]="E")and@|(tfm[scheme+3]="X")and@|
+ (tfm[scheme+4]=" ")and@|(tfm[scheme+5]="M")and@|
+ (tfm[scheme+6]="A")and@|(tfm[scheme+7]="T")and@|
+ (tfm[scheme+8]="H")and@|(tfm[scheme+9]=" ") then
+ begin if (tfm[scheme+10]="S")and(tfm[scheme+11]="Y") then font_type:=mathsy
+ else if (tfm[scheme+10]="E")and(tfm[scheme+11]="X") then font_type:=mathex;
+ end;
+end
+
+@ @<Output the character coding scheme@>=
+left; out('CODINGSCHEME');
+out_BCPL(scheme);
+right
+
+@ @<Output the family name@>=
+left; out('FAMILY');
+check_BCPL(family,20);
+out_BCPL(family);
+right
+
+@ @<Output the rest of the header@>=
+begin left; out('FACE'); out_face(random_word+3); right;
+for i:=18 to lh-1 do begin
+ left; out('HEADER D ',i:1);
+ out_hex(check_sum+4*i,@,4); right;
+ end;
+end
+
+@ This program does not check to see if the |seven_bit_safe_flag| has the
+correct setting, i.e., if it really reflects the seven-bit-safety of
+the \.{TFM} file; the stated value is merely put into the \.{PL} file.
+The \.{PLtoTF} program will store a correct value and give a warning
+message if a file falsely claims to be safe.
+
+@<Output the |seven_bit_safe_flag|@>=
+begin left; out('SEVENBITSAFEFLAG FALSE'); right;
+end
+
+@ The next thing to take care of is the list of parameters.
+
+@<Do the parameters@>=
+if np>0 then begin
+ left; out('FONTDIMEN'); out_ln;
+ for i:=1 to np do @<Check and output the $i$th parameter@>;
+ right;
+ end;
+@<Check to see if |np| is complete for this font type@>;
+
+@ @<Check to see if |np|...@>=
+if (font_type=mathsy)and(np<>22) then
+ print_ln('Unusual number of fontdimen parameters for a math symbols font (',
+@.Unusual number of fontdimen...@>
+ np:1,' not 22).')
+else if (font_type=mathex)and(np<>13) then
+ print_ln('Unusual number of fontdimen parameters for an extension font (',
+ np:1,' not 13).')
+
+@ All |fix_word| values except the design size and the first parameter
+will be checked to make sure that they are less than 16.0 in magnitude,
+using the |check_fix| macro:
+
+@d check_fix_tail(#)==bad(#,' ',i:1,' is too big;');
+ print_ln('I have set it to zero.');
+ end
+@d check_fix(#)==if (tfm[#]>0)and(tfm[#]<255) then
+ begin tfm[#]:=0; tfm[(#)+1]:=0; tfm[(#)+2]:=0; tfm[(#)+3]:=0;
+ check_fix_tail
+
+@<Check and output the $i$th parameter@>=
+begin left;
+if i=1 then out('SLANT') {this parameter is not checked}
+else begin check_fix(param(i))('Parameter');@/
+@.Parameter n is too big@>
+ @<Output the name of parameter $i$@>;
+ end;
+out_fix(param(i)); right;
+end
+
+@ @<Output the name...@>=
+if i<=7 then case i of
+ 2:out('SPACE');@+3:out('STRETCH');@+4:out('SHRINK');
+ 5:out('XHEIGHT');@+6:out('QUAD');@+7:out('EXTRASPACE')@+end
+else if (i<=22)and(font_type=mathsy) then case i of
+ 8:out('NUM1');@+9:out('NUM2');@+10:out('NUM3');
+ 11:out('DENOM1');@+12:out('DENOM2');
+ 13:out('SUP1');@+14:out('SUP2');@+15:out('SUP3');
+ 16:out('SUB1');@+17:out('SUB2');
+ 18:out('SUPDROP');@+19:out('SUBDROP');
+ 20:out('DELIM1');@+21:out('DELIM2');
+ 22:out('AXISHEIGHT')@+end
+else if (i<=13)and(font_type=mathex) then
+ if i=8 then out('DEFAULTRULETHICKNESS')
+ else out('BIGOPSPACING',i-8:1)
+else out('PARAMETER D ',i:1)
+
+@ @<Glob...@>=
+@!start_counter,@!base_counter,@!number_entries:integer;
+@!value:integer;
+
+@ @<Do the ivalue parameters@>=
+if nki>0 then begin
+ start_counter:=ivalues_start*4;
+ base_counter:=ivalues_base*4;
+ for i:=0 to nki-1 do @<Check and output the $i$th ivalue table@>;
+ end;
+
+@ @<Check and output the $i$th ivalue table@>=
+begin
+left; out('FONTIVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('IVALUE'); out_hex_number(j); out_ln;
+ value:=256*tfm[base_counter+2]+tfm[base_counter+3];
+ left; out('IVALUEVAL'); out_hex_number(value); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;;
+end;
+
+@ @<Do the fvalue parameters@>=
+if nkf>0 then begin
+ start_counter:=fvalues_start*4;
+ base_counter:=fvalues_base*4;
+ for i:=0 to nkf-1 do @<Check and output the $i$th fvalue table@>;
+ end;
+
+@ @<Check and output the $i$th fvalue table@>=
+begin
+left; out('FONTFVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('FVALUE'); out_hex_number(j); out_ln;
+ left; out('FVALUEVAL'); out_fix(base_counter); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the mvalue parameters@>=
+if nkm>0 then begin
+ start_counter:=mvalues_start*4;
+ base_counter:=mvalues_base*4;
+ for i:=0 to nkm-1 do @<Check and output the $i$th mvalue table@>;
+ end;
+
+@ @<Check and output the $i$th mvalue table@>=
+begin
+left; out('FONTMVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('MVALUE'); out_hex_number(j); out_ln;
+ left; out('MVALUEVAL'); out_fix(base_counter); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the rule parameters@>=
+if nkr>0 then
+ begin
+ start_counter:=rules_start*4;
+ base_counter:=rules_base*4;
+ for i:=0 to nkr-1 do @<Check and output the $i$th rule table@>;
+ end;
+
+@ @<Check and output the $i$th rule table@>=
+begin
+left; out('FONTRULE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('RULE'); out_hex_number(j); out_ln;
+ left; out('RULEWD'); out_fix(base_counter); right;
+ left; out('RULEHT'); out_fix(base_counter+4); right;
+ left; out('RULEDP'); out_fix(base_counter+8); right;
+ right;
+ base_counter:=base_counter+12;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the glue parameters@>=
+if nkg>0 then begin
+ start_counter:=glues_start*4;
+ base_counter:=glues_base*4;
+ for i:=0 to nkg-1 do @<Check and output the $i$th glue table@>;
+ end;
+
+@ @<Glob...@>=
+@!glue_subtype,@!glue_argument_kind,@!glue_stretch_order,
+@!glue_shrink_order,@!glue_argument:integer;
+
+@ @<Check and output the $i$th glue table@>=
+begin
+left; out('FONTGLUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('GLUE'); out_hex_number(j); out_ln;
+ glue_subtype:=tfm[base_counter] div 16;
+ glue_argument_kind:=tfm[base_counter] mod 16;
+ glue_stretch_order:=tfm[base_counter+1] div 16;
+ glue_shrink_order:=tfm[base_counter+1] mod 16;
+ glue_argument:=tfm[base_counter+2]*256+tfm[base_counter+3];
+ left;
+ out('GLUETYPE');
+ case glue_subtype of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ end;
+ right;
+ case glue_argument_kind of
+ 1: begin
+ left; out('GLUERULE'); out_hex_number(glue_argument); right;
+ end;
+ 2: begin
+ left; out('GLUECHAR'); out_hex_number(glue_argument); right;
+ end;
+ end;
+ left;
+ out('GLUESTRETCHORDER');
+ case glue_stretch_order of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ 4: out(' H 4');
+ end;
+ right;
+ left;
+ out('GLUESHRINKORDER');
+ case glue_shrink_order of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ 4: out(' H 4');
+ end;
+ right;
+ left; out('GLUEWD'); out_fix(base_counter+4); right;
+ left; out('GLUESTRETCH'); out_fix(base_counter+8); right;
+ left; out('GLUESHRINK'); out_fix(base_counter+12); right;
+ right;
+ base_counter:=base_counter+16;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the penalty parameters@>=
+if nkp>0 then begin
+ start_counter:=penalties_start*4;
+ base_counter:=penalties_base*4;
+ for i:=0 to nkp-1 do @<Check and output the $i$th penalty table@>;
+ end;
+
+@ @<Check and output the $i$th penalty table@>=
+begin
+left; out('FONTPENALTY'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('PENALTY'); out_hex_number(j); out_ln;
+ value:=256*tfm[base_counter+2]+tfm[base_counter+3];
+ left; out('PENALTYVAL'); out_hex_number(value); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ We need to check the range of all the remaining |fix_word| values,
+and to make sure that |width[0]=0|, etc.
+
+@d nonzero_fix(#)==(tfm[#]>0)or(tfm[#+1]>0)or(tfm[#+2]>0)or(tfm[#+3]>0)
+
+@<Check the |fix_word| entries@>=
+if nonzero_fix(4*width_base) then bad('width[0] should be zero.');
+@.should be zero@>
+if nonzero_fix(4*height_base) then bad('height[0] should be zero.');
+if nonzero_fix(4*depth_base) then bad('depth[0] should be zero.');
+if nonzero_fix(4*italic_base) then bad('italic[0] should be zero.');
+for i:=0 to nw-1 do check_fix(4*(width_base+i))('Width');
+@.Width n is too big@>
+for i:=0 to nh-1 do check_fix(4*(height_base+i))('Height');
+@.Height n is too big@>
+for i:=0 to nd-1 do check_fix(4*(depth_base+i))('Depth');
+@.Depth n is too big@>
+for i:=0 to ni-1 do check_fix(4*(italic_base+i))('Italic correction');
+@.Italic correction n is too big@>
+if nk>0 then for i:=0 to nk-1 do check_fix(kern(i))('Kern');
+@.Kern n is too big@>
+
+@ The ligature/kerning program comes next. Before we can put it out in
+\.{PL} format, we need to make a table of ``labels'' that will be inserted
+into the program. For each character |c| whose |tag| is |lig_tag| and
+whose starting address is |r|, we will store the pair |(c,r)| in the
+|label_table| array. If there's a boundary-char program starting at~|r|,
+we also store the pair |(256,r)|.
+This array is sorted by its second components, using the
+simple method of straight insertion.
+
+@<Glob...@>=
+@!label_table:array[xxxchar_type] of record
+@!cc:xchar_type;@!rr:0..lig_size;ischar:boolean;end;
+@!label_ptr:xxchar_type; {the largest entry in |label_table|}
+@!sort_ptr:xxchar_type; {index into |label_table|}
+@!boundary_char:xchar_type; {boundary character, or |xmax_char| if none}
+@!bchar_label:0..xmax_label; {beginning of boundary character program}
+
+@ @<Set init...@>=
+boundary_char:=xmax_char; bchar_label:=xmax_label;@/
+label_ptr:=0; label_table[0].rr:=0; {a sentinel appears at the bottom}
+
+@ We'll also identify and remove inaccessible program steps, using the
+|activity| array.
+
+@d unreachable=0 {a program step not known to be reachable}
+@d pass_through=1 {a program step passed through on initialization}
+@d accessible=2 {a program step that can be relevant}
+
+@<Glob...@>=
+@!activity:array[0..lig_size] of unreachable..accessible;
+@!ai,@!acti:0..lig_size; {indices into |activity|}
+
+@ @<Do the ligatures and kerns@>=
+if nl>0 then
+ begin for ai:=0 to (nl-1) do activity[ai]:=unreachable;
+ @<Check for a boundary char@>;
+ end;
+@<Build the label table@>;
+if nl>0 then
+ begin left; out('LIGTABLE'); out_ln;@/
+ @<Compute the |activity| array@>;
+ @<Output and correct the ligature/kern program@>;
+ right;
+ @<Check for ligature cycles@>;
+ end
+
+@ We build the label table even when |nl=0|, because this catches errors
+that would not otherwise be detected.
+
+@<Build...@>=
+for c:=bc to ec do
+if (tag(c)=lig_tag) or (ctag(c)) then begin
+ r:=rremainder(c);
+ if (l_skip_byte(lig_step(r)) div 256)=0 then begin
+ if r<nl then begin
+ if l_skip_byte(lig_step(r))>stop_flag then begin
+ r:=256*l_op_byte(lig_step(r))+l_remainder(lig_step(r));
+ if r<nl then
+ if activity[rremainder(c)]=unreachable then
+ activity[rremainder(c)]:=pass_through;
+ end;
+ end;
+ end;
+ if r>=nl then begin
+ perfect:=false; print_ln(' ');
+ print('Ligature/kern starting index for character '); print_hex(c);
+ print_ln(' is too large;'); print_ln('so I removed it.'); set_no_tag(c);
+ set_no_ctag(c);
+@.Ligature/kern starting index...@>
+ end
+ else @<Insert |(c,r)| into |label_table|@>;
+ end;
+label_table[label_ptr+1].rr:=lig_size; {put ``infinite'' sentinel at the end}
+
+@ @<Insert |(c,r)|...@>=
+begin sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|}
+while label_table[sort_ptr].rr>r do begin
+ label_table[sort_ptr+1]:=label_table[sort_ptr];
+ decr(sort_ptr); {move the hole}
+ end;
+label_table[sort_ptr+1].ischar:=not ctag(c);
+if ctag(c) then
+ label_table[sort_ptr+1].cc:=char_param(c,0)
+else
+ label_table[sort_ptr+1].cc:=c;
+label_table[sort_ptr+1].rr:=r; {fill the hole}
+incr(label_ptr); activity[r]:=accessible;
+end
+
+@ @<Check for a bound...@>=
+if l_skip_byte(lig_step(0))=255 then begin
+ left; out('BOUNDARYCHAR');
+ boundary_char:=l_next_char(lig_step(0)); out_char(boundary_char); right;
+ activity[0]:=pass_through;
+ end;
+if l_skip_byte(lig_step(nl-1))=255 then begin
+ r:=256*l_op_byte(lig_step(nl-1))+l_remainder(lig_step(nl-1));
+ if r>=nl then begin
+ perfect:=false; print_ln(' ');
+ print('Ligature/kern starting index for boundarychar is too large;');
+ print_ln('so I removed it.');
+@.Ligature/kern starting index...@>
+ end
+ else begin label_ptr:=1; label_table[1].cc:=xmax_char;
+ label_table[1].rr:=r;
+ bchar_label:=r; activity[r]:=accessible;
+ end;
+ activity[nl-1]:=pass_through;
+ end
+
+@ @<Compute the |activity| array@>=
+for ai:=0 to (nl-1) do
+if (l_skip_byte(lig_step(ai)) div 256)=1 then
+ activity[ai]:=accessible
+else if activity[ai]=accessible then begin
+ r:=l_skip_byte(lig_step(ai));
+ if r<stop_flag then begin
+ r:=r+ai+1;
+ if r>=nl then begin
+ bad('Ligature/kern step ',ai:1,' skips too far;');
+@.Lig...skips too far@>
+ print_ln('I made it stop.'); set_l_skip_byte(lig_step(ai),stop_flag);
+ end
+ else activity[r]:=accessible;
+ end;
+ end
+
+@ We ignore |pass_through| items, which don't need to be mentioned in
+the \.{PL} file.
+
+@<Output and correct the ligature...@>=
+sort_ptr:=1; {point to the next label that will be needed}
+for acti:=0 to nl-1 do if activity[acti]<>pass_through then
+ begin i:=acti; @<Take care of commenting out unreachable steps@>;
+ @<Output any labels for step $i$@>;
+ @<Output step $i$ of the ligature/kern program@>;
+ end;
+if level=2 then right {the final step was unreachable}
+
+@ @<Globals...@>=
+@!output_clabels:array[0..256] of boolean;
+@!clabel_runner:integer;
+
+@ @<Set init...@>=
+for clabel_runner:=0 to 256 do
+ output_clabels[clabel_runner]:=false;
+
+@ @<Output any labels...@>=
+while i=label_table[sort_ptr].rr do begin
+ if not label_table[sort_ptr].ischar then begin
+ if not output_clabels[label_table[sort_ptr].cc] then begin
+ output_clabels[label_table[sort_ptr].cc]:=true;
+ left;
+ out('CLABEL');
+ out_char(label_table[sort_ptr].cc);
+ right;
+ end
+ end
+ else begin
+ left;
+ out('LABEL');
+ if label_table[sort_ptr].cc=xmax_char then out(' BOUNDARYCHAR')
+ else out_char(label_table[sort_ptr].cc);
+ right;
+ end;
+ incr(sort_ptr);
+ end
+
+@ @<Take care of commenting out...@>=
+if activity[i]=unreachable then begin
+ if level=1 then begin
+ left; out('COMMENT THIS PART OF THE PROGRAM IS NEVER USED!'); out_ln;
+ end
+ end
+else if level=2 then right
+
+@ @<Output step $i$...@>=
+begin k:=lig_step(i);
+if (l_skip_byte(k) div 256)=1 then begin
+ case l_op_byte(k) of
+ 17: begin
+ left; out('CPEN');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k));
+ right;
+ end;
+ 18: begin
+ left; out('CGLUE');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k));
+ right;
+ end;
+ 19: begin
+ left; out('CPENGLUE');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k) div 256);
+ out_hex_number(l_remainder(k) mod 256);
+ right;
+ end;
+ 20: begin
+ left; out('CKRN');
+ out_hex_number(l_next_char(k));
+ r:=l_remainder(k);
+ if r>=nk then begin
+ bad('Kern index too large.');
+@.Kern index too large@>
+ out(' R 0.0');
+ end
+ else out_fix(kern(r));
+ right;
+ end;
+ end;
+ end
+else if l_skip_byte(k)>stop_flag then begin
+ if (256*l_op_byte(k)+l_remainder(k))>=nl then
+ bad('Ligature unconditional stop command address is too big.');
+@.Ligature unconditional stop...@>
+ end
+else if l_op_byte(k)>=kern_flag then @<Output a kern step@>
+else @<Output a ligature step@>;
+if (l_skip_byte(k) mod 256)>0 then
+ if level=1 then @<Output either \.{SKIP} or \.{STOP}@>;
+end
+
+@ The \.{SKIP} command is a bit tricky, because we will be omitting all
+inaccessible commands.
+
+@<Output either...@>=
+begin
+if (l_skip_byte(k) mod 256)>=stop_flag then out('(STOP)')
+else begin
+ count:=0;
+ for ai:=(i+1) to (i+(l_skip_byte(k) mod 256)) do
+ if activity[ai]=accessible then incr(count);
+ out('(SKIP D ',count:1,')'); {possibly $count=0$, so who cares}
+ end;
+out_ln;
+end
+
+@ @<Output a kern step@>=
+begin if nonexistent(l_next_char(k)) then
+ if l_next_char(k)<>boundary_char then
+ correct_bad_char('Kern step for')(l_next_char)(set_l_next_char);
+@.Kern step for nonexistent...@>
+left; out('KRN'); out_char(l_next_char(k));
+r:=256*(l_op_byte(k)-kern_flag)+l_remainder(k);
+if r>=nk then
+ begin bad('Kern index too large.');
+@.Kern index too large@>
+ out(' R 0.0');
+ end
+else out_fix(kern(r));
+right;
+end
+
+@ @<Output a ligature step@>=
+begin
+if nonexistent(l_next_char(k)) then
+ if l_next_char(k)<>boundary_char then
+ correct_bad_char('Ligature step for')(l_next_char)(set_l_next_char);
+@.Ligature step for nonexistent...@>
+if nonexistent(l_remainder(k)) then
+ correct_bad_char('Ligature step produces the')(l_remainder)(set_l_remainder);
+@.Ligature step produces...@>
+left; r:=l_op_byte(k);
+if (r=4)or((r>7)and(r<>11)) then begin
+ print_ln('Ligature step with nonstandard code changed to LIG');
+ r:=0; set_l_op_byte(k,0);
+ end;
+if r mod 4>1 then out('/');
+out('LIG');
+if odd(r) then out('/');
+while r>3 do begin
+ out('>'); r:=r-4;
+ end;
+out_char(l_next_char(k)); out_char(l_remainder(k)); right;
+end
+
+@ The last thing on \.{TFtoPL}'s agenda is to go through the
+list of |char_info| and spew out the information about each individual
+character.
+
+@<Do the characters@>=
+sort_ptr:=0; {this will suppress `\.{STOP}' lines in ligature comments}
+c:=bc;
+while (c<=ec) do
+begin
+if width_index(c)>0 then begin
+ if chars_on_line=8 then begin
+ print_ln(' '); chars_on_line:=1;
+ end
+ else begin
+ if chars_on_line>0 then print(' ');
+ incr(chars_on_line);
+ end;
+ if no_repeats(c)>0 then begin
+ print_hex(c); print('-'); print_hex(c+no_repeats(c));
+ left; out('CHARREPEAT'); out_char(c); out_char(no_repeats(c)); out_ln;
+ end
+ else begin
+ print_hex(c); {progress report}
+ left; out('CHARACTER'); out_char(c); out_ln;
+ end;
+ @<Output the character's width@>;
+ if height_index(c)>0 then @<Output the character's height@>;
+ if depth_index(c)>0 then @<Output the character's depth@>;
+ if italic_index(c)>0 then @<Output the italic correction@>;
+ case tag(c) of
+ no_tag: do_nothing;
+ lig_tag: @<Output the applicable part of the ligature/kern
+ program as a comment@>;
+ list_tag: @<Output the character link unless there is a problem@>;
+ ext_tag: @<Output an extensible character recipe@>;
+ end; {there are no other cases}
+ for i:=0 to npc-1 do begin
+ if char_param(c,i)<>0 then begin
+ left;
+ if i<nki then begin
+ out('CHARIVALUE'); out_hex_number(i);
+ end
+ else if i<(nki+nkf) then begin
+ out('CHARFVALUE'); out_hex_number(i-nki);
+ end
+ else if i<(nki+nkf+nkr) then begin
+ out('CHARRULE'); out_hex_number(i-nki-nkf);
+ end
+ else if i<(nki+nkf+nkr+nkg) then begin
+ out('CHARGLUE'); out_hex_number(i-nki-nkf-nkr);
+ end
+ else if i<(nki+nkf+nkr+nkg+nkp) then begin
+ out('CHARPENALTY'); out_hex_number(i-nki-nkf-nkr-nkg);
+ end;
+ out_hex_number(char_param(c,i));
+ right;
+ end;
+ end;
+ right;
+ end;
+c:=c+1+no_repeats(c);
+end
+
+@ @<Output the character's width@>=
+if width_index(c)>=nw then range_error('Width')
+@.Width index for char...@>
+else begin left; out('CHARWD'); out_fix(width(c)); right;
+ end
+
+@ @<Output the character's height@>=
+if height_index(c)>=nh then range_error('Height')
+@.Height index for char...@>
+else begin left; out('CHARHT'); out_fix(height(c)); right;
+ end
+
+@ @<Output the character's depth@>=
+if depth_index(c)>=nd then range_error('Depth')
+@.Depth index for char@>
+else begin left; out('CHARDP'); out_fix(depth(c)); right;
+ end
+
+@ @<Output the italic correction@>=
+if italic_index(c)>=ni then range_error('Italic correction')
+@.Italic correction index for char...@>
+else begin left; out('CHARIC'); out_fix(italic(c)); right;
+ end
+
+@ @<Output the applicable part of the ligature...@>=
+begin left; out('COMMENT'); out_ln;@/
+i:=rremainder(c); r:=lig_step(i);
+if (l_skip_byte(r) mod 256)>stop_flag
+then i:=256*l_op_byte(r)+l_remainder(r);
+repeat @<Output step...@>;
+if (l_skip_byte(k) mod 256)>=stop_flag then i:=nl
+else i:=i+1+(l_skip_byte(k) mod 256);
+until i>=nl;
+right;
+end
+
+@ We want to make sure that there is no cycle of characters linked together
+by |list_tag| entries, since such a cycle would get \TeX\ into an endless
+loop. If such a cycle exists, the routine here detects it when processing
+the largest character code in the cycle.
+
+@<Output the character link unless there is a problem@>=
+begin r:=rremainder(c);
+if nonexistent(r) then
+ begin bad_char('Character list link to')(r); set_no_tag(c);
+@.Character list link...@>
+ end
+else begin while (r<c)and(tag(r)=list_tag) do r:=rremainder(r);
+ if r=c then
+ begin bad('Cycle in a character list!');
+@.Cycle in a character list@>
+ print('Character '); print_hex(c);
+ print_ln(' now ends the list.');
+ set_no_tag(c);
+ end
+ else begin left; out('NEXTLARGER'); out_char(rremainder(c));
+ right;
+ end;
+ end;
+end
+
+@ @<Output an extensible character recipe@>=
+if rremainder(c)>=ne then
+ begin range_error('Extensible'); set_no_tag(c);
+@.Extensible index for char@>
+ end
+else begin left; out('VARCHAR'); out_ln;
+ @<Output the extensible pieces that exist@>;
+ right;
+ end
+
+@ @<Glob...@>=
+@!exten_char:integer;
+
+@ @<Output the extensible pieces that...@>=
+for d:=0 to 3 do begin
+ if not ofm_on then begin
+ k:=exten(c)+d;
+ exten_char:=tfm[k];
+ end
+ else begin
+ k:=exten(c)+2*d;
+ exten_char:=256*tfm[k]+tfm[k+1];
+ end;
+ if (d=3)or(exten_char>0) then begin
+ left;
+ case d of
+ 0:out('TOP');@+1:out('MID');@+2:out('BOT');@+3:out('REP')@+end;
+ if nonexistent(exten_char) then out_char(c)
+ else out_char(exten_char);
+ right;
+ end
+ end
+
+@ Some of the extensible recipes may not actually be used, but \TeX\ will
+complain about them anyway if they refer to nonexistent characters.
+Therefore \.{TFtoPL} must check them too.
+
+@<Check the extensible recipes@>=
+if ne>0 then
+ for c:=0 to ne-1 do
+ for d:=0 to 3 do begin
+ if not ofm_on then begin
+ k:=4*(exten_base+c)+d;
+ exten_char:=tfm[k];
+ end
+ else begin
+ k:=4*(exten_base+c)+2*d;
+ exten_char:=256*tfm[k]+tfm[k+1];
+ end;
+ if (exten_char>0)or(d=3) then begin
+ if nonexistent(exten_char) then begin
+ bad_char('Extensible recipe involves the')(exten_char);
+@.Extensible recipe involves...@>
+ if d<3 then begin
+ if not ofm_on then begin
+ tfm[k]:=0;
+ end
+ else begin
+ tfm[k]:=0;
+ tfm[k+1]:=0;
+ end;
+ end;
+ end;
+ end;
+ end
+
+@* Checking for ligature loops.
+We have programmed almost everything but the most interesting calculation of
+all, which has been saved for last as a special treat. \TeX's extended
+ligature mechanism allows unwary users to specify sequences of ligature
+replacements that never terminate. For example, the pair of commands
+$$\.{(/LIG $x$ $y$) (/LIG $y$ $x$)}$$
+alternately replaces character $x$ by character $y$ and vice versa. A similar
+loop occurs if \.{(LIG/ $z$ $y$)} occurs in the program for $x$ and
+ \.{(LIG/ $z$ $x$)} occurs in the program for $y$.
+
+More complicated loops are also possible. For example, suppose the ligature
+programs for $x$ and $y$ are
+$$\vcenter{\halign{#\hfil\cr
+\.{(LABEL $x$)(/LIG/ $z$ $w$)(/LIG/> $w$ $y$)} \dots,\cr
+\.{(LABEL $y$)(LIG $w$ $x$)} \dots;\cr}}$$
+then the adjacent characters $xz$ change to $xwz$, $xywz$, $xxz$, $xxwz$,
+\dots, ad infinitum.
+
+@ To detect such loops, \.{TFtoPL} attempts to evaluate the function
+$f(x,y)$ for all character pairs $x$ and~$y$, where $f$ is defined as
+follows: If the current character is $x$ and the next character is
+$y$, we say the ``cursor'' is between $x$ and $y$; when the cursor
+first moves past $y$, the character immediately to its left is
+$f(x,y)$. This function is defined if and only if no infinite loop is
+generated when the cursor is between $x$ and~$y$.
+
+The function $f(x,y)$ can be defined recursively. It turns out that all pairs
+$(x,y)$ belong to one of five classes. The simplest class has $f(x,y)=y$;
+this happens if there's no ligature between $x$ and $y$, or in the cases
+\.{LIG/>} and \.{/LIG/>>}. Another simple class arises when there's a
+\.{LIG} or \.{/LIG>} between $x$ and~$y$, generating the character~$z$;
+then $f(x,y)=z$. Otherwise we always have $f(x,y)$ equal to
+either $f(x,z)$ or $f(z,y)$ or $f(f(x,z),y)$, where $z$ is the inserted
+ligature character.
+
+The first two of these classes can be merged; we can also consider
+$(x,y)$ to belong to the simple class when $f(x,y)$ has been evaluated.
+For technical reasons we allow $x$ to be 256 (for the boundary character
+at the left) or 257 (in cases when an error has been detected).
+
+For each pair $(x,y)$ having a ligature program step, we store
+$(x,y)$ in a hash table from which the values $z$ and $class$ can be read.
+
+@d simple=0 {$f(x,y)=z$}
+@d left_z=1 {$f(x,y)=f(z,y)$}
+@d right_z=2 {$f(x,y)=f(x,z)$}
+@d both_z=3 {$f(x,y)=f(f(x,z),y)$}
+@d pending=4 {$f(x,y)$ is being evaluated}
+
+@<Glob...@>=
+@!hash:array[0..hash_size] of integer;
+@!class:array[0..hash_size] of simple..pending;
+@!lig_z:array[0..hash_size] of xxchar_type;
+@!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|}
+@!hash_list:array[0..hash_size] of 0..hash_size;
+ {list of those nonzero entries}
+@!h,@!hh:0..hash_size; {indices into the hash table}
+@!x_lig_cycle,@!y_lig_cycle:integer; {problematic ligature pair}
+
+@ @<Check for ligature cycles@>=
+hash_ptr:=0; y_lig_cycle:=xmax_char;
+for hh:=0 to hash_size do hash[hh]:=0; {clear the hash table}
+for c:=bc to ec do if tag(c)=lig_tag then
+ begin i:=rremainder(c);
+ if (l_skip_byte(lig_step(i)) mod 256)>stop_flag then
+ i:=256*l_op_byte(lig_step(i))+l_remainder(lig_step(i));
+ @<Enter data for character $c$ starting at location |i| in the hash table@>;
+ end;
+if bchar_label<nl then
+ begin c:=xmax_char; i:=bchar_label;
+ @<Enter data for character $c$ starting at location |i| in the hash table@>;
+ end;
+if hash_ptr=hash_size then
+ begin print_ln('Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ goto final_end;
+ end;
+for hh:=1 to hash_ptr do
+ begin r:=hash_list[hh];
+ if class[r]>simple then {make sure $f$ is defined}
+ r:=f(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+ end;
+if y_lig_cycle<xmax_char then
+ begin print('Infinite ligature loop starting with ');
+@.Infinite ligature loop...@>
+ if x_lig_cycle=xmax_char
+ then print('boundary')@+else print_hex(x_lig_cycle);
+ print(' and '); print_hex(y_lig_cycle); print_ln('!');
+ out('(INFINITE LIGATURE LOOP MUST BE BROKEN!)'); goto final_end;
+ end
+
+@ @<Enter data for character $c$...@>=
+repeat hash_input; k:=l_skip_byte(lig_step(i));
+if k>=stop_flag then i:=nl
+else i:=i+1+k;
+until i>=nl
+
+@ We use an ``ordered hash table'' with linear probing, because such a table
+is efficient when the lookup of a random key tends to be unsuccessful.
+
+@p procedure hash_input; {enter data for character |c| and command |i|}
+label 30; {go here for a quick exit}
+var @!cc:simple..both_z; {class of data being entered}
+@!zz:char_type; {function value or ligature character being entered}
+@!y:char_type; {the character after the cursor}
+@!key:integer; {value to be stored in |hash|}
+@!t:integer; {temporary register for swapping}
+begin if hash_ptr=hash_size then goto 30;
+@<Compute the command parameters |y|, |cc|, and |zz|@>;
+key:=xmax_char*c+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size;
+while hash[h]>0 do
+ begin if hash[h]<=key then
+ begin if hash[h]=key then goto 30; {unused ligature command}
+ t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion}
+ t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap}
+ t:=lig_z[h]; lig_z[h]:=zz; zz:=t;
+ end;
+ if h>0 then decr(h)@+else h:=hash_size;
+ end;
+hash[h]:=key; class[h]:=cc; lig_z[h]:=zz;
+incr(hash_ptr); hash_list[hash_ptr]:=h;
+30:end;
+
+@ We must store kern commands as well as ligature commands, because
+the former might make the latter inapplicable.
+
+@<Compute the command param...@>=
+k:=lig_step(i); y:=l_next_char(k); t:=l_op_byte(k);
+cc:=simple; zz:=l_remainder(k);
+if t>=kern_flag then zz:=y
+else begin case t of
+ 0,6:do_nothing; {\.{LIG},\.{/LIG>}}
+ 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}}
+ 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}}
+ 2:cc:=right_z; {\.{/LIG}}
+ 3:cc:=both_z; {\.{/LIG/}}
+ end; {there are no other cases}
+ end
+
+@ Evaluation of $f(x,y)$ is handled by two mutually recursive procedures.
+Kind of a neat algorithm, generalizing a depth-first search.
+
+@p function f(@!h,@!x,@!y:index):index; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+function eval(@!x,@!y:index):index; {compute $f(x,y)$ with hashtable lookup}
+var @!key:integer; {value sought in hash table}
+begin key:=xmax_char*x+y+1; h:=(hash_mult*key) mod hash_size;
+while hash[h]>key do
+ if h>0 then decr(h)@+else h:=hash_size;
+if hash[h]<key then eval:=y {not in ordered hash table}
+else eval:=f(h,x,y);
+end;
+
+@ Pascal's beastly convention for |forward| declarations prevents us from
+saying |function f(h,x,y:index):index| here.
+
+@p function f;
+begin case class[h] of
+simple: do_nothing;
+left_z: begin class[h]:=pending; lig_z[h]:=eval(lig_z[h],y); class[h]:=simple;
+ end;
+right_z: begin class[h]:=pending; lig_z[h]:=eval(x,lig_z[h]); class[h]:=simple;
+ end;
+both_z: begin class[h]:=pending; lig_z[h]:=eval(eval(x,lig_z[h]),y);
+ class[h]:=simple;
+ end;
+pending: begin x_lig_cycle:=x; y_lig_cycle:=y;
+ lig_z[h]:=xxmax_char; class[h]:=simple;
+ end; {the value |xxmax_char| will break all cycles,
+ since it's not in |hash|}
+end; {there are no other cases}
+f:=lig_z[h];
+end;
+
+@* The main program.
+The routines sketched out so far need to be packaged into separate procedures,
+on some systems, since some \PASCAL\ compilers place a strict limit on the
+size of a routine. The packaging is done here in an attempt to avoid some
+system-dependent changes.
+
+First comes the |organize| procedure, which reads the input data and
+gets ready for subsequent events. If something goes wrong, the routine
+returns |false|.
+
+@p function organize:boolean;
+label final_end, 30;
+var tfm_ptr:index; {an index into |tfm|}
+begin @<Read the whole input file@>;@/
+@<Set subfile sizes |lh|, |bc|, \dots, |np|@>;@/
+@<Compute the base addresses@>;@/
+organize:=true; goto 30;
+final_end: organize:=false;
+30: end;
+
+@ Next we do the simple things.
+
+@p procedure do_simple_things;
+var i:integer; {an index to words of a subfile}
+begin @<Do the header@>;@/
+@<Do the parameters@>;@/
+@<Do the ivalue parameters@>;@/
+@<Do the fvalue parameters@>;@/
+@<Do the mvalue parameters@>;@/
+@<Do the rule parameters@>;@/
+@<Do the glue parameters@>;@/
+@<Do the penalty parameters@>;@/
+@<Check the |fix_word| entries@>@/
+end;
+
+@ And then there's a routine for individual characters.
+
+@p procedure do_characters;
+var @!c:integer; {character being done}
+@!k:index; {a random index}
+@!ai:0..lig_size; {index into |activity|}
+begin @<Do the characters@>;@/
+end;
+
+@ Here is where \.{TFtoPL} begins and ends.
+@p begin initialize;@/
+if not organize then goto final_end;
+do_simple_things;@/
+@<Do the ligatures and kerns@>;
+@<Check the extensible recipes@>;
+do_characters; print_ln('.');@/
+if level<>0 then print_ln('This program isn''t working!');
+@.This program isn't working@>
+if not perfect then
+ out('(COMMENT THE OFM FILE WAS BAD, SO THE DATA HAS BEEN CHANGED!)');
+@.THE OFM FILE WAS BAD...@>
+final_end:end.
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TFtoPL} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.
diff --git a/Build/source/texk/web2c/omegaware/opl2ofm.ch b/Build/source/texk/web2c/omegaware/opl2ofm.ch
new file mode 100644
index 00000000000..a080c2479ea
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/opl2ofm.ch
@@ -0,0 +1,337 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original pltotf.ch.
+%
+% pltotf.ch for C compilation with web2c.
+%
+% 04/04/83 (PC) Original version, made to work with version 1.2 of PLtoTF.
+% 04/16/83 (PC) Brought up to version 1.3 of PLtoTF.
+% 06/30/83 (HWT) Revised changefile format for version 1.7 Tangle
+% 07/28/83 (HWT) Brought up to version 2
+% 12/19/86 (ETM) Brought up to version 2.1
+% 07/05/87 (ETM) Brought up to version 2.3
+% 03/22/88 (ETM) Converted for use with WEB to C
+% 11/29/89 (KB) Version 3.
+% 01/16/90 (SR) Version 3.2.
+% (more recent changes in the ChangeLog)
+
+@x [0] WEAVE: print changes only.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+%\let\maybe=\iffalse
+%\def\title{OPL2OFM changes for C}
+@z
+
+@x [still 2] No banner unless verbose.
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+@z
+
+@x [3] Larger constants.
+@!buf_size=60; {length of lines displayed in error messages}
+@y
+@!buf_size=3000; {max input line length, output error line length}
+@z
+%@x
+%@!max_lig_steps=5000;
+% {maximum length of ligature program, must be at most $32767-257=32510$}
+%@!max_kerns=500; {the maximum number of distinct kern values}
+%@!hash_size=5003; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@y
+%@!max_lig_steps=32500;
+% {maximum length of ligature program, must be at most $32767-257=32510$}
+%@!max_kerns=15000; {the maximum number of distinct kern values}
+%@!hash_size=15077; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@z
+
+@x [6] Open PL file.
+reset(pl_file);
+@y
+reset (pl_file, pl_name);
+if verbose then begin
+ print (banner);
+ print_ln (version_string);
+end;
+@z
+
+@x [16] Open TFM file.
+@ On some systems you may have to do something special to write a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(tfm_file);
+@y
+@ On some systems you may have to do something special to write a
+packed file of bytes. It's no problem in C.
+@^system dependencies@>
+
+@<Set init...@>=
+rewritebin (tfm_file, tfm_name);
+@z
+
+@x [79] `index' might be a library routine.
+|k|th element of its list.
+@y
+|k|th element of its list.
+@d index == index_var
+@z
+
+@x [103] No output (except errors) unless verbose.
+@<Print |c| in hex notation@>;
+@y
+if verbose then @<Print |c| in hex notation@>;
+@z
+
+% [27, 28] Change strings to C char pointers. The Pascal strings are
+% indexed starting at 1, so we pad with a blank.
+@x
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+@y
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: c_string;
+ {strings for output in the user's external character set}
+@!ASCII_all: packed array[0..256] of char;
+@!MBL_string,@!RI_string,@!RCE_string: c_string;
+ {handy string constants for |face| codes}
+@z
+
+@x
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:='0123456789ABCDEF';@/
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+@y
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:=' @@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:=' `abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:=' 0123456789ABCDEF';@/
+strcpy (ASCII_all, ASCII_04);
+strcat (ASCII_all, '@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_');
+strcat (ASCII_all, '`abcdefghijklmnopqrstuvwxyz{|}~');@/
+MBL_string:=' MBL'; RI_string:=' RI '; RCE_string:=' RCE';
+@z
+
+@x [115] Output of reals.
+@ @d round_message(#)==if delta>0 then print_ln('I had to round some ',
+@.I had to round...@>
+ #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.')
+@y
+@ @d round_message(#)==if delta>0 then begin print('I had to round some ',
+@.I had to round...@>
+ #,'s by '); print_real((((delta+1) div 2)/@'4000000),1,7);
+ print_ln(' units.'); end
+@z
+
+% [118] Change the name of the variable `class', since AIX 3.1's <math.h>
+% defines a function by that name.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@d pending=4 {$f(x,y)$ is being evaluated}
+@y
+@d pending=4 {$f(x,y)$ is being evaluated}
+@d class == class_var {Avoid problems with AIX \.{<math.h>}}
+@z
+
+% [123] web2c can't handle these mutually recursive procedures.
+% But let's do a fake definition of f here, so that it gets into web2c's
+% symbol table...
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+@y
+@p
+ifdef('notdef')
+function f(@!h,@!x,@!y:indx):indx; begin end;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+endif('notdef')
+@z
+
+% [124] ... and then really define it now.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@p function f;
+@y
+@p function f(@!h,@!x,@!y:indx):indx;
+@z
+
+@x [127] Fix up output of bytes.
+@d out(#)==write(tfm_file,#)
+@y
+@d out(#)==putbyte(#,tfm_file)
+@z
+
+@x [136] Fix output of reals.
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if abs(x/design_units)>=16.0 then begin
+ print_ln('The relative dimension ',x/@'4000000:1:3,
+ ' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then print(' =',design_units/@'200000:1:3,
+ ' designunits');
+@y
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if fabs(x/design_units)>=16.0 then begin
+ print('The relative dimension ');
+ print_real(x/@'4000000,1,3);
+ print_ln(' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then begin print(' =');
+ print_real(design_units/@'200000,1,3);
+ print(' designunits');
+ end;
+@z
+
+% [141] char_remainder[c] is unsigned, and label_table[sort_ptr].rr
+% might be -1, and if -1 is coerced to being unsigned, it will be bigger
+% than anything else.
+@x
+ while label_table[sort_ptr].rr>char_remainder[c] do begin
+@y
+ while label_table[sort_ptr].rr>intcast(char_remainder[c]) do begin
+@z
+
+@x [147] Be quiet unless verbose.
+read_input; print('.');@/
+@y
+read_input;
+if verbose then print_ln('.');
+@z
+
+@x [148] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{PLtoTF} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 3; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Initialize the option variables@>;
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('opl2ofm');
+
+ end else if argument_is ('help') then begin
+ usage_help (OPL2OFM_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.
+ We must have one or two remaining arguments.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc) then begin
+ write_ln (stderr, 'opl2ofm: Need one or two file arguments.');
+ usage ('opl2ofm');
+ end;
+
+ pl_name := extend_filename (cmdline (optind), 'opl');
+
+ {If an explicit output filename isn't given, construct it from |pl_name|.}
+ if optind + 2 = argc then begin
+ tfm_name := extend_filename (cmdline (optind + 1), 'ofm');
+ end else begin
+ tfm_name := basename_change_suffix (pl_name, '.opl', '.ofm');
+ end;
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Print progress information?
+
+@<Define the option...@> =
+long_options[current_option].name := 'verbose';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := address_of (verbose);
+long_options[current_option].val := 1;
+incr (current_option);
+
+@
+@<Glob...@> =
+@!verbose: c_int_type;
+
+@
+@<Initialize the option...@> =
+verbose := false;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Global...@> =
+@!tfm_name,@!pl_name:c_string;
+@z
diff --git a/Build/source/texk/web2c/omegaware/opl2ofm.web b/Build/source/texk/web2c/omegaware/opl2ofm.web
new file mode 100644
index 00000000000..df91a25dfee
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/opl2ofm.web
@@ -0,0 +1,4363 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--2000 John Plaice and Yannis Haralambous
+% applies only to the changes to the original pltotf.web
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 0 was implemented in January 1982.
+% In February 1982 a new restriction on ligature steps was added.
+% In June 1982 the routines were divided into smaller pieces for IBM people.
+% Hex was added in September 1982, and the result became "Version 1".
+% Version 1.1 fixed a bug in section 28 (since eoln is undefined after eof).
+% Slight changes were made in October, 1982, for version 0.6 of TeX.
+% Version 1.2 fixed a bug in section 115 (TOP, MID, and BOT can be zero)
+% Version 1.3 (April 1983) blanked out unused BCPL header bytes
+% Version 2 (July 1983) was released with TeX version 0.999.
+% Version 2.1 (September 1983) changed TEXINFO to FONTDIMEN.
+% Version 2.2 (May 1985) added checksum computation to match METAFONT.
+% Version 2.3 (August 1985) introduced `backup' to fix a minor bug.
+% Version 3 (October 1989) introduced extended ligature features.
+% Version 3.1 (November 1989) fixed two bugs (notably min_nl:=0).
+% Version 3.2 (December 1989) improved `shorten', increased max_letters.
+% Version 3.3 (September 1990) fixed `nonexistent char 0' (John Gourlay).
+% Version 3.4 (March 1991) has more robust `out_scaled' (Wayne Sullivan).
+% Version 3.5 (March 1995) initialized lk_step_ended (Armin K\"ollner).
+
+% Version 1.0 of OPL2OFM (March 1997) allows one to read OPL files
+% and generate OFM files.
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\font\logo=logo10 % for the METAFONT logo
+\def\MF{{\logo METAFONT}}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{OPL2OFM}
+\def\contentspagenumber{301}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont OPL2OFM} processor}
+ \vskip 15pt
+ \centerline{(Version 1.11, February 2000)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ The preparation of the original report
+ was supported in part by the National Science
+ Foundation under grants IST-8201926 and MCS-8300984,
+ and by the System Development Foundation. `\TeX' is a
+ trademark of the American Mathematical Society.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{OPL2OFM} utility program converts property-list (``\.{PL}''
+and (``\.{OPL}'') files into equivalent \TeX\ and $\Omega$ font metric
+(``\.{TFM}'' and ``\.{OFM}) files. It also makes a thorough check of
+the given \.{PL} or \.{OPL} file, so that the \.{TFM} or \.{OFM} file
+should be acceptable to \TeX\ or $\Omega$.
+
+The first \.{PLtoTF} program was designed by Leo Guibas in the summer of
+1978. Contributions by Frank Liang, Doug Wyatt, and Lyle Ramshaw
+also had a significant effect on the evolution of the present code.
+
+Extensions for an enhanced ligature mechanism were added by D. E. Knuth
+in 1989.
+
+Extensions to handle extended font metric files (``\.{OFM}'') were
+added by John Plaice in December 1995 and January 1996, resulting in the
+new program \.{OPLtoOFM}. In the following documentation, all unchanged
+references to the \.{PLtoTF} program and to \.{TFM} and \.{PL} files also
+apply to the \.{OPLtoOFM} program and to \.{OFM} and \.{OPL} files.
+
+The |banner| string defined here should be changed whenever \.{OPLtoOFM}
+gets modified.
+
+@d banner=='This is OPL2OFM, Version 1.11'
+
+@ This program is written entirely in standard \PASCAL, except that
+it has to do some slightly system-dependent character code conversion
+on input. Furthermore, lower case letters are used in error messages;
+they could be converted to upper case if necessary. The input is read
+from |pl_file|, and the output is written on |tfm_file|; error messages and
+other remarks are written on the |output| file, which the user may
+choose to assign to the terminal if the system permits it.
+@^system dependencies@>
+
+The term |print| is used instead of |write| when this program writes on
+the |output| file, so that all such output can be easily deflected.
+
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+
+@p program OPL2OFM(@!pl_file,@!tfm_file,@!output);
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+ @<Set initial values@>@/
+ end;
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{PLtoTF}'s capacity.
+
+@<Constants...@>=
+@!buf_size=60; {length of lines displayed in error messages}
+@!max_header_bytes=100; {four times the maximum number of words allowed in
+ the \.{TFM} file header block, must be 1024 or less}
+@!max_param_words=100; {the maximum number of \.{fontdimen} parameters allowed}
+@!max_lig_steps=800000;
+ {maximum length of ligature program, must be at most $32767-257=32510$}
+@!xmax_label=800001;
+@!max_kerns=50000; {the maximum number of distinct kern values}
+@!hash_size=130003; {preferably a prime number, a bit larger than the number
+ of character pairs in lig/kern steps}
+@!hash_mult=16007; {another prime}
+@!tfm_size=2000000; {maximum length of |tfm| data, in bytes}
+@!lig_size=800000; {maximum length of |lig_kern| program, in words}
+@!max_char=65535; {the largest character number in a font}
+@!xmax_char=65536; {|max_char|+1}
+@!xxmax_char=65537;{|max_char|+2}
+@!xxxmax_char=65538;{|max_char|+3}
+@!mem_size=262144; {|max_char|*4+8}
+@!max_width=65535; {the largest character width number}
+@!max_height=255; {the largest character height number}
+@!max_depth=255; {the largest character depth number}
+@!max_italic=255; {the largest character italic correction number}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d do_nothing == {empty statement}
+
+@* Property list description of font metric data.
+The idea behind \.{PL} files is that precise details about fonts, i.e., the
+facts that are needed by typesetting routines like \TeX, sometimes have to
+be supplied by hand. The nested property-list format provides a reasonably
+convenient way to do this.
+
+A good deal of computation is necessary to parse and process a
+\.{PL} file, so it would be inappropriate for \TeX\ itself to do this
+every time it loads a font. \TeX\ deals only with the compact descriptions
+of font metric data that appear in \.{TFM} files. Such data is so compact,
+however, it is almost impossible for anybody but a computer to read it.
+The purpose of \.{PLtoTF} is to convert from a human-oriented file of text
+to a computer-oriented file of binary numbers.
+
+@<Glob...@>=
+@!pl_file:text;
+
+@ @<Set init...@>=
+reset(pl_file);
+
+@ A \.{PL} file is a list of entries of the form
+$$\.{(PROPERTYNAME VALUE)}$$
+where the property name is one of a finite set of names understood by
+this program, and the value may itself in turn be a property list.
+The idea is best understood by looking at an example, so let's consider
+a fragment of the \.{PL} file for a hypothetical font.
+$$\vbox{\halign{\.{#}\hfil\cr
+(FAMILY NOVA)\cr
+(FACE F MIE)\cr
+(CODINGSCHEME ASCII)\cr
+(DESIGNSIZE D 10)\cr
+(DESIGNUNITS D 18)\cr
+(COMMENT A COMMENT IS IGNORED)\cr
+(COMMENT (EXCEPT THIS ONE ISN'T))\cr
+(COMMENT (ACTUALLY IT IS, EVEN THOUGH\cr
+\qquad\qquad IT SAYS IT ISN'T))\cr
+(FONTDIMEN\cr
+\qquad (SLANT R -.25)\cr
+\qquad (SPACE D 6)\cr
+\qquad (SHRINK D 2)\cr
+\qquad (STRETCH D 3)\cr
+\qquad (XHEIGHT R 10.55)\cr
+\qquad (QUAD D 18)\cr
+\qquad )\cr
+(LIGTABLE\cr
+\qquad (LABEL C f)\cr
+\qquad (LIG C f O 200)\cr
+\qquad (SKIP D 1)\cr
+\qquad (LABEL O 200)\cr
+\qquad (LIG C i O 201)\cr
+\qquad (KRN O 51 R 1.5)\cr
+\qquad (/LIG C ? C f)\cr
+\qquad (STOP)\cr
+\qquad )\cr
+(CHARACTER C f\cr
+\qquad (CHARWD D 6)\cr
+\qquad (CHARHT R 13.5)\cr
+\qquad (CHARIC R 1.5)\cr
+\qquad )\cr}}$$
+This example says that the font whose metric information is being described
+belongs to the hypothetical
+\.{NOVA} family; its face code is medium italic extended;
+and the characters appear in ASCII code positions. The design size is 10 points,
+and all other sizes in this \.{PL} file are given in units such that 18 units
+equals the design size. The font is slanted with a slope of $-.25$ (hence the
+letters actually slant backward---perhaps that is why the family name is
+\.{NOVA}). The normal space between words is 6 units (i.e., one third of
+the 18-unit design size), with glue that shrinks by 2 units or stretches by 3.
+The letters for which accents don't need to be raised or lowered are 10.55
+units high, and one em equals 18 units.
+
+The example ligature table is a bit trickier. It specifies that the
+letter \.f followed by another \.f is changed to code @'200, while
+code @'200 followed by \.i is changed to @'201; presumably codes @'200
+and @'201 represent the ligatures `ff' and `ffi'. Moreover, in both cases
+\.f and @'200, if the following character is the code @'51 (which is a
+right parenthesis), an additional 1.5 units of space should be inserted
+before the @'51. (The `\.{SKIP}~\.D~\.1' skips over one \.{LIG} or
+\.{KRN} command, which in this case is the second \.{LIG}; in this way
+two different ligature/kern programs can come together.)
+Finally, if either \.f or @'200 is followed by a question mark,
+the question mark is replaced by \.f and the ligature program is
+started over. (Thus, the character pair `\.{f?}' would actually become
+the ligature `ff', and `\.{ff?}' or `\.{f?f}' would become `fff'. To
+avoid this restart procedure, the \.{/LIG} command could be replaced
+by \.{/LIG>}; then `\.{f?} would become `f\kern0ptf' and `\.{f?f}'
+would become `f\kern0ptff'.)
+
+Character \.f itself is 6 units wide and 13.5 units tall, in this example.
+Its depth is zero (since \.{CHARDP} is not given), and its italic correction
+is 1.5 units.
+
+@ The example above illustrates most of the features found in \.{PL} files.
+Note that some property names, like \.{FAMILY} or \.{COMMENT}, take a
+string as their value; this string continues until the first unmatched
+right parenthesis. But most property names, like \.{DESIGNSIZE} and \.{SLANT}
+and \.{LABEL}, take a number as their value. This number can be expressed in
+a variety of ways, indicated by a prefixed code; \.D stands for decimal,
+\.H for hexadecimal, \.O for octal, \.R for real, \.C for character, and
+\.F for ``face.'' Other property names, like \.{LIG}, take two numbers as
+their value. And still other names, like \.{FONTDIMEN} and \.{LIGTABLE} and
+\.{CHARACTER}, have more complicated values that involve property lists.
+
+A property name is supposed to be used only in an appropriate property
+list. For example, \.{CHARWD} shouldn't occur on the outer level or
+within \.{FONTDIMEN}.
+
+The individual property-and-value pairs in a property list can appear in
+any order. For instance, `\.{SHRINK}' precedes `\.{STRETCH}' in the above
+example, although the \.{TFM} file always puts the stretch parameter first.
+One could even give the information about characters like `\.f' before
+specifying the number of units in the design size, or before specifying the
+ligature and kerning table. However, the \.{LIGTABLE} itself is an exception
+to this rule; the individual elements of the \.{LIGTABLE} property list
+can be reordered only to a certain extent without changing the meaning
+of that table.
+
+If property-and-value pairs are omitted, a default value is used. For example,
+we have already noted that the default for \.{CHARDP} is zero. The default
+for {\sl every\/} numeric value is, in fact, zero, unless otherwise stated
+below.
+
+If the same property name is used more than once, \.{PLtoTF} will not notice
+the discrepancy; it simply uses the final value given. Once again, however, the
+\.{LIGTABLE} is an exception to this rule; \.{PLtoTF} will complain if there
+is more than one label for some character. And of course many of the
+entries in the \.{LIGTABLE} property list have the same property name.
+
+From these rules, you can guess (correctly) that \.{PLtoTF} operates in four
+main steps. First it assigns the default values to all properties; then it scans
+through the \.{PL} file, changing property values as new ones are seen; then
+it checks the information and corrects any problems; and finally it outputs
+the \.{TFM} file.
+
+@ Instead of relying on a hypothetical example, let's consider a complete
+grammar for \.{PL} files. At the outer level, the following property names
+are valid:
+
+\yskip\hang\.{CHECKSUM} (four-byte value). The value, which should be a
+nonnegative integer less than $2^{32}$, is used to identify a particular
+version of a font; it should match the check sum value stored with the font
+itself. An explicit check sum of zero is used to bypass
+check sum testing. If no checksum is specified in the \.{PL} file,
+\.{PLtoTF} will compute the checksum that \MF\ would compute from the
+same data.
+
+\yskip\hang\.{DESIGNSIZE} (numeric value, default is 10). The value, which
+should be a real number in the range |1.0<=x<2048|, represents the default
+amount by which all quantities will be scaled if the font is not loaded
+with an `\.{at}' specification. For example, if one says
+`\.{\\font\\A=cmr10 at 15pt}' in \TeX\ language, the design size in the \.{TFM}
+file is ignored and effectively replaced by 15 points; but if one simply
+says `\.{\\font\\A=cmr10}' the stated design size is used. This quantity is
+always in units of printer's points.
+
+\yskip\hang\.{DESIGNUNITS} (numeric value, default is 1). The value
+should be a positive real number; it says how many units equals the design
+size (or the eventual `\.{at}' size, if the font is being scaled). For
+example, suppose you have a font that has been digitized with 600 pixels per
+em, and the design size is one em; then you could say `\.{(DESIGNUNITS R 600)}'
+if you wanted to give all of your measurements in units of pixels.
+
+\yskip\hang\.{CODINGSCHEME} (string value, default is `\.{UNSPECIFIED}').
+The string should not contain parentheses, and its length must be less than 40.
+It identifies the correspondence between the numeric codes and font characters.
+(\TeX\ ignores this information, but other software programs make use of it.)
+
+\yskip\hang\.{FAMILY} (string value, default is `\.{UNSPECIFIED}').
+The string should not contain parentheses, and its length must be less than 20.
+It identifies the name of the family to which this font belongs, e.g.,
+`\.{HELVETICA}'. (\TeX\ ignores this information; but it is needed, for
+example, when converting \.{DVI} files to \.{PRESS} files for Xerox
+equipment.)
+
+\yskip\hang\.{FACE} (one-byte value). This number, which must lie between
+0 and 255 inclusive, is a subsidiary ident\-ifi\-ca\-tion of the font within its
+family. For example, bold italic condensed fonts might have the same family name
+as light roman extended fonts, differing only in their face byte. (\TeX\
+ignores this information; but it is needed, for example, when converting
+\.{DVI} files to \.{PRESS} files for Xerox equipment.)
+
+\yskip\hang\.{SEVENBITSAFEFLAG} (string value, default is `\.{FALSE}'). The
+value should start with either `\.T' (true) or `\.F' (false). If true, character
+codes less than 128 cannot lead to codes of 128 or more via ligatures or
+charlists or extensible characters. (\TeX82 ignores this flag, but older
+versions of \TeX\ would only accept \.{TFM} files that were seven-bit safe.)
+\.{PLtoTF} computes the correct value of this flag and gives an error message
+only if a claimed ``true'' value is incorrect.
+
+\yskip\hang\.{HEADER} (a one-byte value followed by a four-byte value).
+The one-byte value should be between 18 and a maximum limit that can be
+raised or lowered depending on the compile-time setting of |max_header_bytes|.
+The four-byte value goes into the header word whose index is the one-byte
+value; for example, to set |header[18]:=1|, one may write
+`\.{(HEADER D 18 O 1)}'. This notation is used for header information that
+is presently unnamed. (\TeX\ ignores it.)
+
+\yskip\hang\.{FONTDIMEN} (property list value). See below for the names
+allowed in this property list.
+
+\yskip\hang\.{LIGTABLE} (property list value). See below for the rules
+about this special kind of property list.
+
+\yskip\hang\.{BOUNDARYCHAR} (integer value). If this character appears in
+a \.{LIGTABLE} command, it matches ``end of word'' as well as itself.
+If no boundary character is given and no \.{LABEL} \.{BOUNDARYCHAR} occurs
+within \.{LIGTABLE}, word boundaries will not affect ligatures or kerning.
+
+\yskip\hang\.{CHARACTER}. The value is an integer followed by
+a property list. The integer represents the number of a character that is
+present in the font; the property list of a character is defined below.
+The default is an empty property list.
+
+@ Numeric property list values can be given in various forms identified by
+a prefixed letter.
+
+\yskip\hang\.C denotes an ASCII character, which should be a standard visible
+character that is not a parenthesis. The numeric value will therefore be
+between @'41 and @'176 but not @'50 or @'51.
+
+\yskip\hang\.D denotes a decimal integer, which must be nonnegative and
+less than 256. (Use \.R for larger values or for negative values.)
+
+\yskip\hang\.F denotes a three-letter Xerox face code; the admissible codes
+are \.{MRR}, \.{MIR}, \.{BRR}, \.{BIR}, \.{LRR}, \.{LIR}, \.{MRC}, \.{MIC},
+\.{BRC}, \.{BIC}, \.{LRC}, \.{LIC}, \.{MRE}, \.{MIE}, \.{BRE}, \.{BIE},
+\.{LRE}, and \.{LIE}, denoting the integers 0 to 17, respectively.
+
+\yskip\hang\.O denotes an unsigned octal integer, which must be less than
+$2^{32}$, i.e., at most `\.{O 37777777777}'.
+
+\yskip\hang\.H denotes an unsigned hexadecimal integer, which must be less than
+$2^{32}$, i.e., at most `\.{H FFFFFFFF}'.
+
+\yskip\hang\.R denotes a real number in decimal notation, optionally preceded
+by a `\.+' or `\.-' sign, and optionally including a decimal point. The
+absolute value must be less than 2048.
+
+@ The property names allowed in a \.{FONTDIMEN} property list correspond to
+various \TeX\ parameters, each of which has a (real) numeric value. All
+of the parameters except \.{SLANT} are in design units. The admissible
+names are \.{SLANT}, \.{SPACE}, \.{STRETCH}, \.{SHRINK}, \.{XHEIGHT},
+\.{QUAD}, \.{EXTRASPACE}, \.{NUM1}, \.{NUM2}, \.{NUM3}, \.{DENOM1},
+\.{DENOM2}, \.{SUP1}, \.{SUP2}, \.{SUP3}, \.{SUB1}, \.{SUB2}, \.{SUPDROP},
+\.{SUBDROP}, \.{DELIM1}, \.{DELIM2}, and \.{AXISHEIGHT}, for parameters
+1~to~22. The alternate names \.{DEFAULTRULETHICKNESS},
+\.{BIGOPSPACING1}, \.{BIGOPSPACING2}, \.{BIGOPSPACING3},
+\.{BIGOPSPACING4}, and \.{BIGOPSPACING5}, may also be used for parameters
+8 to 13.
+
+The notation `\.{PARAMETER} $n$' provides another way to specify the
+$n$th parameter; for example, `\.{(PARAMETER} \.{D 1 R -.25)}' is another way
+to specify that the \.{SLANT} is $-0.25$. The value of $n$ must be positive
+and less than |max_param_words|.
+
+@ The elements of a \.{CHARACTER} property list can be of six different types.
+
+\yskip\hang\.{CHARWD} (real value) denotes the character's width in
+design units.
+
+\yskip\hang\.{CHARHT} (real value) denotes the character's height in
+design units.
+
+\yskip\hang\.{CHARDP} (real value) denotes the character's depth in
+design units.
+
+\yskip\hang\.{CHARIC} (real value) denotes the character's italic correction in
+design units.
+
+\yskip\hang\.{NEXTLARGER} (integer value), specifies the character that
+follows the present one in a ``charlist.'' The value must be the number of a
+character in the font, and there must be no infinite cycles of supposedly
+larger and larger characters.
+
+\yskip\hang\.{VARCHAR} (property list value), specifies an extensible character.
+This option and \.{NEXTLARGER} are mutually exclusive; i.e., they cannot
+both be used within the same \.{CHARACTER} list.
+
+\yskip\noindent
+The elements of a \.{VARCHAR} property list are either \.{TOP}, \.{MID},
+\.{BOT} or \.{REP}; the values are integers, which must be zero or the number
+of a character in the font. A zero value for \.{TOP}, \.{MID}, or \.{BOT} means
+that the corresponding piece of the extensible character is absent. A nonzero
+value, or a \.{REP} value of zero, denotes the character code used to make
+up the top, middle, bottom, or replicated piece of an extensible character.
+
+@ A \.{LIGTABLE} property list contains elements of four kinds, specifying a
+program in a simple command language that \TeX\ uses for ligatures and kerns.
+If several \.{LIGTABLE} lists appear, they are effectively concatenated into
+a single list.
+
+\yskip\hang\.{LABEL} (integer value) means that the program for the
+stated character value starts here. The integer must be the number of a
+character in the font; its \.{CHARACTER} property list must not have a
+\.{NEXTLARGER} or \.{VARCHAR} field. At least one \.{LIG} or \.{KRN} step
+must follow.
+
+\yskip\hang\.{LABEL} \.{BOUNDARYCHAR} means that the program for
+beginning-of-word ligatures starts here.
+
+\yskip\hang\.{LIG} (two integer values). The instruction `\.{(LIG} $c$ $r$\.)'
+means, ``If the next character is $c$, then insert character~$r$ and
+possibly delete the current character and/or~$c$;
+otherwise go on to the next instruction.''
+Characters $r$ and $c$ must be present in the font. \.{LIG} may be immediately
+preceded or followed by a slash, and then immediately followed by \.>
+characters not exceeding the number of slashes. Thus there are eight
+possible forms:
+$$\hbox to .8\hsize{\.{LIG}\hfil\.{/LIG}\hfil\.{/LIG>}\hfil
+\.{LIG/}\hfil\.{LIG/>}\hfil\.{/LIG/}\hfil\.{/LIG/>}\hfil\.{/LIG/>>}}$$
+The slashes specify retention of the left or right original character; the
+\.> signs specify passing over the result without further ligature processing.
+
+\yskip\hang\.{KRN} (an integer value and a real value). The instruction
+`\.{(KRN} $c$ $r$\.)' means, ``If the next character is $c$, then insert
+a blank space of width $r$ between the current character character and $c$;
+otherwise go on to the next intruction.'' The value of $r$, which is in
+units of the design size, is often negative. Character code $c$ must exist
+in the font.
+
+\yskip\hang\.{STOP} (no value). This instruction ends a ligature/kern program.
+It must follow either a \.{LIG} or \.{KRN} instruction, not a \.{LABEL}
+or \.{STOP} or \.{SKIP}.
+
+\yskip\hang\.{SKIP} (value in the range |0..127|). This instruction specifies
+continuation of a ligature/kern program after the specified number of \.{LIG}
+or \.{KRN} has been skipped over. The number of subsequent \.{LIG} and \.{KRN}
+instructions must therefore exceed this specified amount.
+
+@ In addition to all these possibilities, the property name \.{COMMENT} is
+allowed in any property list. Such comments are ignored.
+
+@ So that is what \.{PL} files hold. The next question is, ``What about
+\.{TFM} files?'' A complete answer to that question appears in the
+documentation of the companion program, \.{TFtoPL}, so it will not
+be repeated here. Suffice it to say that a \.{TFM} file stores all of the
+relevant font information in a sequence of 8-bit bytes. The number of
+bytes is always a multiple of 4, so we could regard the \.{TFM} file
+as a sequence of 32-bit words; but \TeX\ uses the byte interpretation,
+and so does \.{PLtoTF}. Note that the bytes are considered to be unsigned
+numbers.
+
+@<Glob...@>=
+@!tfm_file:packed file of 0..255;
+
+@ On some systems you may have to do something special to write a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(tfm_file);
+
+@* Basic input routines.
+For the purposes of this program, a |byte| is an unsigned 16-bit quantity,
+and an |ASCII_code| is an integer between @'40 and @'177. Such ASCII codes
+correspond to one-character constants like \.{"A"} in \.{WEB} language.
+
+@<Types...@>=
+@!byte=0..65535; {unsigned sixteen-bit quantity}
+@!ASCII_code=@'40..@'177; {standard ASCII code numbers}
+
+@ One of the things \.{PLtoTF} has to do is convert characters of strings
+to ASCII form, since that is the code used for the family name and the
+coding scheme in a \.{TFM} file. An array |xord| is used to do the
+conversion from |char|; the method below should work with little or no change
+on most \PASCAL\ systems.
+@^system dependencies@>
+
+@d first_ord=0 {ordinal number of the smallest element of |char|}
+@d last_ord=127 {ordinal number of the largest element of |char|}
+
+@<Global...@>=
+@!xord:array[char] of ASCII_code; {conversion table}
+
+@ @<Local variables for init...@>=
+@!k:integer; {all-purpose initialization index}
+
+@ Characters that should not appear in \.{PL} files (except in comments)
+are mapped into @'177.
+
+@d invalid_code=@'177 {code deserving an error message}
+
+@<Set init...@>=
+for k:=first_ord to last_ord do xord[chr(k)]:=invalid_code;
+xord[' ']:=" "; xord['!']:="!"; xord['"']:=""""; xord['#']:="#";
+xord['$']:="$"; xord['%']:="%"; xord['&']:="&"; xord['''']:="'";
+xord['(']:="("; xord[')']:=")"; xord['*']:="*"; xord['+']:="+"; xord[',']:=",";
+xord['-']:="-"; xord['.']:="."; xord['/']:="/"; xord['0']:="0"; xord['1']:="1";
+xord['2']:="2"; xord['3']:="3"; xord['4']:="4"; xord['5']:="5"; xord['6']:="6";
+xord['7']:="7"; xord['8']:="8"; xord['9']:="9"; xord[':']:=":"; xord[';']:=";";
+xord['<']:="<"; xord['=']:="="; xord['>']:=">"; xord['?']:="?";
+xord['@@']:="@@"; xord['A']:="A"; xord['B']:="B"; xord['C']:="C";
+xord['D']:="D"; xord['E']:="E"; xord['F']:="F"; xord['G']:="G"; xord['H']:="H";
+xord['I']:="I"; xord['J']:="J"; xord['K']:="K"; xord['L']:="L"; xord['M']:="M";
+xord['N']:="N"; xord['O']:="O"; xord['P']:="P"; xord['Q']:="Q"; xord['R']:="R";
+xord['S']:="S"; xord['T']:="T"; xord['U']:="U"; xord['V']:="V"; xord['W']:="W";
+xord['X']:="X"; xord['Y']:="Y"; xord['Z']:="Z"; xord['[']:="["; xord['\']:="\";
+xord[']']:="]"; xord['^']:="^"; xord['_']:="_"; xord['`']:="`"; xord['a']:="a";
+xord['b']:="b"; xord['c']:="c"; xord['d']:="d"; xord['e']:="e"; xord['f']:="f";
+xord['g']:="g"; xord['h']:="h"; xord['i']:="i"; xord['j']:="j"; xord['k']:="k";
+xord['l']:="l"; xord['m']:="m"; xord['n']:="n"; xord['o']:="o"; xord['p']:="p";
+xord['q']:="q"; xord['r']:="r"; xord['s']:="s"; xord['t']:="t"; xord['u']:="u";
+xord['v']:="v"; xord['w']:="w"; xord['x']:="x"; xord['y']:="y"; xord['z']:="z";
+xord['{']:="{"; xord['|']:="|"; xord['}']:="}"; xord['~']:="~";
+
+@ In order to help catch errors of badly nested parentheses, \.{PLtoTF}
+assumes that the user will begin each line with a number of blank spaces equal
+to some constant times the number of open parentheses at the beginning of
+that line. However, the program doesn't know in advance what the constant
+is, nor does it want to print an error message on every line for a user
+who has followed no consistent pattern of indentation.
+
+Therefore the following strategy is adopted: If the user has been consistent
+with indentation for ten or more lines, an indentation error will be
+reported. The constant of indentation is reset on every line that should
+have nonzero indentation.
+
+@<Glob...@>=
+@!line:integer; {the number of the current line}
+@!good_indent:integer; {the number of lines since the last bad indentation}
+@!indent: integer; {the number of spaces per open parenthesis, zero if unknown}
+@!level: integer; {the current number of open parentheses}
+
+@ @<Set init...@>=
+line:=0; good_indent:=0; indent:=0; level:=0;
+
+@ The input need not really be broken into lines of any maximum length, and
+we could read it character by character without any buffering. But we shall
+place it into a small buffer so that offending lines can be displayed in error
+messages.
+
+@<Glob...@>=
+@!left_ln,@!right_ln:boolean; {are the left and right ends of the buffer
+ at end-of-line marks?}
+@!limit:0..buf_size; {position of the last character present in the buffer}
+@!loc:0..buf_size; {position of the last character read in the buffer}
+@!buffer:array[1..buf_size] of char;
+@!input_has_ended:boolean; {there is no more input to read}
+
+@ @<Set init...@>=
+limit:=0; loc:=0; left_ln:=true; right_ln:=true; input_has_ended:=false;
+
+@ Just before each \.{CHARACTER} property list is evaluated, the character
+code is printed in octal notation. Up to eight such codes appear on a line;
+so we have a variable to keep track of how many are currently there.
+
+@<Glob...@>=
+@!chars_on_line:0..8; {the number of characters printed on the current line}
+
+@ @<Set init...@>=
+chars_on_line:=0;
+
+@ The following routine prints an error message and an indication of
+where the error was detected. The error message should not include any
+final punctuation, since this procedure supplies its own.
+
+@d err_print(#)==begin if chars_on_line>0 then print_ln(' ');
+ print(#); show_error_context;
+ end
+
+@p procedure show_error_context; {prints the current scanner location}
+var k:0..buf_size; {an index into |buffer|}
+begin print_ln(' (line ',line:1,').');
+if not left_ln then print('...');
+for k:=1 to loc do print(buffer[k]); {print the characters already scanned}
+print_ln(' ');
+if not left_ln then print(' ');
+for k:=1 to loc do print(' '); {space out the second line}
+for k:=loc+1 to limit do print(buffer[k]); {print the characters yet unseen}
+if right_ln then print_ln(' ')@+else print_ln('...');
+chars_on_line:=0;
+end;
+
+@ Here is a procedure that does the right thing when we are done
+reading the present contents of the buffer. It keeps |buffer[buf_size]|
+empty, in order to avoid range errors on certain \PASCAL\ compilers.
+
+An infinite sequence of right parentheses is placed at the end of the
+file, so that the program is sure to get out of whatever level of nesting
+it is in.
+
+On some systems it is desirable to modify this code so that tab marks
+in the buffer are replaced by blank spaces. (Simply setting
+|xord[chr(@'11)]:=" "| would not work; for example, two-line
+error messages would not come out properly aligned.)
+@^system dependencies@>
+
+@p procedure fill_buffer;
+begin left_ln:=right_ln; limit:=0; loc:=0;
+if left_ln then begin
+ if line>0 then read_ln(pl_file);
+ incr(line);
+ end;
+if eof(pl_file) then begin
+ limit:=1; buffer[1]:=')'; right_ln:=false; input_has_ended:=true;
+ end
+else begin
+ while (limit<buf_size-1)and(not eoln(pl_file)) do begin
+ incr(limit); read(pl_file,buffer[limit]);
+ end;
+ buffer[limit+1]:=' '; right_ln:=eoln(pl_file);
+ if left_ln then @<Set |loc| to the number of leading blanks in
+ the buffer, and check the indentation@>;
+ end;
+end;
+
+@ The interesting part about |fill_buffer| is the part that learns what
+indentation conventions the user is following, if any.
+
+@d bad_indent(#)==begin if good_indent>=10 then err_print(#);
+ good_indent:=0; indent:=0;
+ end
+
+@<Set |loc|...@>=
+begin while (loc<limit)and(buffer[loc+1]=' ') do incr(loc);
+if loc<limit then begin
+ if level=0 then
+ if loc=0 then incr(good_indent)
+ else bad_indent('Warning: Indented line occurred at level zero')
+@.Warning: Indented line...@>
+ else if indent=0 then
+ if loc mod level=0 then begin
+ indent:=loc div level; good_indent:=1;
+ end
+ else good_indent:=0
+ else if indent*level=loc then incr(good_indent)
+ else bad_indent('Warning: Inconsistent indentation; ',
+@.Warning: Inconsistent indentation...@>
+ 'you are at parenthesis level ',level:1);
+ end;
+end
+
+@* Basic scanning routines.
+The global variable |cur_char| holds the ASCII code corresponding to the
+character most recently read from the input buffer, or to a character that
+has been substituted for the real one.
+
+@<Global...@>=
+@!cur_char:ASCII_code; {we have just read this}
+
+@ Here is a procedure that sets |cur_char| to an ASCII code for the
+next character of input, if that character is a letter or digit or slash
+or \.>. Otherwise
+it sets |cur_char:=" "|, and the input system will be poised to reread the
+character that was rejected, whether or not it was a space.
+Lower case letters are converted to upper case.
+
+@p procedure get_keyword_char;
+begin while (loc=limit)and(not right_ln) do fill_buffer;
+if loc=limit then cur_char:=" " {end-of-line counts as a delimiter}
+else begin
+ cur_char:=xord[buffer[loc+1]];
+ if cur_char>="a" then cur_char:=cur_char-@'40;
+ if ((cur_char>="0")and(cur_char<="9")) then incr(loc)
+ else if ((cur_char>="A")and(cur_char<="Z")) then incr(loc)
+ else if cur_char="/" then incr(loc)
+ else if cur_char=">" then incr(loc)
+ else cur_char:=" ";
+ end;
+end;
+
+@ The following procedure sets |cur_char| to the next character code,
+and converts lower case to upper case. If the character is a left or
+right parenthesis, it will not be ``digested''; the character will
+be read again and again, until the calling routine does something
+like `|incr(loc)|' to get past it. Such special treatment of parentheses
+insures that the structural information they contain won't be lost in
+the midst of other error recovery operations.
+
+@d backup==begin if (cur_char>")")or(cur_char<"(") then decr(loc);
+ end {undoes the effect of |get_next|}
+
+@p procedure get_next; {sets |cur_char| to next, balks at parentheses}
+begin while loc=limit do fill_buffer;
+incr(loc); cur_char:=xord[buffer[loc]];
+if cur_char>="a" then
+ if cur_char<="z" then cur_char:=cur_char-@'40 {uppercasify}
+ else begin
+ if cur_char=invalid_code then begin
+ err_print('Illegal character in the file');
+@.Illegal character...@>
+ cur_char:="?";
+ end;
+ end
+else if (cur_char<=")")and(cur_char>="(") then decr(loc);
+end;
+
+@ The next procedure is used to ignore the text of a comment, or to pass over
+erroneous material. As such, it has the privilege of passing parentheses.
+It stops after the first right parenthesis that drops the level below
+the level in force when the procedure was called.
+
+@p procedure skip_to_end_of_item;
+var l:integer; {initial value of |level|}
+begin l:=level;
+while level>=l do begin
+ while loc=limit do fill_buffer;
+ incr(loc);
+ if buffer[loc]=')' then decr(level)
+ else if buffer[loc]='(' then incr(level);
+ end;
+if input_has_ended then err_print('File ended unexpectedly: No closing ")"');
+@.File ended unexpectedly...@>
+cur_char:=" "; {now the right parenthesis has been read and digested}
+end;
+
+@ Sometimes we merely want to skip past characters in the input until we
+reach a left or a right parenthesis. For example, we do this whenever we
+have finished scanning a property value and we hope that a right parenthesis
+is next (except for possible blank spaces).
+
+@d skip_to_paren==repeat get_next@;@+ until (cur_char="(")or(cur_char=")")
+@d skip_error(#)==begin err_print(#); skip_to_paren;
+ end {this gets to the right parenthesis if something goes wrong}
+@d flush_error(#)==begin err_print(#); skip_to_end_of_item;
+ end {this gets past the right parenthesis if something goes wrong}
+
+@ After a property value has been scanned, we want to move just past the
+right parenthesis that should come next in the input (except for possible
+blank spaces).
+
+@p procedure finish_the_property; {do this when the value has been scanned}
+begin while cur_char=" " do get_next;
+if cur_char<>")" then err_print('Junk after property value will be ignored');
+@.Junk after property value...@>
+skip_to_end_of_item;
+end;
+
+@* Scanning property names.
+We have to figure out the meaning of names that appear in the \.{PL} file,
+by looking them up in a dictionary of known keywords. Keyword number $n$
+appears in locations |start[n]| through |start[n+1]-1| of an array called
+|dictionary|.
+
+@d max_name_index=300 {upper bound on the number of keywords}
+@d max_letters=3000 {upper bound on the total length of all keywords}
+
+@<Global...@>=
+@!start:array[1..max_name_index] of 0..max_letters;
+@!dictionary:array[0..max_letters] of ASCII_code;
+@!start_ptr:0..max_name_index; {the first available place in |start|}
+@!dict_ptr:0..max_letters; {the first available place in |dictionary|}
+
+@ @<Set init...@>=
+start_ptr:=1; start[1]:=0; dict_ptr:=0;
+
+@ When we are looking for a name, we put it into the |cur_name| array.
+When we have found it, the corresponding |start| index will go into
+the global variable |name_ptr|.
+
+@d longest_name=20 {length of \.{DEFAULTRULETHICKNESS}}
+
+@<Glob...@>=
+@!cur_name:array[1..longest_name] of ASCII_code; {a name to look up}
+@!name_length:0..longest_name; {its length}
+@!name_ptr:0..max_name_index; {its ordinal number in the dictionary}
+
+@ A conventional hash table with linear probing (cf.\ Algorithm 6.4L
+in {\sl The Art of Computer Pro\-gram\-ming\/}) is used for the dictionary
+operations. If |nhash[h]=0|, the table position is empty, otherwise |nhash[h]|
+points into the |start| array.
+
+@d hash_prime=307 {size of the hash table}
+
+@<Glob...@>=
+@!nhash:array[0..hash_prime-1] of 0..max_name_index;
+@!cur_hash:0..hash_prime-1; {current position in the hash table}
+
+@ @<Local...@>=
+@!h:0..hash_prime-1; {runs through the hash table}
+
+@ @<Set init...@>=
+for h:=0 to hash_prime-1 do nhash[h]:=0;
+
+@ Since there is no chance of the hash table overflowing, the procedure
+is very simple. After |lookup| has done its work, |cur_hash| will point
+to the place where the given name was found, or where it should be inserted.
+
+@p procedure lookup; {finds |cur_name| in the dictionary}
+var k:0..longest_name; {index into |cur_name|}
+@!j:0..max_letters; {index into |dictionary|}
+@!not_found:boolean; {clumsy thing necessary to avoid |goto| statement}
+@!cur_hash_reset:boolean;
+begin @<Compute the hash code, |cur_hash|, for |cur_name|@>;
+not_found:=true;
+cur_hash_reset:=false;
+while not_found do begin
+ if (cur_hash=0) and (cur_hash_reset) then
+ not_found:=false
+ else begin
+ if cur_hash=0 then begin
+ cur_hash:=hash_prime-1;
+ cur_hash_reset:=true
+ end
+ else decr(cur_hash);
+ if nhash[cur_hash]=0 then not_found:=false
+ else begin
+ j:=start[nhash[cur_hash]];
+ if start[nhash[cur_hash]+1]=j+name_length then begin
+ not_found:=false;
+ for k:=1 to name_length do
+ if dictionary[j+k-1]<>cur_name[k] then not_found:=true;
+ end
+ end
+ end
+ end;
+name_ptr:=nhash[cur_hash];
+end;
+
+@ @<Compute the hash...@>=
+cur_hash:=cur_name[1];
+for k:=2 to name_length do
+ cur_hash:=(cur_hash+cur_hash+cur_name[k]) mod hash_prime
+
+@ The ``meaning'' of the keyword that begins at |start[k]| in the
+dictionary is kept in |equiv[k]|. The numeric |equiv| codes are given
+symbolic meanings by the following definitions.
+
+@d comment_code=0
+@d check_sum_code=1
+@d design_size_code=2
+@d design_units_code=3
+@d coding_scheme_code=4
+@d family_code=5
+@d face_code=6
+@d seven_bit_safe_flag_code=7
+@d header_code= 8
+@d font_dimen_code=9
+@d lig_table_code=10
+@d boundary_char_code=11
+@d font_dir_code=14
+@d n_font_dir_code=15
+@d character_code=16
+@d parameter_code=30
+@d char_info_code=70
+@d width=1
+@d height=2
+@d depth=3
+@d italic=4
+@d sec_width=5
+@d sec_height=6
+@d sec_depth=7
+@d sec_italic=8
+@d accent=9
+@d prim_top_axis=10
+@d prim_top_axis_bis=11
+@d prim_bot_axis=12
+@d prim_bot_axis_bis=13
+@d prim_mid_hor=14
+@d prim_mid_vert=15
+@d prim_base_slant=16
+@d sec_top_axis=17
+@d sec_top_axis_bis=18
+@d sec_bot_axis=19
+@d sec_bot_axis_bis=20
+@d sec_mid_hor=21
+@d sec_mid_vert=22
+@d sec_base_slant=23
+@d char_wd_code=char_info_code+width
+@d char_ht_code=char_info_code+height
+@d char_dp_code=char_info_code+depth
+@d char_ic_code=char_info_code+italic
+@d sec_width_code=char_info_code+sec_width
+@d sec_height_code=char_info_code+sec_height
+@d sec_depth_code=char_info_code+sec_depth
+@d sec_italic_code=char_info_code+sec_italic
+@d accent_code=char_info_code+accent
+@d prim_top_axis_code=char_info_code+prim_top_axis
+@d prim_top_axis_bis_code=char_info_code+prim_top_axis_bis
+@d prim_bot_axis_code=char_info_code+prim_bot_axis
+@d prim_bot_axis_bis_code=char_info_code+prim_bot_axis_bis
+@d prim_mid_hor_code=char_info_code+prim_mid_hor
+@d prim_mid_vert_code=char_info_code+prim_mid_vert
+@d prim_base_slant_code=char_info_code+prim_base_slant
+@d sec_top_axis_code=char_info_code+sec_top_axis
+@d sec_top_axis_bis_code=char_info_code+sec_top_axis_bis
+@d sec_bot_axis_code=char_info_code+sec_bot_axis
+@d sec_bot_axis_bis_code=char_info_code+sec_bot_axis_bis
+@d sec_mid_hor_code=char_info_code+sec_mid_hor
+@d sec_mid_vert_code=char_info_code+sec_mid_vert
+@d sec_base_slant_code=char_info_code+sec_base_slant
+@d next_larger_code=100
+@d var_char_code=102
+@d label_code=130
+@d stop_code=131
+@d skip_code=132
+@d krn_code=133
+@d lig_code=134
+@d ofm_level_code=140
+@d char_repeat_code=150
+@d char_ivalue_code=151
+@d char_fvalue_code=152
+@d char_mvalue_code=153
+@d char_rule_code=154
+@d char_glue_code=155
+@d char_penalty_code=156
+@d font_rule_code=160
+@d rule_code=161
+@d rule_width_code=162
+@d rule_height_code=163
+@d rule_depth_code=164
+@d font_glue_code=170
+@d glue_code=171
+@d glue_type_code=172
+@d glue_stretch_order_code=173
+@d glue_shrink_order_code=174
+@d glue_width_code=175
+@d glue_stretch_code=176
+@d glue_shrink_code=177
+@d glue_char_code=178
+@d glue_rule_code=179
+@d order_unit_code=181
+@d order_fi_code=182
+@d order_fil_code=183
+@d order_fill_code=184
+@d order_filll_code=185
+@d type_normal_code=186
+@d type_aleaders_code=187
+@d type_cleaders_code=188
+@d type_xleaders_code=189
+@d font_penalty_code=190
+@d penalty_code=191
+@d penalty_val_code=192
+@d font_mvalue_code=200
+@d mvalue_code=201
+@d mvalue_val_code=202
+@d font_fvalue_code=210
+@d fvalue_code=211
+@d fvalue_val_code=212
+@d font_ivalue_code=220
+@d ivalue_code=221
+@d ivalue_val_code=222
+@d clabel_code=231
+@d cpen_code=232
+@d cglue_code=233
+@d cpenglue_code=234
+@d ckrn_code=235
+@d TL_dir_code=240
+@d LT_dir_code=241
+@d TR_dir_code=242
+@d LB_dir_code=243
+@d BL_dir_code=244
+@d RT_dir_code=245
+@d BR_dir_code=246
+@d RB_dir_code=247
+
+
+@<Glo...@>=
+@!equiv:array[0..max_name_index] of byte;
+@!cur_code:byte; {equivalent most recently found in |equiv|}
+
+@ We have to get the keywords into the hash table and into the dictionary in
+the first place (sigh). The procedure that does this has the desired
+|equiv| code as a parameter. In order to facilitate \.{WEB} macro writing
+for the initialization, the keyword being initialized is placed into the
+last positions of |cur_name|, instead of the first positions.
+
+@p procedure enter_name(v:byte); {|cur_name| goes into the dictionary}
+var k:0..longest_name;
+begin for k:=1 to name_length do
+ cur_name[k]:=cur_name[k+longest_name-name_length];
+{now the name has been shifted into the correct position}
+lookup; {this sets |cur_hash| to the proper insertion place}
+nhash[cur_hash]:=start_ptr; equiv[start_ptr]:=v;
+for k:=1 to name_length do
+ begin dictionary[dict_ptr]:=cur_name[k]; incr(dict_ptr);
+ end;
+incr(start_ptr); start[start_ptr]:=dict_ptr;
+end;
+
+@ Here are the macros to load a name of up to 20 letters into the
+dictionary. For example, the macro |load5| is used for five-letter keywords.
+
+@d tail(#)==enter_name(#)
+@d t20(#)==cur_name[20]:=#;tail
+@d t19(#)==cur_name[19]:=#;t20
+@d t18(#)==cur_name[18]:=#;t19
+@d t17(#)==cur_name[17]:=#;t18
+@d t16(#)==cur_name[16]:=#;t17
+@d t15(#)==cur_name[15]:=#;t16
+@d t14(#)==cur_name[14]:=#;t15
+@d t13(#)==cur_name[13]:=#;t14
+@d t12(#)==cur_name[12]:=#;t13
+@d t11(#)==cur_name[11]:=#;t12
+@d t10(#)==cur_name[10]:=#;t11
+@d t9(#)==cur_name[9]:=#;t10
+@d t8(#)==cur_name[8]:=#;t9
+@d t7(#)==cur_name[7]:=#;t8
+@d t6(#)==cur_name[6]:=#;t7
+@d t5(#)==cur_name[5]:=#;t6
+@d t4(#)==cur_name[4]:=#;t5
+@d t3(#)==cur_name[3]:=#;t4
+@d t2(#)==cur_name[2]:=#;t3
+@d t1(#)==cur_name[1]:=#;t2
+@d load2==name_length:=2;t19
+@d load3==name_length:=3;t18
+@d load4==name_length:=4;t17
+@d load5==name_length:=5;t16
+@d load6==name_length:=6;t15
+@d load7==name_length:=7;t14
+@d load8==name_length:=8;t13
+@d load9==name_length:=9;t12
+@d load10==name_length:=10;t11
+@d load11==name_length:=11;t10
+@d load12==name_length:=12;t9
+@d load13==name_length:=13;t8
+@d load14==name_length:=14;t7
+@d load15==name_length:=15;t6
+@d load16==name_length:=16;t5
+@d load17==name_length:=17;t4
+@d load18==name_length:=18;t3
+@d load19==name_length:=19;t2
+@d load20==name_length:=20;t1
+
+@ (Thank goodness for keyboard macros in the text editor used to create this
+\.{WEB} file.)
+
+@<Enter all of the names and their equivalents, except the parameter names@>=
+equiv[0]:=comment_code; {this is used after unknown keywords}
+load8("C")("H")("E")("C")("K")("S")("U")("M")(check_sum_code);@/
+load10("D")("E")("S")("I")("G")("N")("S")("I")("Z")("E")(design_size_code);@/
+load11("D")("E")("S")("I")("G")("N")
+ ("U")("N")("I")("T")("S")(design_units_code);@/
+load12("C")("O")("D")("I")("N")("G")
+ ("S")("C")("H")("E")("M")("E")(coding_scheme_code);@/
+load6("F")("A")("M")("I")("L")("Y")(family_code);@/
+load4("F")("A")("C")("E")(face_code);@/
+load16("S")("E")("V")("E")("N")("B")("I")("T")@/@t\hskip2em@>
+ ("S")("A")("F")("E")("F")("L")("A")("G")(seven_bit_safe_flag_code);@/
+load6("H")("E")("A")("D")("E")("R")(header_code);@/
+load9("F")("O")("N")("T")("D")("I")("M")("E")("N")(font_dimen_code);@/
+load8("L")("I")("G")("T")("A")("B")("L")("E")(lig_table_code);@/
+load12("B")("O")("U")("N")("D")("A")("R")("Y")("C")("H")("A")("R")
+ (boundary_char_code);@/
+load9("C")("H")("A")("R")("A")("C")("T")("E")("R")(character_code);@/
+load9("P")("A")("R")("A")("M")("E")("T")("E")("R")(parameter_code);@/
+load6("C")("H")("A")("R")("W")("D")(char_wd_code);@/
+load6("C")("H")("A")("R")("H")("T")(char_ht_code);@/
+load6("C")("H")("A")("R")("D")("P")(char_dp_code);@/
+load6("C")("H")("A")("R")("I")("C")(char_ic_code);@/
+load5("S")("E")("C")("W")("D")(sec_width_code);@/
+load5("S")("E")("C")("H")("T")(sec_height_code);@/
+load5("S")("E")("C")("D")("P")(sec_depth_code);@/
+load5("S")("E")("C")("I")("C")(sec_italic_code);@/
+load6("A")("C")("C")("E")("N")("T")(accent_code);@/
+load11("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")(prim_top_axis_code);@/
+load14("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(prim_top_axis_bis_code);@/
+load11("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")(prim_bot_axis_code);@/
+load14("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(prim_bot_axis_bis_code);@/
+load10("P")("R")("I")("M")("M")("I")("D")("H")("O")("R")(prim_mid_hor_code);@/
+load10("P")("R")("I")("M")("M")("I")("D")("V")("E")("R")(prim_mid_vert_code);@/
+load13("P")("R")("I")("M")("B")("A")("S")("E")("S")("L")("A")("N")("T")(prim_base_slant_code);@/
+load10("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")(sec_top_axis_code);@/
+load13("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(sec_top_axis_bis_code);@/
+load10("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")(sec_bot_axis_code);@/
+load13("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(sec_bot_axis_bis_code);@/
+load9("S")("E")("C")("M")("I")("D")("H")("O")("R")(sec_mid_hor_code);@/
+load9("S")("E")("C")("M")("I")("D")("V")("E")("R")(sec_mid_vert_code);@/
+load12("S")("E")("C")("B")("A")("S")("E")("S")("L")("A")("N")("T")(sec_base_slant_code);@/
+load10("N")("E")("X")("T")("L")("A")("R")("G")("E")("R")(next_larger_code);@/
+load7("V")("A")("R")("C")("H")("A")("R")(var_char_code);@/
+load3("T")("O")("P")(var_char_code+1);@/
+load3("M")("I")("D")(var_char_code+2);@/
+load3("B")("O")("T")(var_char_code+3);@/
+load3("R")("E")("P")(var_char_code+4);@/
+load3("E")("X")("T")(var_char_code+4); {compatibility with older \.{PL} format}
+load7("C")("O")("M")("M")("E")("N")("T")(comment_code);@/
+load5("L")("A")("B")("E")("L")(label_code);@/
+load4("S")("T")("O")("P")(stop_code);@/
+load4("S")("K")("I")("P")(skip_code);@/
+load3("K")("R")("N")(krn_code);@/
+load3("L")("I")("G")(lig_code);@/
+load4("/")("L")("I")("G")(lig_code+2);@/
+load5("/")("L")("I")("G")(">")(lig_code+6);@/
+load4("L")("I")("G")("/")(lig_code+1);@/
+load5("L")("I")("G")("/")(">")(lig_code+5);@/
+load5("/")("L")("I")("G")("/")(lig_code+3);@/
+load6("/")("L")("I")("G")("/")(">")(lig_code+7);@/
+load7("/")("L")("I")("G")("/")(">")(">")(lig_code+11);@/
+load6("C")("L")("A")("B")("E")("L")(clabel_code);@/
+load4("C")("P")("E")("N")(cpen_code);@/
+load5("C")("G")("L")("U")("E")(cglue_code);@/
+load8("C")("P")("E")("N")("G")("L")("U")("E")(cpenglue_code);@/
+load4("C")("K")("R")("N")(ckrn_code);@/
+load8("O")("F")("M")("L")("E")("V")("E")("L")(ofm_level_code);@/
+load7("F")("O")("N")("T")("D")("I")("R")(font_dir_code);@/
+load8("N")("F")("O")("N")("T")("D")("I")("R")(n_font_dir_code);@/
+load10("C")("H")("A")("R")("R")("E")("P")("E")("A")("T")(char_repeat_code);@/
+load10("C")("H")("A")("R")("I")("V")("A")("L")("U")("E")(char_ivalue_code);@/
+load10("C")("H")("A")("R")("F")("V")("A")("L")("U")("E")(char_fvalue_code);@/
+load10("C")("H")("A")("R")("M")("V")("A")("L")("U")("E")(char_mvalue_code);@/
+load8("C")("H")("A")("R")("R")("U")("L")("E")(char_rule_code);@/
+load8("C")("H")("A")("R")("G")("L")("U")("E")(char_glue_code);@/
+load11("C")("H")("A")("R")("P")("E")("N")("A")("L")("T")("Y")(char_penalty_code);@/
+load8("F")("O")("N")("T")("R")("U")("L")("E")(font_rule_code);@/
+load4("R")("U")("L")("E")(rule_code);@/
+load6("R")("U")("L")("E")("W")("D")(rule_width_code);@/
+load6("R")("U")("L")("E")("H")("T")(rule_height_code);@/
+load6("R")("U")("L")("E")("D")("P")(rule_depth_code);@/
+load8("F")("O")("N")("T")("G")("L")("U")("E")(font_glue_code);@/
+load4("G")("L")("U")("E")(glue_code);@/
+load8("G")("L")("U")("E")("T")("Y")("P")("E")(glue_type_code);@/
+load16("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")("O")("R")("D")("E")("R")(glue_stretch_order_code);@/
+load15("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")("O")("R")("D")("E")("R")(glue_shrink_order_code);@/
+load8("G")("L")("U")("E")("R")("U")("L")("E")(glue_rule_code);@/
+load8("G")("L")("U")("E")("C")("H")("A")("R")(glue_char_code);@/
+load6("G")("L")("U")("E")("W")("D")(glue_width_code);@/
+load11("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")(glue_stretch_code);@/
+load10("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")(glue_shrink_code);@/
+load4("U")("N")("I")("T")(order_unit_code);@/
+load2("F")("I")(order_fi_code);@/
+load3("F")("I")("L")(order_fil_code);@/
+load4("F")("I")("L")("L")(order_fill_code);@/
+load5("F")("I")("L")("L")("L")(order_filll_code);@/
+load6("N")("O")("R")("M")("A")("L")(type_normal_code);@/
+load8("A")("L")("E")("A")("D")("E")("R")("S")(type_aleaders_code);@/
+load8("C")("L")("E")("A")("D")("E")("R")("S")(type_cleaders_code);@/
+load8("X")("L")("E")("A")("D")("E")("R")("S")(type_xleaders_code);@/
+load11("F")("O")("N")("T")("P")("E")("N")("A")("L")("T")("Y")(font_penalty_code);@/
+load7("P")("E")("N")("A")("L")("T")("Y")(penalty_code);@/
+load10("P")("E")("N")("A")("L")("T")("Y")("V")("A")("L")(penalty_val_code);@/
+load10("F")("O")("N")("T")("M")("V")("A")("L")("U")("E")(font_mvalue_code);@/
+load6("M")("V")("A")("L")("U")("E")(mvalue_code);@/
+load9("M")("V")("A")("L")("U")("E")("V")("A")("L")(mvalue_val_code);@/
+load10("F")("O")("N")("T")("F")("V")("A")("L")("U")("E")(font_fvalue_code);@/
+load6("F")("V")("A")("L")("U")("E")(fvalue_code);@/
+load9("F")("V")("A")("L")("U")("E")("V")("A")("L")(fvalue_val_code);@/
+load10("F")("O")("N")("T")("I")("V")("A")("L")("U")("E")(font_ivalue_code);@/
+load6("I")("V")("A")("L")("U")("E")(ivalue_code);@/
+load9("I")("V")("A")("L")("U")("E")("V")("A")("L")(ivalue_val_code);@/
+load2("T")("L")(TL_dir_code);
+load2("L")("T")(LT_dir_code);
+load2("T")("R")(TR_dir_code);
+load2("L")("B")(LB_dir_code);
+load2("B")("L")(BL_dir_code);
+load2("R")("T")(RT_dir_code);
+load2("B")("R")(BR_dir_code);
+load2("R")("B")(RB_dir_code);
+
+@ @<Enter the parameter names@>=
+load5("S")("L")("A")("N")("T")(parameter_code+1);@/
+load5("S")("P")("A")("C")("E")(parameter_code+2);@/
+load7("S")("T")("R")("E")("T")("C")("H")(parameter_code+3);@/
+load6("S")("H")("R")("I")("N")("K")(parameter_code+4);@/
+load7("X")("H")("E")("I")("G")("H")("T")(parameter_code+5);@/
+load4("Q")("U")("A")("D")(parameter_code+6);@/
+load10("E")("X")("T")("R")("A")("S")("P")("A")("C")("E")(parameter_code+7);@/
+load4("N")("U")("M")("1")(parameter_code+8);@/
+load4("N")("U")("M")("2")(parameter_code+9);@/
+load4("N")("U")("M")("3")(parameter_code+10);@/
+load6("D")("E")("N")("O")("M")("1")(parameter_code+11);@/
+load6("D")("E")("N")("O")("M")("2")(parameter_code+12);@/
+load4("S")("U")("P")("1")(parameter_code+13);@/
+load4("S")("U")("P")("2")(parameter_code+14);@/
+load4("S")("U")("P")("3")(parameter_code+15);@/
+load4("S")("U")("B")("1")(parameter_code+16);@/
+load4("S")("U")("B")("2")(parameter_code+17);@/
+load7("S")("U")("P")("D")("R")("O")("P")(parameter_code+18);@/
+load7("S")("U")("B")("D")("R")("O")("P")(parameter_code+19);@/
+load6("D")("E")("L")("I")("M")("1")(parameter_code+20);@/
+load6("D")("E")("L")("I")("M")("2")(parameter_code+21);@/
+load10("A")("X")("I")("S")("H")("E")("I")("G")("H")("T")(parameter_code+22);@/
+load20("D")("E")("F")("A")("U")("L")("T")("R")("U")("L")("E")@/@t\hskip2em@>
+ ("T")("H")("I")("C")("K")("N")("E")("S")("S")(parameter_code+8);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("1")(parameter_code+9);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("2")(parameter_code+10);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("3")(parameter_code+11);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("4")(parameter_code+12);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("5")(parameter_code+13);@/
+
+@ When a left parenthesis has been scanned, the following routine
+is used to interpret the keyword that follows, and to store the
+equivalent value in |cur_code|.
+
+@p procedure get_name;
+begin incr(loc); incr(level); {pass the left parenthesis}
+cur_char:=" ";
+while cur_char=" " do get_next;
+if (cur_char>")")or(cur_char<"(") then decr(loc); {back up one character}
+name_length:=0; get_keyword_char; {prepare to scan the name}
+while cur_char<>" " do begin
+ if name_length=longest_name then cur_name[1]:="X" {force error}
+ else incr(name_length);
+ cur_name[name_length]:=cur_char;
+ get_keyword_char;
+ end;
+lookup;
+if name_ptr=0 then err_print('Sorry, I don''t know that property name');
+@.Sorry, I don't know...@>
+cur_code:=equiv[name_ptr];
+end;
+
+@* Scanning numeric data.
+The next thing we need is a trio of subroutines to read the one-byte,
+four-byte, and real numbers that may appear as property values.
+These subroutines are careful to stick to numbers between $-2^{31}$
+and $2^{31}-1$, inclusive, so that a computer with two's complement
+32-bit arithmetic will not be interrupted by overflow.
+
+@ The first number scanner, which returns a one-byte value, surely has
+no problems of arithmetic overflow.
+
+@p function get_byte:byte; {scans a one-byte property value}
+var acc:integer; {an accumulator}
+@!t:ASCII_code; {the type of value to be scanned}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+t:=cur_char; acc:=0;
+repeat get_next;
+until cur_char<>" "; {skip the blanks after the type code}
+if t="C" then @<Scan an ASCII character code@>
+else if t="D" then @<Scan a small decimal number@>
+else if t="O" then @<Scan a small octal number@>
+else if t="H" then @<Scan a small hexadecimal number@>
+else if t="F" then @<Scan a face code@>
+else skip_error('You need "C" or "D" or "O" or "H" or "F" here');
+@.You need "C" or "D" ...here@>
+cur_char:=" "; get_byte:=acc;
+end;
+
+@ The |get_next| routine converts lower case to upper case, but it leaves
+the character in the buffer, so we can unconvert it.
+
+@<Scan an ASCII...@>=
+if (cur_char>=@'41)and(cur_char<=@'176)and
+ ((cur_char<"(")or(cur_char>")")) then
+ acc:=xord[buffer[loc]]
+else skip_error('"C" value must be standard ASCII and not a paren')
+@:C value}\.{"C" value must be...@>
+
+@ @<Scan a small dec...@>=
+begin while (cur_char>="0")and(cur_char<="9") do begin
+ acc:=acc*10+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed 65535');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a small oct...@>=
+begin while (cur_char>="0")and(cur_char<="7") do
+ begin acc:=acc*8+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed ''177777');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a small hex...@>=
+begin while ((cur_char>="0")and(cur_char<="9"))or
+ ((cur_char>="A")and(cur_char<="F")) do begin
+ if cur_char>="A" then cur_char:=cur_char+"0"+10-"A";
+ acc:=acc*16+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed "FFFF');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a face...@>=
+begin if cur_char="B" then acc:=2
+else if cur_char="L" then acc:=4
+else if cur_char<>"M" then acc:=18;
+get_next;
+if cur_char="I" then incr(acc)
+else if cur_char<>"R" then acc:=18;
+get_next;
+if cur_char="C" then acc:=acc+6
+else if cur_char="E" then acc:=acc+12
+else if cur_char<>"R" then acc:=18;
+if acc>=18 then begin
+ skip_error('Illegal face code, I changed it to MRR');
+@.Illegal face code...@>
+ acc:=0;
+ end;
+end
+
+@ The routine that scans a four-byte value puts its output into |cur_bytes|,
+which is a record containing (yes, you guessed it) four bytes.
+
+@<Types...@>=
+@!four_bytes=record @!b0:byte;@+@!b1:byte;@+@!b2:byte;@+@!b3:byte;@+end;
+
+@ @d c0==cur_bytes.b0
+@d c1==cur_bytes.b1
+@d c2==cur_bytes.b2
+@d c3==cur_bytes.b3
+
+@<Glob...@>=
+@!cur_bytes:four_bytes; {a four-byte accumulator}
+@!zero_bytes:four_bytes; {four bytes all zero}
+
+@ @<Set init...@>=
+zero_bytes.b0:=0; zero_bytes.b1:=0; zero_bytes.b2:=0; zero_bytes.b3:=0;
+
+@ Since the |get_four_bytes| routine is used very infrequently, no attempt
+has been made to make it fast; we only want it to work.
+This is no longer the case, but we hope that it is not too slow.
+
+@p procedure get_four_bytes; {scans an unsigned constant and sets |four_bytes|}
+var c:integer; {leading byte}
+@!r:integer; {radix}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+r:=0; cur_bytes:=zero_bytes; {start with the accumulator zero}
+if cur_char="H" then r:=16
+else if cur_char="O" then r:=8
+else if cur_char="D" then r:=10
+else skip_error('Decimal ("D"), octal ("O") or hex ("H") value is needed here');
+@.Decimal ("D"), octal ("O") or hex ("H")...@>
+if r>0 then begin
+ repeat get_next;
+ until cur_char<>" "; {skip the blanks after the type code}
+ while ((cur_char>="0")and(cur_char<="9"))or@|
+ ((cur_char>="A")and(cur_char<="F")) do
+ @<Multiply by |r|, add |cur_char-"0"|, and |get_next|@>;
+ end;
+end;
+
+function get_integer:integer; {scans an integer property value}
+begin get_four_bytes;
+get_integer:=(c0*@"1000000)+(c1*@"10000)+(c2*@"100)+c3;
+end;
+
+@ @<Multiply by |r|...@>=
+begin if cur_char>="A" then cur_char:=cur_char+"0"+10-"A";
+if cur_char>="0"+r then skip_error('Illegal digit')
+@.Illegal digit@>
+else begin
+ c:=c3*r+cur_char-"0"; c3:=c mod 256;@/
+ c:=c2*r+c div 256; c2:=c mod 256;@/
+ c:=c1*r+c div 256; c1:=c mod 256;@/
+ c:=c0*r+c div 256;
+ if c<256 then c0:=c
+ else begin
+ cur_bytes:=zero_bytes;
+ if r=8 then
+ skip_error('Sorry, the maximum octal value is O 37777777777')
+@.Sorry, the maximum...@>
+ else if r=10 then
+ skip_error('Sorry, the maximum decimal value is D 4294967295')
+ else skip_error('Sorry, the maximum hex value is H FFFFFFFF');
+ end;
+ get_next;
+ end;
+end
+
+@ The remaining scanning routine is the most interesting. It scans a real
+constant and returns the nearest |fix_word| approximation to that constant.
+A |fix_word| is a 32-bit integer that represents a real value that
+has been multiplied by $2^{20}$. Since \.{PLtoTF} restricts the magnitude
+of reals to 2048, the |fix_word| will have a magnitude less than $2^{31}$.
+
+@d unity==@'4000000 {$2^{20}$, the |fix_word| 1.0}
+
+@<Types...@>=
+@!fix_word=integer; {a scaled real value with 20 bits of fraction}
+@!unsigned_integer=integer;
+
+@ When a real value is desired, we might as well treat `\.D' and `\.R'
+formats as if they were identical.
+
+@p function get_fix:fix_word; {scans a real property value}
+var negative:boolean; {was there a minus sign?}
+@!acc:integer; {an accumulator}
+@!int_part:integer; {the integer part}
+@!j:0..7; {the number of decimal places stored}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+negative:=false; acc:=0; {start with the accumulators zero}
+if (cur_char<>"R")and(cur_char<>"D") then
+ skip_error('An "R" or "D" value is needed here')
+@.An "R" or "D" ... needed here@>
+else begin
+ @<Scan the blanks and/or signs after the type code@>;
+ while (cur_char>="0") and (cur_char<="9") do
+ @<Multiply by 10, add |cur_char-"0"|, and |get_next|@>;
+ int_part:=acc; acc:=0;
+ if cur_char="." then @<Scan the fraction part and put it in |acc|@>;
+ if (acc>=unity)and(int_part=2047) then
+ skip_error('Real constants must be less than 2048')
+@.Real constants must be...@>
+ else acc:=int_part*unity+acc;
+ end;
+if negative then get_fix:=-acc@+else get_fix:=acc;
+end;
+
+@ @<Scan the blanks...@>=
+repeat get_next;
+if cur_char="-" then begin
+ cur_char:=" "; negative:=true;
+ end
+else if cur_char="+" then cur_char:=" ";
+until cur_char<>" "
+
+@ @<Multiply by 10...@>=
+begin acc:=acc*10+cur_char-"0";
+if acc>=2048 then begin
+ skip_error('Real constants must be less than 2048');
+@.Real constants must be...@>
+ acc:=0; cur_char:=" ";
+ end
+else get_next;
+end
+
+@ To scan the fraction $.d_1d_2\ldots\,$, we keep track of up to seven
+of the digits $d_j$. A correct result is obtained if we first compute
+$f^\prime=\lfloor 2^{21}(d_1\ldots d_j)/10^j\rfloor$, after which
+$f=\lfloor(f^\prime+1)/2\rfloor$. It is possible to have $f=1.0$.
+
+@<Glob...@>=
+@!fraction_digits:array[1..7] of integer; {$2^{21}$ times $d_j$}
+
+@ @<Scan the frac...@>=
+begin j:=0; get_next;
+while (cur_char>="0")and(cur_char<="9") do begin
+ if j<7 then begin
+ incr(j); fraction_digits[j]:=@'10000000*(cur_char-"0");
+ end;
+ get_next;
+ end;
+acc:=0;
+while j>0 do begin
+ acc:=fraction_digits[j]+(acc div 10); decr(j);
+ end;
+acc:=(acc+10) div 20;
+end
+
+@* Storing the property values.
+When property values have been found, they are squirreled away in a bunch
+of arrays. The header information is unpacked into bytes in an array
+called |header_bytes|. The ligature/kerning program is stored in an array
+of type |four_bytes|.
+Another |four_bytes| array holds the specifications of extensible characters.
+The kerns and parameters are stored in separate arrays of |fix_word| values.
+
+Instead of storing the design size in the header array, we will keep it
+in a |fix_word| variable until the last minute. The number of units in the
+design size is also kept in a |fix_word|.
+
+@<Glob...@>=
+@!header_bytes:array[header_index] of byte; {the header block}
+@!header_ptr:header_index; {the number of header bytes in use}
+@!design_size:fix_word; {the design size}
+@!design_units:fix_word; {reciprocal of the scaling factor}
+@!seven_bit_safe_flag:boolean; {does the file claim to be seven-bit-safe?}
+@!lig_kern:array[0..max_lig_steps] of four_bytes; {the ligature program}
+@!nl:unsigned_integer; {the number of ligature/kern instructions so far}
+@!min_nl:unsigned_integer; {the final value of |nl| must be at least this}
+@!kern:array[0..max_kerns] of fix_word; {the distinct kerning amounts}
+@!nk:0..max_kerns; {the number of entries of |kern|}
+@!exten:array[char_type] of four_bytes; {extensible character specs}
+@!ne:xchar_type; {the number of extensible characters}
+@!param:array[1..max_param_words] of fix_word; {\.{FONTDIMEN} parameters}
+@!np:0..max_param_words; {the largest parameter set nonzero}
+@!check_sum_specified:boolean; {did the user name the check sum?}
+@!bchar:xchar_type; {the right boundary character, or 256 if unspecified}
+@!font_dir:integer; {font direction}
+
+@ @<Types...@>=
+@!char_type=0..max_char;
+@!xchar_type=0..xmax_char;
+@!xxchar_type=0..xxmax_char;
+@!xxxchar_type=0..xxxmax_char;
+@!header_index=0..max_header_bytes;
+@!indx=xxchar_type;
+
+@ @<Local...@>=
+@!d:header_index; {an index into |header_bytes|}
+
+@ We start by setting up the default values.
+
+@d check_sum_loc=0
+@d design_size_loc=4
+@d coding_scheme_loc=8
+@d family_loc=coding_scheme_loc+40
+@d seven_flag_loc=family_loc+20
+@d face_loc=seven_flag_loc+3
+
+@<Set init...@>=
+for d:=0 to 18*4-1 do header_bytes[d]:=0;
+header_bytes[8]:=11; header_bytes[9]:="U";
+header_bytes[10]:="N";
+header_bytes[11]:="S";
+header_bytes[12]:="P";
+header_bytes[13]:="E";
+header_bytes[14]:="C";
+header_bytes[15]:="I";
+header_bytes[16]:="F";
+header_bytes[17]:="I";
+header_bytes[18]:="E";
+header_bytes[19]:="D";
+@.UNSPECIFIED@>
+for d:=family_loc to family_loc+11 do header_bytes[d]:=header_bytes[d-40];
+design_size:=10*unity; design_units:=unity; seven_bit_safe_flag:=false;@/
+header_ptr:=18*4; nl:=0; min_nl:=0; nk:=0; ne:=0; np:=0;@/
+check_sum_specified:=false; bchar:=xmax_char;
+font_dir:=0;
+
+@ Most of the dimensions, however, go into the |memory| array. There are
+at most |max_char+2| widths, |max_char+2| heights, |max_char+2| depths,
+and |max_char+2| italic corrections, since the value 0 is required but
+it need not be used. So |memory| has room for |4*max_char+8| entries,
+each of which is a |fix_word|. An auxiliary table called |link| is
+used to link these words together in linear lists, so that sorting and
+other operations can be done conveniently.
+
+We also add four ``list head'' words to the |memory| and |link| arrays;
+these are in locations |width| through |italic|, i.e., 1 through 4.
+For example, |link[height]| points to the smallest element in
+the sorted list of distinct heights that have appeared so far, and
+|memory[height]| is the number of distinct heights.
+
+@<Types...@>=
+@!pointer=0..mem_size; {an index into memory}
+
+@ The arrays |char_wd|, |char_ht|, |char_dp|, and |char_ic| contain
+pointers to the |memory| array entries where the corresponding dimensions
+appear. Two other arrays, |char_tag| and |char_remainder|, hold
+the other information that \.{TFM} files pack into a |char_info_word|.
+
+@d no_tag=0 {vanilla character}
+@d lig_tag=1 {character has a ligature/kerning program}
+@d list_tag=2 {character has a successor in a charlist}
+@d ext_tag=3 {character is extensible}
+@d bchar_label==char_remainder[xmax_char]
+ {beginning of ligature program for left boundary}
+
+@<Glob...@>=
+@!memory:array[pointer] of fix_word; {character dimensions and kerns}
+@!mem_ptr:pointer; {largest |memory| word in use}
+@!link:array[pointer] of pointer; {to make lists of |memory| items}
+@!char_wd:array[char_type] of pointer; {pointers to the widths}
+@!char_ht:array[char_type] of pointer; {pointers to the heights}
+@!char_dp:array[char_type] of pointer; {pointers to the depths}
+@!char_ic:array[char_type] of pointer; {pointers to italic corrections}
+@!char_tag:array[char_type] of no_tag..ext_tag; {character tags}
+@!char_remainder:array[xchar_type] of xchar_type;
+ {pointers to ligature labels,
+ next larger characters, or extensible characters}
+@!top_width,@!top_height,@!top_depth,@!top_italic:integer;
+
+@ @<Local...@>=
+@!c:integer; {runs through all character codes}
+
+@ @<Set init...@>=
+bchar_label:=xmax_label;
+for c:=0 to max_char do begin
+ char_wd[c]:=0; char_ht[c]:=0; char_dp[c]:=0; char_ic[c]:=0;@/
+ char_tag[c]:=no_tag; char_remainder[c]:=0;
+ end;
+memory[0]:=@'17777777777; {an ``infinite'' element at the end of the lists}
+memory[width]:=0; link[width]:=0; {width list is empty}
+memory[height]:=0; link[height]:=0; {height list is empty}
+memory[depth]:=0; link[depth]:=0; {depth list is empty}
+memory[italic]:=0; link[italic]:=0; {italic list is empty}
+mem_ptr:=italic;
+
+@ As an example of these data structures, let us consider the simple
+routine that inserts a potentially new element into one of the dimension
+lists. The first parameter indicates the list head (i.e., |h=width| for
+the width list, etc.); the second parameter is the value that is to be
+inserted into the list if it is not already present. The procedure
+returns the value of the location where the dimension appears in |memory|.
+The fact that |memory[0]| is larger than any legal dimension makes the
+algorithm particularly short.
+
+We do have to handle two somewhat subtle situations. A width of zero must be
+put into the list, so that a zero-width character in the font will not appear
+to be nonexistent (i.e., so that its |char_wd| index will not be zero), but
+this does not need to be done for heights, depths, or italic corrections.
+Furthermore, it is necessary to test for memory overflow even though we
+have provided room for the maximum number of different dimensions in any
+legal font, since the \.{PL} file might foolishly give any number of
+different sizes to the same character.
+
+@p function sort_in(@!h:pointer;@!d:fix_word):pointer; {inserts into list}
+var p:pointer; {the current node of interest}
+begin if (d=0)and(h<>width) then sort_in:=0
+else begin
+ p:=h;
+ while d>=memory[link[p]] do p:=link[p];
+ if (d=memory[p])and(p<>h) then sort_in:=p
+ else if mem_ptr=mem_size then
+ begin err_print('Memory overflow: too many widths, etc');
+@.Memory overflow...@>
+ print_ln('Congratulations! It''s hard to make this error.');
+ sort_in:=p;
+ end
+ else begin
+ incr(mem_ptr); memory[mem_ptr]:=d;
+ link[mem_ptr]:=link[p]; link[p]:=mem_ptr; incr(memory[h]);
+ sort_in:=mem_ptr;
+ end;
+ end;
+end;
+
+@ When these lists of dimensions are eventually written to the \.{OFM}
+file, we may have to do some rounding of values, because the \.{OFM} file
+allows at most 65536 widths, 256 heights, 256 depths, and 256 italic
+corrections. The following procedure takes a given list head |h| and a
+given dimension |d|, and returns the minimum $m$ such that the elements
+of the list can be covered by $m$ intervals of width $d$. It also sets
+|next_d| to the smallest value $d^\prime>d$ such that the covering found
+by this procedure would be different. In particular, if $d=0$ it computes
+the number of elements of the list, and sets |next_d| to the smallest
+distance between two list elements. (The covering by intervals of width
+|next_d| is not guaranteed to have fewer than $m$ elements, but in
+practice this seems to happen most of the time.)
+
+@<Glob...@>=
+@!next_d:fix_word; {the next larger interval that is worth trying}
+
+@ Once again we can make good use of the fact that |memory[0]| is ``infinite.''
+
+@p function min_cover(@!h:pointer;@!d:fix_word):integer;
+var p:pointer; {the current node of interest}
+@!l:fix_word; {the least element covered by the current interval}
+@!m:integer; {the current size of the cover being generated}
+begin m:=0; p:=link[h]; next_d:=memory[0];
+while p<>0 do begin
+ incr(m); l:=memory[p];
+ while memory[link[p]]<=l+d do p:=link[p];
+ p:=link[p];
+ if memory[p]-l<next_d then next_d:=memory[p]-l;
+ end;
+min_cover:=m;
+end;
+
+@ The following procedure uses |min_cover| to determine the smallest $d$
+such that a given list can be covered with at most a given number of
+intervals.
+
+@p function shorten(@!h:pointer;m:integer):fix_word; {finds best way to round}
+var d:fix_word; {the current trial interval length}
+@!k:integer; {the size of a minimum cover}
+begin if memory[h]>m then begin
+ excess:=memory[h]-m;
+ k:=min_cover(h,0); d:=next_d; {now the answer is at least |d|}
+ repeat d:=d+d; k:=min_cover(h,d);
+ until k<=m; {first we ascend rapidly until finding the range}
+ d:=d div 2; k:=min_cover(h,d); {now we run through the feasible steps}
+ while k>m do begin
+ d:=next_d; k:=min_cover(h,d);
+ end;
+ shorten:=d;
+ end
+else shorten:=0;
+end;
+
+@ When we are nearly ready to output the \.{TFM} file, we will set
+|index[p]:=k| if the dimension in |memory[p]| is being rounded to the
+|k|th element of its list.
+
+@<Glob...@>=
+@!index:array[pointer] of byte;
+@!excess:byte; {number of words to remove, if list is being shortened}
+
+@ Here is the procedure that sets the |index| values. It also shortens
+the list so that there is only one element per covering interval;
+the remaining elements are the midpoints of their clusters.
+
+@p procedure set_indices(@!h:pointer;@!d:fix_word);
+ {reduces and indexes a list}
+var p:pointer; {the current node of interest}
+@!q:pointer; {trails one step behind |p|}
+@!m:byte; {index number of nodes in the current interval}
+@!l:fix_word; {least value in the current interval}
+begin q:=h; p:=link[q]; m:=0;
+while p<>0 do begin
+ incr(m); l:=memory[p]; index[p]:=m;
+ while memory[link[p]]<=l+d do begin
+ p:=link[p]; index[p]:=m; decr(excess);
+ if excess=0 then d:=0;
+ end;
+ link[q]:=p; memory[p]:=l+(memory[p]-l) div 2; q:=p; p:=link[p];
+ end;
+memory[h]:=m;
+end;
+
+@* The input phase.
+We're ready now to read and parse the \.{PL} file, storing property
+values as we go.
+
+@<Glob...@>=
+@!c:integer; {the current character or byte being processed}
+@!cprime:char_type; {Processing for several characters together}
+@!crange:char_type; {ditto}
+
+@ @<Read all the input@>=
+cur_char:=" ";
+repeat while cur_char=" " do get_next;
+if cur_char="(" then @<Read a font property value@>
+else if (cur_char=")")and not input_has_ended then begin
+ err_print('Extra right parenthesis');
+ incr(loc); cur_char:=" ";
+ end
+@.Extra right parenthesis@>
+else if not input_has_ended then junk_error;
+until input_has_ended
+
+@ The |junk_error| routine just referred to is called when something
+appears in the forbidden area between properties of a property list.
+
+@p procedure junk_error; {gets past no man's land}
+begin err_print('There''s junk here that is not in parentheses');
+@.There's junk here...@>
+skip_to_paren;
+end;
+
+@ For each font property, we are supposed to read the data from the
+left parenthesis that is the current value of |cur_char| to the right
+parenthesis that matches it in the input. The main complication is
+to recover with reasonable grace from various error conditions that
+might arise.
+
+@<Read a font property value@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<110) and (cur_code>character_code) then
+ flush_error('This property name doesn''t belong on the outer level')
+else if (cur_code>=110) and ((cur_code mod 10)<>0) then
+ flush_error('This property name doesn''t belong on the outer level')
+@.This property name doesn't belong...@>
+else begin @<Read the font property value specified by |cur_code|@>;
+ finish_the_property;
+ end;
+end
+
+@ @<Read the font property value spec...@>=
+case cur_code of
+ check_sum_code: begin
+ check_sum_specified:=true;
+ read_four_bytes(check_sum_loc);
+ end;
+ design_size_code: @<Read the design size@>;
+ design_units_code: @<Read the design units@>;
+ coding_scheme_code: read_BCPL(coding_scheme_loc,40);
+ family_code: read_BCPL(family_loc,20);
+ face_code: begin
+ c:=get_byte; if c>255 then
+ begin err_print('FACE clipped to 255'); c:=255 end;
+ header_bytes[face_loc]:=c
+ end;
+ seven_bit_safe_flag_code: @<Read the seven-bit-safe flag@>;
+ header_code: @<Read an indexed header word@>;
+ font_dimen_code: @<Read font parameter list@>;
+ lig_table_code: read_lig_kern;
+ boundary_char_code: bchar:=get_byte;
+ character_code: read_char_info;
+ ofm_level_code: @<Read OFM level code@>;
+ font_dir_code: @<Read font direction code@>;
+ n_font_dir_code: @<Read natural font direction code@>;
+ char_repeat_code: read_repeated_character_info;
+ font_rule_code: read_font_rule_list;
+ font_glue_code: read_font_glue_list;
+ font_penalty_code: read_font_penalty_list;
+ font_mvalue_code: read_font_mvalue_list;
+ font_fvalue_code: read_font_fvalue_list;
+ font_ivalue_code: read_font_ivalue_list;
+ end
+
+@ The |case| statement just given makes use of two subroutines that we
+haven't defined yet. The first of these puts a 32-bit octal quantity
+into four specified bytes of the header block.
+
+@p procedure read_four_bytes(l:header_index);
+begin get_four_bytes;
+header_bytes[l]:=c0;
+header_bytes[l+1]:=c1;
+header_bytes[l+2]:=c2;
+header_bytes[l+3]:=c3;
+end;
+
+@ The second little procedure is used to scan a string and to store it in
+the ``{\mc BCPL} format'' required by \.{TFM} files. The string is supposed
+to contain at most |n| bytes, including the first byte (which holds the
+length of the rest of the string).
+
+@p procedure read_BCPL(l:header_index;n:byte);
+var k:header_index;
+begin k:=l;
+while cur_char=" " do get_next;
+while (cur_char<>"(")and(cur_char<>")") do begin
+ if k<l+n then incr(k);
+ if k<l+n then header_bytes[k]:=cur_char;
+ get_next;
+ end;
+if k=l+n then begin
+ err_print('String is too long; its first ',n-1:1,
+@.String is too long...@>
+ ' characters will be kept'); decr(k);
+ end;
+header_bytes[l]:=k-l;
+while k<l+n-1 do begin {tidy up the remaining bytes by setting them to nulls}
+ incr(k); header_bytes[k]:=0;
+ end;
+end;
+
+@ @<Read the design size@>=
+begin next_d:=get_fix;
+if next_d<unity then
+ err_print('The design size must be at least 1')
+@.The design size must...@>
+else design_size:=next_d;
+end
+
+@ @<Read the design units@>=
+begin next_d:=get_fix;
+if next_d<=0 then
+ err_print('The number of units per design size must be positive')
+@.The number of units...@>
+else design_units:=next_d;
+end
+
+@ @<Read the seven-bit-safe...@>=
+begin while cur_char=" " do get_next;
+if cur_char="T" then seven_bit_safe_flag:=true
+else if cur_char="F" then seven_bit_safe_flag:=false
+else err_print('The flag value should be "TRUE" or "FALSE"');
+@.The flag value should be...@>
+skip_to_paren;
+end
+
+@ @<Read an indexed header word@>=
+begin c:=get_byte;
+if c<18 then skip_error('HEADER indices should be 18 or more')
+@.HEADER indices...@>
+else if 4*c+4>max_header_bytes then
+ skip_error('This HEADER index is too big for my present table size')
+@.This HEADER index is too big...@>
+else begin
+ while header_ptr<4*c+4 do begin
+ header_bytes[header_ptr]:=0; incr(header_ptr);
+ end;
+ read_four_bytes(4*c);
+ end;
+end
+
+@ The remaining kinds of font property values that need to be read are
+those that involve property lists on higher levels. Each of these has a
+loop similar to the one that was used at level zero. Then we put the
+right parenthesis back so that `|finish_the_property|' will be happy;
+there is probably a more elegant way to do this.
+
+@d finish_inner_property_list==begin decr(loc); incr(level); cur_char:=")";
+ end
+
+@<Read font parameter list@>=
+begin while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a parameter value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a parameter value@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<parameter_code)or(cur_code>=char_wd_code) then
+ flush_error('This property name doesn''t belong in a FONTDIMEN list')
+@.This property name doesn't belong...@>
+else begin
+ if cur_code=parameter_code then c:=get_integer
+ else c:=cur_code-parameter_code;
+ if c=0 then flush_error('PARAMETER index must not be zero')
+@.PARAMETER index must not...@>
+ else if c>max_param_words then
+ flush_error('This PARAMETER index is too big for my present table size')
+@.This PARAMETER index is too big...@>
+ else begin
+ while np<c do begin
+ incr(np); param[np]:=0;
+ end;
+ param[c]:=get_fix;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Read ligature/kern list@>=
+begin lk_step_ended:=false;
+while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then read_lig_kern_command
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a ligature/kern command@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code>=label_code) and (cur_code<=(lig_code+11)) then begin
+ case cur_code of
+ label_code:@<Read a label step@>;
+ stop_code:@<Read a stop step@>;
+ skip_code:@<Read a skip step@>;
+ krn_code:@<Read a kerning step@>;
+ lig_code,lig_code+1,lig_code+2,lig_code+3,lig_code+5,
+ lig_code+6,lig_code+7,lig_code+11:@<Read a ligature step@>;
+ end; {there are no other cases |>=label_code|}
+ finish_the_property;
+end
+else if (cur_code>=clabel_code) and (cur_code<=cpenglue_code) then begin
+ case cur_code of
+ clabel_code:@<Read an extended label step@>;
+ cpen_code:@<Read an extended penalty step@>;
+ cglue_code:@<Read an extended glue step@>;
+ cpenglue_code:@<Read an extended penalty/glue step@>;
+ ckrn_code:@<Read an extended kern step@>;
+ end; {there are no other cases |>=label_code|}
+ finish_the_property;
+end
+else flush_error('This property name doesn''t belong in a LIGTABLE list');
+@.This property name doesn't belong...@>
+end
+
+@ When a character is about to be tagged, we call the following
+procedure so that an error message is given in case of multiple tags.
+
+@p procedure check_tag(c:integer); {print error if |c| already tagged}
+begin case char_tag[c] of
+ no_tag: do_nothing;
+ lig_tag: err_print('This character already appeared in a LIGTABLE LABEL');
+@.This character already...@>
+ list_tag: err_print('This character already has a NEXTLARGER spec');
+ ext_tag: err_print('This character already has a VARCHAR spec');
+ end;
+end;
+
+@ @<Read a label step@>=
+begin while cur_char=" " do get_next;
+if cur_char="B" then begin
+ bchar_label:=nl; skip_to_paren; {\.{LABEL BOUNDARYCHAR}}
+ end
+else begin
+ backup; c:=get_byte;
+ check_tag(c); char_tag[c]:=lig_tag; char_remainder[c]:=nl;
+ end;
+if min_nl<=nl then min_nl:=nl+1;
+lk_step_ended:=false;
+end
+
+@ @d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program}
+@d kern_flag=128 {op code for a kern step}
+
+@<Globals...@>=
+@!lk_step_ended:boolean;
+ {was the last \.{LIGTABLE} property \.{LIG} or \.{KRN}?}
+@!krn_ptr:0..max_kerns; {an index into |kern|}
+
+@ @<Read a stop step@>=
+if not lk_step_ended then
+ err_print('STOP must follow LIG or KRN')
+@.STOP must follow LIG or KRN@>
+else begin
+ lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag;
+ lk_step_ended:=false;
+ end
+
+@ @<Read a skip step@>=
+if not lk_step_ended then
+ err_print('SKIP must follow LIG or KRN')
+@.SKIP must follow LIG or KRN@>
+else begin
+ c:=get_byte;
+ if c>=128 then err_print('Maximum SKIP amount is 127')
+@.Maximum SKIP amount...@>
+ else if nl+c>=max_lig_steps then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+ else begin
+ lig_kern[nl-1].b0:=c;
+ if min_nl<=nl+c then min_nl:=nl+c+1;
+ end;
+ lk_step_ended:=false;
+ end
+
+@ @<Read a ligature step@>=
+begin lig_kern[nl].b0:=0;
+lig_kern[nl].b2:=cur_code-lig_code;
+lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b3:=get_byte;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read a kerning step@>=
+begin lig_kern[nl].b0:=0; lig_kern[nl].b1:=get_byte;
+kern[nk]:=get_fix; krn_ptr:=0;
+while kern[krn_ptr]<>kern[nk] do incr(krn_ptr);
+if krn_ptr=nk then begin
+ if nk<max_kerns then incr(nk)
+ else begin
+ err_print('Sorry, too many different kerns for me to handle');
+@.Sorry, too many different kerns...@>
+ decr(krn_ptr);
+ end;
+ end;
+if ofm_level=-1 then begin
+ lig_kern[nl].b2:=kern_flag+(krn_ptr div 256);
+ lig_kern[nl].b3:=krn_ptr mod 256;
+ end
+else begin
+ lig_kern[nl].b2:=kern_flag+(krn_ptr div 65536);
+ lig_kern[nl].b3:=krn_ptr mod 65536;
+ end;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Global...@>=
+@!category_remainders:array[0..256] of integer;
+@!ivalue_category,@!max_ivalue_category:integer;
+@!glue_category,@!max_glue_category:integer;
+@!penalty_category,@!max_penalty_category:integer;
+
+@ @<Set init...@>=
+for ivalue_category:=0 to 256 do begin
+ category_remainders[ivalue_category]:=-1;
+ end;
+max_ivalue_category:=-1;
+max_glue_category:=-1;
+max_penalty_category:=-1;
+
+@ @<Read an extended label step@>=
+begin
+c:=get_byte;
+category_remainders[c]:=nl;
+if max_ivalue_category<c then max_ivalue_category:=c;
+if min_nl<=nl then min_nl:=nl+1;
+lk_step_ended:=false;
+end
+
+@ @<Read an extended penalty step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=17;
+penalty_category:=get_byte;
+if max_penalty_category<penalty_category then
+ max_penalty_category:=penalty_category;
+lig_kern[nl].b3:=penalty_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended glue step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=18;
+glue_category:=get_byte;
+if max_glue_category<glue_category then
+ max_glue_category:=glue_category;
+lig_kern[nl].b3:=glue_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended penalty/glue step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=19;
+penalty_category:=get_byte;
+if max_penalty_category<penalty_category then
+ max_penalty_category:=penalty_category;
+glue_category:=get_byte;
+if max_glue_category<glue_category then
+ max_glue_category:=glue_category;
+lig_kern[nl].b3:=penalty_category*256+glue_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended kern step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=20;
+kern[nk]:=get_fix; krn_ptr:=0;
+while kern[krn_ptr]<>kern[nk] do incr(krn_ptr);
+if krn_ptr=nk then begin
+ if nk<max_kerns then incr(nk)
+ else begin
+ err_print('Sorry, too many different kerns for me to handle');
+@.Sorry, too many different kerns...@>
+ decr(krn_ptr);
+ end;
+ end;
+if krn_ptr>65535 then
+ err_print('Sorry, too many different kerns for me to handle');
+lig_kern[nl].b3:=krn_ptr;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Globals...@>=
+@!char_extended_tag:array [char_type] of boolean;
+
+@ @<Set init...@>=
+for c:=0 to max_char do
+ char_extended_tag[c]:=false;
+
+@ @<Finish up the extended font stuff@>=
+begin
+if max_penalty_category>0 then begin
+ if nkp=0 then
+ err_print('No PENALTY table')
+ else if npp[0]<max_penalty_category then
+ err_print('Not enough PENALTY entries');
+ end;
+if max_glue_category>0 then begin
+ if nkg=0 then
+ err_print('No GLUE table')
+ else if npg[0]<max_glue_category then
+ err_print('Not enough GLUE entries');
+ end;
+if max_ivalue_category>0 then begin
+ if nki=0 then
+ err_print('No IVALUE table')
+ else if npi[0]<max_ivalue_category then
+ err_print('Not enough IVALUE entries')
+ else begin
+ for c:=0 to max_char do begin
+ if (char_wd[c]<>0) then begin
+ for j:=0 to max_ivalue_category do
+ if char_table[c,0]=j then begin
+ if category_remainders[j]<>-1 then begin
+ if char_tag[c]<>0 then
+ err_print('Character already has a tag')
+ else begin
+ char_extended_tag[c]:=true;
+ char_remainder[c]:=category_remainders[j];
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+end
+
+@ @<Global...@>=
+tables_read:boolean;
+
+@ @<Set init...@>=
+tables_read:=false;
+
+@ Finally we come to the part of \.{PLtoTF}'s input mechanism
+that is used most, the processing of individual character data.
+
+@<Read character info list@>=
+begin
+if not tables_read then begin
+ compute_new_header_ofm;
+ tables_read:=true;
+ end;
+c:=get_byte; {read the character code that is being specified}
+@<Print |c| in hex notation@>;
+while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then read_character_property
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|}
+finish_inner_property_list;
+end
+
+@ @<Globals...@>=
+@!char_original:array [0..max_char] of integer;
+@!char_repeats:array [0..max_char] of integer;
+@!diff:boolean;
+@!needed_space,@!extra_bytes:integer;
+
+@ @<Set init...@>=
+for ch_entry:=0 to max_char do begin
+ char_original[ch_entry]:=ch_entry;
+ char_repeats[ch_entry]:=0;
+ end;
+
+@ @<Read repeated character info@>=
+begin
+if not tables_read then begin
+ @<Compute the new header information for OFM files@>;
+ tables_read:=true;
+ end;
+c:=get_byte; {read the character code that is being specified}
+@<Print |c| in hex notation@>;
+crange:=get_byte; {read how many characters are being defined}
+if (crange<0) then begin
+ err_print('Character ranges must be positive');
+ crange:=0;
+ end;
+if ((c+crange)>max_char) then begin
+ err_print('Character range too large');
+ crange:=0;
+ end;
+print('-'); print_hex(c+crange);
+while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then read_character_property
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|}
+finish_inner_property_list;
+cprime:=c;
+for c:=(cprime+1) to (cprime+crange) do begin
+ char_wd[c]:=char_wd[cprime];
+ char_ht[c]:=char_ht[cprime];
+ char_dp[c]:=char_dp[cprime];
+ char_ic[c]:=char_ic[cprime];
+ for tab:=0 to (nki+nkf+nkr+nkg+nkp-1) do begin
+ char_table[c,tab]:= char_table[cprime,tab];
+ end;
+ end;
+end
+
+@ Tables for character parameters
+
+@d char_param_tables==8
+
+@<Globals...@>=
+@!char_table:array [0..max_char,0..char_param_tables] of integer;
+@!ch_table,@!ch_entry:integer;
+@!temp_value:integer;
+
+@ @<Set init...@>=
+for c:=0 to max_char do
+ for ch_table:=0 to char_param_tables do
+ char_table[c,ch_table]:=0;
+
+@ @<Read a character property@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<char_wd_code)or
+ ((cur_code>var_char_code)and
+ ((cur_code<char_ivalue_code)or(cur_code>char_penalty_code)))
+then
+ flush_error('This property name doesn''t belong in a CHARACTER list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code of
+ char_wd_code:char_wd[c]:=sort_in(width,get_fix);
+ char_ht_code:char_ht[c]:=sort_in(height,get_fix);
+ char_dp_code:char_dp[c]:=sort_in(depth,get_fix);
+ char_ic_code:char_ic[c]:=sort_in(italic,get_fix);
+ sec_width_code:temp_value:=get_fix;
+ sec_height_code:temp_value:=get_fix;
+ sec_depth_code:temp_value:=get_fix;
+ sec_italic_code:temp_value:=get_fix;
+ accent_code:temp_value:=get_fix;
+ prim_top_axis_code:temp_value:=get_fix;
+ prim_top_axis_bis_code:temp_value:=get_fix;
+ prim_bot_axis_code:temp_value:=get_fix;
+ prim_bot_axis_bis_code:temp_value:=get_fix;
+ prim_mid_hor_code:temp_value:=get_fix;
+ prim_mid_vert_code:temp_value:=get_fix;
+ prim_base_slant_code:temp_value:=get_fix;
+ sec_top_axis_code:temp_value:=get_fix;
+ sec_top_axis_bis_code:temp_value:=get_fix;
+ sec_bot_axis_code:temp_value:=get_fix;
+ sec_bot_axis_bis_code:temp_value:=get_fix;
+ sec_mid_hor_code:temp_value:=get_fix;
+ sec_mid_vert_code:temp_value:=get_fix;
+ sec_base_slant_code:temp_value:=get_fix;
+ next_larger_code:begin check_tag(c); char_tag[c]:=list_tag;
+ char_remainder[c]:=get_byte;
+ end;
+ var_char_code:@<Read an extensible recipe for |c|@>;
+ char_ivalue_code: begin
+ ch_table:=get_integer;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkci then nkci:=ch_table;
+ end;
+ char_fvalue_code: begin
+ ch_table:=get_integer+nki;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcf then nkcf:=ch_table;
+ end;
+ char_mvalue_code: begin
+ ch_table:=get_integer+nki+nkf;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcm then nkcm:=ch_table;
+ end;
+ char_rule_code: begin
+ ch_table:=get_integer+nki+nkf+nkm;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcr then nkcr:=ch_table;
+ end;
+ char_glue_code: begin
+ ch_table:=get_integer+nki+nkf+nkm+nkr;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcg then nkcg:=ch_table;
+ end;
+ char_penalty_code: begin
+ ch_table:=get_integer+nki+nkf+nkm+nkr+nkg;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcp then nkcp:=ch_table;
+ end;
+ end;@/
+ finish_the_property;
+ end;
+end
+
+@ @<Read an extensible r...@>=
+begin if ne=xmax_char then
+ err_print('Sorry, too many VARCHAR specs')
+@.Sorry, too many VARCHAR specs@>
+else begin
+ check_tag(c); char_tag[c]:=ext_tag; char_remainder[c]:=ne;@/
+ exten[ne]:=zero_bytes;
+ while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an extensible piece@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ incr(ne);
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an extensible p...@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<var_char_code+1)or(cur_code>var_char_code+4) then
+ flush_error('This property name doesn''t belong in a VARCHAR list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code-(var_char_code+1) of
+ 0:exten[ne].b0:=get_byte;
+ 1:exten[ne].b1:=get_byte;
+ 2:exten[ne].b2:=get_byte;
+ 3:exten[ne].b3:=get_byte;
+ end;@/
+ finish_the_property;
+ end;
+end
+
+@ The input routine is now complete except for the following code,
+which prints a progress report as the file is being read.
+@<Glob...@>=
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+
+@ @<Set init...@>=
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~ ';@/
+HEX:='0123456789ABCDEF';@/
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+
+@ The array |dig| will hold a sequence of digits to be output.
+
+@<Glob...@>=
+@!dig:array[0..32] of integer;
+
+@ Here, in fact, are two procedures that output
+|dig[j-1]|$\,\ldots\,$|dig[0]|, given $j>0$.
+
+@p procedure out_digs(j:integer); {outputs |j| digits}
+begin repeat decr(j); out(HEX[1+dig[j]]);
+until j=0;
+end;
+@#
+procedure print_digs(j:integer); {prints |j| digits}
+begin repeat decr(j); print(HEX[1+dig[j]]);
+until j=0;
+end;
+
+
+@ The |print_number| procedure indicates how |print_digs| can be used.
+This procedure can print in octal, decimal or hex notation.
+
+@d print_hex(#)==print_number(#,16)
+@d print_octal(#)==print_number(#,8)
+@d print_decimal(#)==print_number(#,10)
+
+@p procedure print_number(c:integer; form:integer); {prints value of |c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0
+ end;
+if form=8 then
+ print('''') {an apostrophe indicates the octal notation}
+else if form=16 then
+ print('"') { a double apostrophe indicates the hexadecimal notation}
+else if form<>10 then begin
+ print_ln('Internal error: print_number');
+ form:=10
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+print_digs(j);
+end;
+
+
+@ @<Print |c| in hex...@>=
+begin if chars_on_line=8 then begin
+ print_ln(' '); chars_on_line:=1;
+ end
+else begin
+ if chars_on_line>0 then print(' ');
+ incr(chars_on_line);
+ end;
+print_hex(c); {progress report}
+end
+
+@* The checking and massaging phase.
+Once the whole \.{PL} file has been read in, we must check it for consistency
+and correct any errors. This process consists mainly of running through
+the characters that exist and seeing if they refer to characters that
+don't exist. We also compute the true value of |seven_unsafe|; we make sure
+that the charlists and ligature programs contain no loops; and we
+shorten the lists of widths, heights, depths, and italic corrections,
+if necessary, to keep from exceeding the required maximum sizes.
+
+@<Glob...@>=
+@!seven_unsafe:boolean; {do seven-bit characters generate eight-bit ones?}
+
+@ @<Correct and check the information@>=
+if nl>0 then @<Make sure the ligature/kerning program ends appropriately@>;
+seven_unsafe:=false;
+for c:=0 to max_char do if char_wd[c]<>0 then
+ @<For all characters |g| generated by |c|,
+ make sure that |char_wd[g]| is nonzero, and
+ set |seven_unsafe| if |c<128<=g|@>;
+if bchar_label<xmax_label then begin
+ c:=xmax_char; @<Check ligature program of |c|@>;
+ end;
+if seven_bit_safe_flag and seven_unsafe then
+ print_ln('The font is not really seven-bit-safe!');
+@.The font is not...safe@>
+@<Check for infinite ligature loops@>;
+@<Doublecheck the lig/kern commands and the extensible recipes@>;
+finish_extended_font;
+for c:=0 to max_char do
+ @<Make sure that |c| is not the largest element of a charlist cycle@>;
+@<Put the width, height, depth, and italic lists into final form@>
+
+@ The checking that we need in several places is accomplished by three
+macros that are only slightly tricky.
+
+@d existence_tail(#)==begin char_wd[g]:=sort_in(width,0);
+ print(#,' '); print_hex(c);
+ print_ln(' had no CHARACTER spec.');
+ end;
+ end
+@d check_existence_and_safety(#)==begin g:=#;
+ if (g>=128)and(c<128) then seven_unsafe:=true;
+ if char_wd[g]=0 then existence_tail
+@d check_existence(#)==begin g:=#;
+ if char_wd[g]=0 then existence_tail
+
+@<For all characters |g| generated by |c|...@>=
+case char_tag[c] of
+ no_tag: do_nothing;
+ lig_tag: @<Check ligature program of |c|@>;
+ list_tag: check_existence_and_safety(char_remainder[c])
+ ('The character NEXTLARGER than');
+@.The character NEXTLARGER...@>
+ ext_tag:@<Check the pieces of |exten[c]|@>;
+ end
+
+@ @<Check the pieces...@>=
+begin if exten[char_remainder[c]].b0>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b0)
+ ('TOP piece of character');
+@.TOP piece of character...@>
+if exten[char_remainder[c]].b1>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b1)
+ ('MID piece of character');
+@.MID piece of character...@>
+if exten[char_remainder[c]].b2>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b2)
+ ('BOT piece of character');
+@.BOT piece of character...@>
+check_existence_and_safety(exten[char_remainder[c]].b3)
+ ('REP piece of character');
+@.REP piece of character...@>
+end
+
+@ @<Make sure that |c| is not the largest element of a charlist cycle@>=
+if char_tag[c]=list_tag then begin
+ g:=char_remainder[c];
+ while (g<c)and(char_tag[g]=list_tag) do g:=char_remainder[g];
+ if g=c then begin
+ char_tag[c]:=no_tag;
+ print('A cycle of NEXTLARGER characters has been broken at ');
+@.A cycle of NEXTLARGER...@>
+ print_hex(c); print_ln('.');
+ end;
+ end
+
+@ @<Global...@>=
+@!delta:fix_word; {size of the intervals needed for rounding}
+
+@ @d round_message(#)==if delta>0 then print_ln('I had to round some ',
+@.I had to round...@>
+ #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.')
+
+@<Put the width, height, depth, and italic lists into final form@>=
+case ofm_level of
+ -1: begin
+ top_width:=255; top_depth:=15; top_height:=15; top_italic:=63;
+ end;
+ 0: begin
+ top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255;
+ end;
+ 1: begin
+ top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255;
+ end;
+ end;
+delta:=shorten(width,top_width); set_indices(width,delta);
+ round_message('width');@/
+delta:=shorten(height,top_height); set_indices(height,delta);
+ round_message('height');@/
+delta:=shorten(depth,top_depth); set_indices(depth,delta);
+ round_message('depth');@/
+delta:=shorten(italic,top_italic); set_indices(italic,delta);
+ round_message('italic correction');
+
+@ @d clear_lig_kern_entry== {make an unconditional \.{STOP}}
+ lig_kern[nl].b0:=255; lig_kern[nl].b1:=0;
+ lig_kern[nl].b2:=0; lig_kern[nl].b3:=0
+
+@<Make sure the ligature/kerning program ends...@>=
+begin if bchar_label<xmax_label then {make room for it} begin
+ clear_lig_kern_entry; incr(nl);
+ end; {|bchar_label| will be stored later}
+while min_nl>nl do begin
+ clear_lig_kern_entry; incr(nl);
+ end;
+if (lig_kern[nl-1].b0 mod 256)=0 then
+ lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag;
+end
+
+@ It's not trivial to check for infinite loops generated by repeated
+insertion of ligature characters. But fortunately there is a nice
+algorithm for such testing, copied here from the program \.{TFtoPL}
+where it is explained further.
+
+@d simple=0 {$f(x,y)=z$}
+@d left_z=1 {$f(x,y)=f(z,y)$}
+@d right_z=2 {$f(x,y)=f(x,z)$}
+@d both_z=3 {$f(x,y)=f(f(x,z),y)$}
+@d pending=4 {$f(x,y)$ is being evaluated}
+
+
+@ @<Glo...@>=
+@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|}
+@!hash:array[0..hash_size] of integer;
+@!class:array[0..hash_size] of simple..pending;
+@!lig_z:array[0..hash_size] of xxchar_type;
+@!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|}
+@!hash_list:array[0..hash_size] of 0..hash_size; {list of those nonzero entries}
+@!h,@!hh:0..hash_size; {indices into the hash table}
+@!tt:indx; {temporary register}
+@!x_lig_cycle,@!y_lig_cycle:xchar_type; {problematic ligature pair}
+
+@ @<Set init...@>=
+hash_ptr:=0; y_lig_cycle:=xmax_char;
+for k:=0 to hash_size do hash[k]:=0;
+
+@ @d lig_exam==lig_kern[lig_ptr].b1
+@d lig_gen==lig_kern[lig_ptr].b3
+
+@<Check lig...@>=
+begin lig_ptr:=char_remainder[c];
+if (lig_kern[lig_ptr].b0 div 256)=0 then
+begin
+repeat if hash_input(lig_ptr,c) then begin
+ if lig_kern[lig_ptr].b2<kern_flag then begin
+ if lig_exam<>bchar then
+ check_existence(lig_exam)('LIG character examined by');
+@.LIG character examined...@>
+ check_existence(lig_gen)('LIG character generated by');
+@.LIG character generated...@>
+ if lig_gen>=128 then if(c<128)or(c=bchar) then
+ if(lig_exam<128)or(lig_exam=bchar) then seven_unsafe:=true;
+ end
+ else if lig_exam<>bchar then
+ check_existence(lig_exam)('KRN character examined by');
+@.KRN character examined...@>
+ end;
+if (lig_kern[lig_ptr].b0 mod 256)>=stop_flag then lig_ptr:=nl
+else lig_ptr:=lig_ptr+1+lig_kern[lig_ptr].b0;
+until lig_ptr>=nl;
+end;
+end
+
+@ The |hash_input| procedure is copied from \.{TFtoPL}, but it is made
+into a boolean function that returns |false| if the ligature command
+was masked by a previous one.
+
+@p function hash_input(@!p,@!c:indx):boolean;
+ {enter data for character |c| and command in location |p|, unless it isn't new}
+label 30; {go here for a quick exit}
+var @!cc:simple..both_z; {class of data being entered}
+@!zz:char_type; {function value or ligature character being entered}
+@!y:char_type; {the character after the cursor}
+@!key:integer; {value to be stored in |hash|}
+@!t:integer; {temporary register for swapping}
+begin if hash_ptr=hash_size then
+ begin hash_input:=false; goto 30;@+end;
+@<Compute the command parameters |y|, |cc|, and |zz|@>;
+key:=xmax_char*c+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size;
+while hash[h]>0 do begin
+ if hash[h]<=key then begin
+ if hash[h]=key then begin
+ hash_input:=false; goto 30; {unused ligature command}
+ end;
+ t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion}
+ t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap}
+ t:=lig_z[h]; lig_z[h]:=zz; zz:=t;
+ end;
+ if h>0 then decr(h)@+else h:=hash_size;
+ end;
+hash[h]:=key; class[h]:=cc; lig_z[h]:=zz;
+incr(hash_ptr); hash_list[hash_ptr]:=h;
+hash_input:=true;
+30:end;
+
+@ @<Compute the command param...@>=
+y:=lig_kern[p].b1; t:=lig_kern[p].b2; cc:=simple;
+zz:=lig_kern[p].b3;
+if t>=kern_flag then zz:=y
+else begin
+ case t of
+ 0,6:do_nothing; {\.{LIG},\.{/LIG>}}
+ 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}}
+ 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}}
+ 2:cc:=right_z; {\.{/LIG}}
+ 3:cc:=both_z; {\.{/LIG/}}
+ end; {there are no other cases}
+ end
+
+@ (More good stuff from \.{TFtoPL}.)
+
+@p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+function eval(@!x,@!y:indx):indx; {compute $f(x,y)$ with hashtable lookup}
+var @!key:integer; {value sought in hash table}
+begin key:=xmax_char*x+y+1; h:=(hash_mult*key) mod hash_size;
+while hash[h]>key do
+ if h>0 then decr(h)@+else h:=hash_size;
+if hash[h]<key then eval:=y {not in ordered hash table}
+else eval:=f(h,x,y);
+end;
+
+@ Pascal's beastly convention for |forward| declarations prevents us from
+saying |function f(h,x,y:indx):indx| here.
+
+@p function f;
+begin
+case class[h] of
+ simple: do_nothing;
+ left_z: begin class[h]:=pending; lig_z[h]:=eval(lig_z[h],y); class[h]:=simple;
+ end;
+ right_z: begin class[h]:=pending; lig_z[h]:=eval(x,lig_z[h]); class[h]:=simple;
+ end;
+ both_z: begin class[h]:=pending; lig_z[h]:=eval(eval(x,lig_z[h]),y);
+ class[h]:=simple;
+ end;
+ pending: begin x_lig_cycle:=x; y_lig_cycle:=y;
+ lig_z[h]:=xxmax_char; class[h]:=simple;
+ end; {the value |xxmax_char| will break all cycles,
+ since it's not in |hash|}
+ end; {there are no other cases}
+f:=lig_z[h];
+end;
+
+@ @<Check for infinite...@>=
+if hash_ptr<hash_size then for hh:=1 to hash_ptr do begin
+ tt:=hash_list[hh];
+ if class[tt]>simple then {make sure $f$ is well defined}
+ tt:=f(tt,(hash[tt]-1)div xmax_char,(hash[tt]-1)mod xmax_char);
+ end;
+if(hash_ptr=hash_size)or(y_lig_cycle<xmax_char) then begin
+ if hash_ptr<hash_size then begin
+ print('Infinite ligature loop starting with ');
+@.Infinite ligature loop...@>
+ if x_lig_cycle=xmax_char
+ then print('boundary')@+else print_hex(x_lig_cycle);
+ print(' and '); print_hex(y_lig_cycle); print_ln('!');
+ end
+ else print_ln('Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ print_ln('All ligatures will be cleared.');
+ for c:=0 to max_char do if char_tag[c]=lig_tag then begin
+ char_tag[c]:=no_tag; char_remainder[c]:=0;
+ end;
+ nl:=0; bchar:=xmax_char; bchar_label:=xmax_label;
+ end
+
+@ The lig/kern program may still contain references to nonexistent characters,
+if parts of that program are never used. Similarly, there may be extensible
+characters that are never used, because they were overridden by
+\.{NEXTLARGER}, say. This would produce an invalid \.{TFM} file; so we
+must fix such errors.
+
+@d double_check_tail(#)==@t\1@>if char_wd[0]=0
+ then char_wd[0]:=sort_in(width,0);
+ print('Unused ',#,' refers to nonexistent character ');
+ print_hex(c); print_ln('!');
+ end;
+ end
+@d double_check_lig(#)==begin c:=lig_kern[lig_ptr].#;
+ if char_wd[c]=0 then if c<>bchar then
+ begin lig_kern[lig_ptr].#:=0; double_check_tail
+@d double_check_ext(#)==begin c:=exten[g].#;
+ if c>0 then if char_wd[c]=0 then
+ begin exten[g].#:=0; double_check_tail
+@d double_check_rep(#)==begin c:=exten[g].#;
+ if char_wd[c]=0 then
+ begin exten[g].#:=0; double_check_tail
+
+@<Doublecheck...@>=
+if nl>0 then for lig_ptr:=0 to nl-1 do
+ if (lig_kern[lig_ptr].b0 div 256)=0 then begin
+ if lig_kern[lig_ptr].b2<kern_flag then begin
+ if lig_kern[lig_ptr].b0<255 then begin
+ double_check_lig(b1)('LIG step'); double_check_lig(b3)('LIG step');
+ end;
+ end
+ else double_check_lig(b1)('KRN step');
+ end;
+@.Unused LIG step...@>
+@.Unused KRN step...@>
+if ne>0 then for g:=0 to ne-1 do begin
+ double_check_ext(b0)('VARCHAR TOP');
+ double_check_ext(b1)('VARCHAR MID');
+ double_check_ext(b2)('VARCHAR BOT');
+ double_check_rep(b3)('VARCHAR REP');
+@.Unused VARCHAR...@>
+ end
+
+@* The output phase.
+Now that we know how to get all of the font data correctly stored in
+\.{PLtoTF}'s memory, it only remains to write the answers out.
+
+First of all, it is convenient to have an abbreviation for output to the
+\.{TFM} file:
+
+@d out(#)==write(tfm_file,#)
+
+@ The general plan for producing \.{TFM} files is long but simple:
+
+@<Do the font metric output@>=
+compute_subfile_sizes;
+output_subfile_sizes;
+@<Output the header block@>;
+output_new_information_ofm;
+output_character_info;
+@<Output the dimensions themselves@>;
+@<Output the ligature/kern program@>;
+@<Output the extensible character recipes@>;
+@<Output the parameters@>;
+
+@ A \.{TFM} file begins with 12 numbers that tell how big its subfiles are.
+We already know most of these numbers; for example, the number of distinct
+widths is |memory[width]+1|, where the $+1$ accounts for the zero width that
+is always supposed to be present. But we still should compute the beginning
+and ending character codes (|bc| and |ec|), the number of header words (|lh|),
+and the total number of words in the \.{TFM} file (|lf|).
+
+@<Gl...@>=
+@!bc:byte; {the smallest character code in the font}
+@!ec:byte; {the largest character code in the font}
+@!lh:byte; {the number of words in the header block}
+@!lf:unsigned_integer; {the number of words in the entire \.{TFM} file}
+@!not_found:boolean; {has a font character been found?}
+@!temp_width:fix_word; {width being used to compute a check sum}
+@!ncw,@!nco,@!npc:integer;
+
+@ It might turn out that no characters exist at all. But \.{PLtoTF} keeps
+going and writes the \.{TFM} anyway. In this case |ec| will be~0 and |bc|
+will be~1.
+
+@<Compute the subfile sizes@>=
+case ofm_level of
+ -1: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=255) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=255;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ lf:=6+lh+(ec-bc+1)+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+nl+lk_offset+nk+ne+np;
+ end;
+ 0: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=max_char) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=max_char;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ lf:=14+lh+2*(ec-bc+1)+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+2*nl+lk_offset+nk+2*ne+np;
+ end;
+ 1: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=max_char) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=max_char;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ @<Compute the character info size@>;
+ lf:=29+lh+ncw+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+2*(nl+lk_offset)+nk+2*ne+np+
+ nki+nwi+nkf+nwf+nkm+nwm++nkr+nwr+nkg+nwg+nkp+nwp;
+ nco:=29+lh+nki+nwi+nkf+nwf+nkm+nwm++nkr+nwr+nkg+nwg+nkp+nwp;
+ end;
+ end;
+
+@ @d out_size(#)==out((#) div 256); out((#) mod 256)
+ @d out_integer(#)==out((#) div @"1000000);
+ out(((#) mod @"1000000) div @"10000);
+ out(((#) mod @"10000) div @"100);
+ out((#) mod @"100)
+
+@<Output the subfile sizes@>=
+case ofm_level of
+ -1: begin
+ out_size(lf); out_size(lh); out_size(bc); out_size(ec);
+ out_size(memory[width]); out_size(memory[height]);
+ out_size(memory[depth]); out_size(memory[italic]);
+ out_size(nl+lk_offset); out_size(nk); out_size(ne); out_size(np);
+ end;
+ 0: begin
+ out_integer(0);
+ out_integer(lf); out_integer(lh); out_integer(bc); out_integer(ec);
+ out_integer(memory[width]); out_integer(memory[height]);
+ out_integer(memory[depth]); out_integer(memory[italic]);
+ out_integer(nl+lk_offset); out_integer(nk);
+ out_integer(ne); out_integer(np); out_integer(font_dir);
+ end;
+ 1: begin
+ out_integer(1);
+ out_integer(lf); out_integer(lh);
+ out_integer(bc); out_integer(ec);
+ out_integer(memory[width]); out_integer(memory[height]);
+ out_integer(memory[depth]); out_integer(memory[italic]);
+ out_integer(nl+lk_offset); out_integer(nk);
+ out_integer(ne); out_integer(np); out_integer(font_dir);
+ out_integer(nco); out_integer(ncw); out_integer(npc);
+ out_integer(nki); out_integer(nwi); out_integer(nkf); out_integer(nwf);
+ out_integer(nkm); out_integer(nwm); out_integer(nkr); out_integer(nwr);
+ out_integer(nkg); out_integer(nwg); out_integer(nkp); out_integer(nwp);
+ end;
+ end;
+
+@ The routines that follow need a few temporary variables of different types.
+
+@<Gl...@>=
+@!j:0..max_header_bytes; {index into |header_bytes|}
+@!p:pointer; {index into |memory|}
+@!q:width..italic; {runs through the list heads for dimensions}
+@!par_ptr:0..max_param_words; {runs through the parameters}
+
+@ The header block follows the subfile sizes. The necessary information all
+appears in |header_bytes|, except that the design size and the seven-bit-safe
+flag must still be set.
+
+@<Output the header block@>=
+if not check_sum_specified then @<Compute the check sum@>;
+header_bytes[design_size_loc]:=design_size div @'100000000;
+ {this works since |design_size>0|}
+header_bytes[design_size_loc+1]:=(design_size div @'200000) mod 256;
+header_bytes[design_size_loc+2]:=(design_size div 256) mod 256;
+header_bytes[design_size_loc+3]:=design_size mod 256;
+if not seven_unsafe then header_bytes[seven_flag_loc]:=128;
+for j:=0 to header_ptr-1 do out(header_bytes[j]);
+
+@ @<Compute the check sum@>=
+begin c0:=bc; c1:=ec; c2:=bc; c3:=ec;
+for c:=bc to ec do if char_wd[c]>0 then begin
+ temp_width:=memory[char_wd[c]];
+ if design_units<>unity then
+ temp_width:=round((temp_width/design_units)*1048576.0);
+ temp_width:=temp_width + (c+4)*@'20000000; {this should be positive}
+ c0:=(c0+c0+temp_width) mod 255;
+ c1:=(c1+c1+temp_width) mod 253;
+ c2:=(c2+c2+temp_width) mod 251;
+ c3:=(c3+c3+temp_width) mod 247;
+ end;
+header_bytes[check_sum_loc]:=c0;
+header_bytes[check_sum_loc+1]:=c1;
+header_bytes[check_sum_loc+2]:=c2;
+header_bytes[check_sum_loc+3]:=c3;
+end
+
+@ @<Global...@>=
+@!tab:integer;
+
+@
+@<Compute the character info size@>=
+if ofm_level=1 then begin
+ ncw:=0;
+ if nkcp>-1 then
+ npc:=nki+nkf+nkr+nkg+nkcp+1
+ else if nkcg>-1 then
+ npc:=nki+nkf+nkr+nkcg+1
+ else if nkcr>-1 then
+ npc:=nki+nkf+nkcr+1
+ else if nkcf>-1 then
+ npc:=nki+nkcf+1
+ else if nkci>-1 then
+ npc:=nkci+1
+ else
+ npc:=0;
+ needed_space:=(12+npc*2) div 4;
+ extra_bytes:=(needed_space*4) - (10+npc*2);
+ for c:=bc to ec do begin
+ if char_original[c]=c then begin
+ cprime:=c+1;
+ diff:=false;
+ while (not diff) and (cprime<=ec) do begin
+ if index[char_wd[c]]<>index[char_wd[cprime]] then diff:=true;
+ if index[char_ht[c]]<>index[char_ht[cprime]] then diff:=true;
+ if index[char_dp[c]]<>index[char_dp[cprime]] then diff:=true;
+ if index[char_ic[c]]<>index[char_ic[cprime]] then diff:=true;
+ if char_remainder[c]<>char_remainder[cprime] then diff:=true;
+ for tab:=0 to npc-1 do begin
+ if char_table[c,tab]<>char_table[cprime,tab] then diff:=true;
+ end;
+ if not diff then begin
+ char_original[cprime]:=c;
+ cprime:=cprime+1;
+ end;
+ end;
+ if cprime>(c+1) then begin
+ char_repeats[c]:=cprime-c-1;
+ end;
+ ncw:=ncw+needed_space;
+ end;
+ end;
+ end;
+
+@ The next block contains packed |char_info|.
+
+@<Output the character info@>=
+index[0]:=0;
+for c:=bc to ec do
+case ofm_level of
+ -1: begin
+ out(index[char_wd[c]]);
+ out(index[char_ht[c]]*16+index[char_dp[c]]);
+ out(index[char_ic[c]]*4+char_tag[c]);
+ out(char_remainder[c]);
+ end;
+ 0: begin
+ out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256);
+ out(index[char_ht[c]]); out(index[char_dp[c]]);
+ out(index[char_ic[c]] div 64);out((index[char_ic[c]] mod 64)*4+char_tag[c]);
+ out(char_remainder[c] div 256); out(char_remainder[c] mod 256);
+ end;
+ 1: begin
+ if c=char_original[c] then begin
+ out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256);
+ out(index[char_ht[c]]); out(index[char_dp[c]]);
+ out(index[char_ic[c]]);
+ tab:=char_tag[c];
+ if char_extended_tag[c] then begin
+ tab:=5;
+ end;
+ out(tab);
+ out(char_remainder[c] div 256); out(char_remainder[c] mod 256);
+ out_size(char_repeats[c]);
+ for tab:=0 to npc-1 do begin
+ out(char_table[c,tab] div 256); out(char_table[c,tab] mod 256);
+ end;
+ for tab:=1 to extra_bytes do begin
+ out(0);
+ end;
+ end;
+ end;
+ end;
+
+
+@ When a scaled quantity is output, we may need to divide it by |design_units|.
+The following subroutine takes care of this, using floating point arithmetic
+only if |design_units<>1.0|.
+
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if abs(x/design_units)>=16.0 then begin
+ print_ln('The relative dimension ',x/@'4000000:1:3,
+ ' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then print(' =',design_units/@'200000:1:3,
+ ' designunits');
+ print_ln(')'); x:=0;
+ end;
+if design_units<>unity then x:=round((x/design_units)*1048576.0);
+if x<0 then begin
+ out(255); x:=x+@'100000000;
+ if x<=0 then x:=1;
+ end
+else begin out(0);
+ if x>=@'100000000 then x:=@'77777777;
+ end;
+n:=x div @'200000; m:=x mod @'200000;
+out(n); out(m div 256); out(m mod 256);
+end;
+
+@ We have output the packed indices for individual characters.
+The scaled widths, heights, depths, and italic corrections are next.
+
+@<Output the dimensions themselves@>=
+for q:=width to italic do begin
+ out(0); out(0); out(0); out(0); {output the zero word}
+ p:=link[q]; {head of list}
+ while p>0 do begin
+ out_scaled(memory[p]);
+ p:=link[p];
+ end;
+ end;
+
+@ One embarrassing problem remains: The ligature/kern program might be very
+long, but the starting addresses in |char_remainder| can be at most~255.
+Therefore we need to output some indirect address information; we want to
+compute |lk_offset| so that addition of |lk_offset| to all remainders makes
+all but |lk_offset| distinct remainders less than~256.
+
+For this we need a sorted table of all relevant remainders.
+
+@<Glob...@>=
+@!label_table:array[xchar_type] of record
+ @!rr: -1..xmax_label; {sorted label values}
+ @!cc: integer; {associated characters}
+ end;
+@!label_ptr:xchar_type; {index of highest entry in |label_table|}
+@!sort_ptr:xchar_type; {index into |label_table|}
+@!lk_offset:xchar_type; {smallest offset value that might work}
+@!t:0..xmax_label; {label value that is being redirected}
+@!extra_loc_needed:boolean; {do we need a special word for |bchar|?}
+
+@ @<Compute the ligature/kern program offset@>=
+@<Insert all labels into |label_table|@>;
+if bchar<xmax_char then begin
+ extra_loc_needed:=true; lk_offset:=1;
+ end
+else begin
+ extra_loc_needed:=false; lk_offset:=0;
+ end;
+@<Find the minimum |lk_offset| and adjust all remainders@>;
+if bchar_label<xmax_label then begin
+ if ofm_level=-1 then begin
+ lig_kern[nl-1].b2:=(bchar_label+lk_offset)div 256;
+ lig_kern[nl-1].b3:=(bchar_label+lk_offset)mod 256;
+ end
+ else begin
+ lig_kern[nl-1].b2:=(bchar_label+lk_offset)div 65536;
+ lig_kern[nl-1].b3:=(bchar_label+lk_offset)mod 65536;
+ end
+ end
+
+@ @<Insert all labels...@>=
+label_ptr:=0; label_table[0].rr:=-1; {sentinel}
+for c:=bc to ec do if char_tag[c]=lig_tag then begin
+ sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|}
+ while label_table[sort_ptr].rr>char_remainder[c] do begin
+ label_table[sort_ptr+1]:=label_table[sort_ptr];
+ decr(sort_ptr); {move the hole}
+ end;
+ label_table[sort_ptr+1].cc:=c;
+ label_table[sort_ptr+1].rr:=char_remainder[c];
+ incr(label_ptr);
+ end
+
+@ @<Find the minimum |lk_offset| and adjust all remainders@>=
+begin sort_ptr:=label_ptr; {the largest unallocated label}
+if ofm_level=-1 then begin
+ if label_table[sort_ptr].rr+lk_offset > 255 then begin
+ lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty}
+ repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin
+ decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ end;
+ incr(lk_offset); decr(sort_ptr);
+ until lk_offset+label_table[sort_ptr].rr<256;
+ {N.B.: |lk_offset=256| satisfies this when |sort_ptr=0|}
+ end;
+ end
+else begin
+ if label_table[sort_ptr].rr+lk_offset > 65535 then begin
+ lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty}
+ repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin
+ decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ end;
+ incr(lk_offset); decr(sort_ptr);
+ until lk_offset+label_table[sort_ptr].rr<65536;
+ {N.B.: |lk_offset=65536| satisfies this when |sort_ptr=0|}
+ end;
+ end;
+if lk_offset>0 then while sort_ptr>0 do begin
+ char_remainder[label_table[sort_ptr].cc]:=
+ char_remainder[label_table[sort_ptr].cc]+lk_offset;
+ decr(sort_ptr);
+ end;
+end
+
+@ @<Output the ligature/kern program@>=
+if ofm_level=-1 then begin
+ if extra_loc_needed then begin {|lk_offset=1|}
+ out(255); out(bchar); out(0); out(0);
+ end
+ else for sort_ptr:=1 to lk_offset do begin {output the redirection specs}
+ t:=label_table[label_ptr].rr;
+ if bchar<256 then begin
+ out(255); out(bchar);
+ end
+ else begin
+ out(254); out(0);
+ end;
+ out_size(t+lk_offset);
+ repeat decr(label_ptr); until label_table[label_ptr].rr<t;
+ end;
+ if nl>0 then for lig_ptr:=0 to nl-1 do begin
+ out(lig_kern[lig_ptr].b0);
+ out(lig_kern[lig_ptr].b1);
+ out(lig_kern[lig_ptr].b2);
+ out(lig_kern[lig_ptr].b3);
+ end;
+ if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr])
+ end
+else begin
+ if extra_loc_needed then {|lk_offset=1|} begin
+ out_size(255); out_size(bchar); out_size(0); out_size(0);
+ end
+ else
+ for sort_ptr:=1 to lk_offset do {output the redirection specs} begin
+ t:=label_table[label_ptr].rr;
+ if bchar<xmax_char then begin
+ out_size(255); out_size(bchar);
+ end
+ else begin
+ out_size(254); out_size(0);
+ end;
+ out_size((t+lk_offset) div 256);
+ out_size((t+lk_offset) mod 256);
+ repeat decr(label_ptr); until label_table[label_ptr].rr<t;
+ end;
+ if nl>0 then for lig_ptr:=0 to nl-1 do begin
+ out_size(lig_kern[lig_ptr].b0);
+ out_size(lig_kern[lig_ptr].b1);
+ out_size(lig_kern[lig_ptr].b2);
+ out_size(lig_kern[lig_ptr].b3);
+ end;
+ if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr])
+ end
+
+@ @<Output the extensible character recipes@>=
+if ofm_level=-1 then begin
+ if ne>0 then for c:=0 to ne-1 do begin
+ out(exten[c].b0);
+ out(exten[c].b1);
+ out(exten[c].b2);
+ out(exten[c].b3);
+ end;
+ end
+else begin
+ if ne>0 then for c:=0 to ne-1 do begin
+ out_size(exten[c].b0);
+ out_size(exten[c].b1);
+ out_size(exten[c].b2);
+ out_size(exten[c].b3);
+ end;
+ end;
+
+@ For our grand finale, we wind everything up by outputting the parameters.
+
+@<Output the parameters@>=
+for par_ptr:=1 to np do begin
+ if par_ptr=1 then
+ @<Output the slant (|param[1]|) without scaling@>
+ else out_scaled(param[par_ptr]);
+ end
+
+@ @<Output the slant...@>=
+begin if param[1]<0 then begin
+ param[1]:=param[1]+@'10000000000;
+ out((param[1] div @'100000000)+256-64);
+ end
+else out(param[1] div @'100000000);
+out((param[1] div @'200000) mod 256);
+out((param[1] div 256) mod 256);
+out(param[1] mod 256);
+end
+
+@* The main program.
+The routines sketched out so far need to be packaged into separate procedures,
+on some systems, since some \PASCAL\ compilers place a strict limit on the
+size of a routine. The packaging is done here in an attempt to avoid some
+system-dependent changes.
+
+@p procedure param_enter;
+begin @<Enter the parameter names@>;
+end;
+@#
+procedure name_enter; {enter all names and their equivalents}
+begin @<Enter all of the names...@>;
+param_enter;
+end;
+@#
+procedure read_lig_kern;
+var @!krn_ptr:0..max_kerns; {an index into |kern|}
+@!c:integer; {runs through all character codes}
+begin @<Read ligature/kern list@>;
+end;
+@#
+procedure output_new_information_ofm;
+begin @<Output the new information for OFM files@>;
+end;
+@#
+procedure compute_new_header_ofm;
+begin @<Compute the new header information for OFM files@>;
+end;
+@#
+procedure finish_extended_font;
+begin @<Finish up the extended font stuff@>;
+end;
+@#
+procedure output_subfile_sizes;
+begin @<Output the subfile sizes@>;
+end;
+@#
+procedure compute_subfile_sizes;
+begin @<Compute the subfile sizes@>;
+end;
+@#
+procedure output_character_info;
+begin @<Output the character info@>;
+end;
+@#
+procedure read_font_rule_list;
+begin @<Read font rule list@>;
+end;
+@#
+procedure read_font_glue_list;
+begin @<Read font glue list@>;
+end;
+@#
+procedure read_font_penalty_list;
+begin @<Read font penalty list@>;
+end;
+@#
+procedure read_font_mvalue_list;
+begin @<Read font mvalue list@>;
+end;
+@#
+procedure read_font_fvalue_list;
+begin @<Read font fvalue list@>;
+end;
+@#
+procedure read_font_ivalue_list;
+begin @<Read font ivalue list@>;
+end;
+@#
+procedure read_repeated_character_info;
+begin @<Read repeated character info@>;
+end;
+@#
+procedure read_lig_kern_command;
+begin @<Read a ligature/kern command@>;
+end;
+@#
+procedure read_character_property;
+begin @<Read a character property@>;
+end;
+@#
+procedure read_char_info;
+begin @<Read character info list@>;
+end;
+@#
+procedure read_input;
+var @!c:integer; {header or parameter index}
+begin @<Read all the input@>;
+end;
+@#
+procedure corr_and_check;
+var @!c:integer; {runs through all character codes}
+@!hh:0..hash_size; {an index into |hash_list|}
+@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|}
+@!g:byte; {a character generated by the current character |c|}
+begin @<Correct and check the information@>
+end;
+
+@ Here is where \.{PLtoTF} begins and ends.
+
+@p begin initialize;@/
+name_enter;@/
+read_input; print('.');@/
+corr_and_check;@/
+@<Do the font metric output@>;
+end.
+
+@ @<Global...@>=
+@!ofm_level:integer;
+
+@ @<Set init...@>=
+ofm_level:=-1; {Suppose that it is a TFM file}
+
+@ @<Read OFM level code@>=
+begin
+ofm_level:=get_integer;
+if (ofm_level<0) or (ofm_level>1) then begin
+ flush_error('OFMLEVEL must be 0 or 1 -- 1 assumed');
+ ofm_level:=1;
+ end;
+end
+
+@ @<Read font direction code@>=
+begin
+font_dir:=-1;
+repeat get_next;
+until cur_char<>" ";
+case cur_char of
+ "T": begin get_next;
+ if cur_char="L" then font_dir:=0
+ else if cur_char="R" then font_dir:=2;
+ end;
+ "B": begin get_next;
+ if cur_char="L" then font_dir:=4
+ else if cur_char="R" then font_dir:=6;
+ end;
+ "R": begin get_next;
+ if cur_char="T" then font_dir:=5
+ else if cur_char="B" then font_dir:=7;
+ end;
+ "L": begin get_next;
+ if cur_char="T" then font_dir:=1
+ else if cur_char="B" then font_dir:=3;
+ end;
+ end;
+while cur_char<>")" do get_next;
+if font_dir = -1 then begin
+ flush_error('FONTDIR must be valid direction, -- TR assumed');
+ font_dir:=0;
+ end;
+end
+
+@ @<Read natural font direction code@>=
+begin
+font_dir:=-1;
+repeat get_next;
+until cur_char<>" ";
+case cur_char of
+ "T": begin get_next;
+ if cur_char="L" then font_dir:=8
+ else if cur_char="R" then font_dir:=10;
+ end;
+ "B": begin get_next;
+ if cur_char="L" then font_dir:=12
+ else if cur_char="R" then font_dir:=14;
+ end;
+ "R": begin get_next;
+ if cur_char="T" then font_dir:=13
+ else if cur_char="B" then font_dir:=15;
+ end;
+ "L": begin get_next;
+ if cur_char="T" then font_dir:=9
+ else if cur_char="B" then font_dir:=11;
+ end;
+ end;
+while cur_char<>")" do get_next;
+if font_dir = -1 then begin
+ flush_error('NFONTDIR must be valid direction, -- TR assumed');
+ font_dir:=8;
+ end;
+end
+
+@
+Here are some general values for the various entries.
+They can all be changed.
+
+@d arrays_per_kind==20
+@d entries_per_array==200
+
+@ @<Constants...@>=
+@!rule_arrays=arrays_per_kind;
+@!rule_entries=entries_per_array;
+
+@ @<Types...@>=
+rule_array_type=0..rule_arrays;
+rule_entry_type=0..rule_entries;
+rule_node=
+record
+ rn_width: fix_word;
+ rn_height: fix_word;
+ rn_depth: fix_word;
+end;
+
+@ @<Global...@>=
+@!rules:array[rule_array_type,rule_entry_type] of rule_node;
+@!npr:array[rule_array_type] of integer;
+@!nkr:integer;
+@!nkcr:integer;
+@!nwr:integer;
+@!r_array:integer;
+@!r_number:integer;
+
+@ @<Set init...@>=
+for r_array := 0 to rule_arrays do begin
+ npr[r_array]:=0;
+ @<Null out the rule@>;
+ end;
+nkr:=-1;
+nkcr:=-1;
+
+@ @<Read font rule list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+r_array:=get_integer;
+if r_array>rule_arrays then
+ flush_error('This FONTRULE table index is too big for my present size')
+else if r_array<0 then
+ flush_error('This FONTRULE index is negative')
+else begin
+ if r_array>nkr then nkr:=r_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a rule@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a rule@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>rule_code then
+ flush_error('This property name doesn''t belong in a RULE list')
+else begin
+ r_number:=get_integer;
+ if r_number>rule_entries then
+ flush_error('This RULE index is too big for my present table size')
+ else if r_number<0 then
+ flush_error('This RULE index is negative')
+ else begin
+ while npr[r_array]<r_number do begin
+ incr(npr[r_array]); @<Null out the rule@>;
+ end;
+ @<Read all of a rule's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the rule@>=
+begin
+rules[r_array,npr[r_array]].rn_width:=0;
+rules[r_array,npr[r_array]].rn_depth:=0;
+rules[r_array,npr[r_array]].rn_height:=0;
+end
+
+@ @<Read all of a rule's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single rule value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single rule value@>=
+begin
+get_name;
+case cur_code of
+ rule_width_code:
+ rules[r_array,r_number].rn_width:=get_fix;
+ rule_height_code:
+ rules[r_array,r_number].rn_height:=get_fix;
+ rule_depth_code:
+ rules[r_array,r_number].rn_depth:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for rules@>=
+begin
+nwr:=0;
+for r_array := 0 to nkr do begin
+ incr(npr[r_array]);
+ nwr := nwr + 3*npr[r_array];
+ end;
+incr(nkr);
+end
+
+@ @<Output the rules@>=
+begin
+for r_array:= 0 to nkr-1 do
+ for r_number:=0 to npr[r_array]-1 do begin
+ out_scaled(rules[r_array,r_number].rn_width);
+ out_scaled(rules[r_array,r_number].rn_height);
+ out_scaled(rules[r_array,r_number].rn_depth);
+ end;
+end
+
+@ @<Output the rule headers@>=
+begin
+for r_array:= 0 to nkr-1 do begin
+ out_integer(npr[r_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!glue_arrays=arrays_per_kind;
+@!glue_entries=entries_per_array;
+
+@
+@d t_normal==0
+@d t_aleaders==1
+@d t_cleaders==2
+@d t_xleaders==3
+
+@d o_unit==0
+@d o_fi==1
+@d o_fil==2
+@d o_fill==3
+@d o_filll==4
+
+@d g_space==0
+@d g_rule==1
+@d g_char==2
+
+@<Types...@>=
+glue_array_type=0..glue_arrays;
+glue_entry_type=0..glue_entries;
+glue_node=
+record
+ gn_width: fix_word;
+ gn_stretch: fix_word;
+ gn_shrink: fix_word;
+ gn_type: integer;
+ gn_arg_type: g_space..g_char;
+ gn_stretch_order: integer;
+ gn_shrink_order: integer;
+ gn_argument: integer;
+end;
+
+@ @<Global...@>=
+@!glues:array[glue_array_type,glue_entry_type] of glue_node;
+@!npg:array[glue_array_type] of integer;
+@!nkg:integer;
+@!nkcg:integer;
+@!nwg:integer;
+@!g_array:integer;
+@!g_byte:integer;
+@!g_number:integer;
+
+@ @<Set init...@>=
+for g_array := 0 to glue_arrays do
+begin
+ npg[g_array]:=0;
+ @<Null out the glue@>;
+end;
+nkg:=-1;
+nkcg:=-1;
+
+@ @<Read font glue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+g_array:=get_integer;
+if g_array>glue_arrays then
+ flush_error('This FONTGLUE table index is too big for my present size')
+else if g_array<0 then
+ flush_error('This FONTGLUE index is negative')
+else begin
+ if g_array>nkg then nkg:=g_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a glue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a glue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>glue_code then
+ flush_error('This property name doesn''t belong in a GLUE list')
+else begin
+ g_number:=get_integer;
+ if g_number>glue_entries then
+ flush_error('This GLUE index is too big for my present table size')
+ else if g_number<0 then
+ flush_error('This GLUE index is negative')
+ else begin
+ while npg[g_array]<g_number do begin
+ incr(npg[g_array]); @<Null out the glue@>;
+ end;
+ @<Read all of a glue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the glue@>=
+begin
+glues[g_array,npg[g_array]].gn_width:=0;
+glues[g_array,npg[g_array]].gn_stretch:=0;
+glues[g_array,npg[g_array]].gn_shrink:=0;
+glues[g_array,npg[g_array]].gn_type:=0;
+glues[g_array,npg[g_array]].gn_arg_type:=0;
+glues[g_array,npg[g_array]].gn_stretch_order:=0;
+glues[g_array,npg[g_array]].gn_shrink_order:=0;
+glues[g_array,npg[g_array]].gn_argument:=0;
+end
+
+@ @<Read all of a glue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single glue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single glue value@>=
+begin
+get_name;
+case cur_code of
+ glue_width_code:
+ glues[g_array,g_number].gn_width:=get_fix;
+ glue_stretch_code:
+ glues[g_array,g_number].gn_stretch:=get_fix;
+ glue_shrink_code:
+ glues[g_array,g_number].gn_shrink:=get_fix;
+ glue_type_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>3) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_type:=g_byte;
+ end;
+ glue_stretch_order_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>4) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_stretch_order:=g_byte;
+ end;
+ glue_shrink_order_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>4) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_shrink_order:=g_byte;
+ end;
+ glue_char_code: begin
+ glues[g_array,g_number].gn_argument:=get_integer;
+ glues[g_array,g_number].gn_arg_type:=g_char;
+ end;
+ glue_rule_code: begin
+ glues[g_array,g_number].gn_argument:=get_integer;
+ glues[g_array,g_number].gn_arg_type:=g_rule;
+ end;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for glues@>=
+begin
+nwg:=0;
+for g_array := 0 to nkg do begin
+ incr(npg[g_array]);
+ nwg := nwg + 4*npg[g_array];
+ end;
+incr(nkg);
+end
+
+@ @<Output the glues@>=
+begin
+for g_array:= 0 to nkg-1 do
+ for g_number:=0 to npg[g_array]-1 do begin
+ g_byte:=glues[g_array,g_number].gn_type*16+
+ glues[g_array,g_number].gn_arg_type;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_stretch_order*16+
+ glues[g_array,g_number].gn_shrink_order;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_argument div 256;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_argument mod 256;
+ out(g_byte);
+ out_scaled(glues[g_array,g_number].gn_width);
+ out_scaled(glues[g_array,g_number].gn_stretch);
+ out_scaled(glues[g_array,g_number].gn_shrink);
+ end;
+end
+
+@ @<Output the glue headers@>=
+begin
+for g_array:= 0 to nkg-1 do begin
+ out_integer(npg[g_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!penalty_arrays=arrays_per_kind;
+@!penalty_entries=entries_per_array;
+
+@ @<Types...@>=
+penalty_array_type=0..penalty_arrays;
+penalty_entry_type=0..penalty_entries;
+penalty_node=
+record
+ pn_val: integer;
+end;
+
+@ @<Global...@>=
+@!penalties:array[penalty_array_type,penalty_entry_type] of penalty_node;
+@!npp:array[penalty_array_type] of integer;
+@!nkp:integer;
+@!nkcp:integer;
+@!nwp:integer;
+@!p_array:integer;
+@!p_number:integer;
+
+@ @<Set init...@>=
+for p_array := 0 to penalty_arrays do begin
+ npp[p_array]:=0;
+ @<Null out the penalty@>;
+ end;
+nkp:=-1;
+nkcp:=-1;
+
+@ @<Read font penalty list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+p_array:=get_integer;
+if p_array>penalty_arrays then
+ flush_error('This FONTPENALTY table index is too big for my present size')
+else if p_array<0 then
+ flush_error('This FONTPENALTY index is negative')
+else begin
+ if p_array>nkp then nkp:=p_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a penalty@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a penalty@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>penalty_code then
+ flush_error('This property name doesn''t belong in a PENALTY list')
+else begin
+ p_number:=get_integer;
+ if p_number>penalty_entries then
+ flush_error('This PENALTY index is too big for my present table size')
+ else if p_number<0 then
+ flush_error('This PENALTY index is negative')
+ else begin
+ while npp[p_array]<p_number do begin
+ incr(npp[p_array]); @<Null out the penalty@>;
+ end;
+ @<Read all of a penalty's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the penalty@>=
+begin
+penalties[p_array,npp[p_array]].pn_val:=0;
+end
+
+@ @<Read all of a penalty's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single penalty value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single penalty value@>=
+begin
+get_name;
+case cur_code of
+ penalty_val_code:
+ penalties[p_array,p_number].pn_val:=get_integer;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for penalties@>=
+begin
+nwp:=0;
+for p_array := 0 to nkp do begin
+ incr(npp[p_array]);
+ nwp := nwp + npp[p_array];
+ end;
+incr(nkp);
+end
+
+@ @<Output the penalties@>=
+begin
+for p_array:= 0 to nkp-1 do
+ for p_number:=0 to npp[p_array]-1 do begin
+ out_integer(penalties[p_array,p_number].pn_val);
+ end;
+end
+
+@ @<Output the penalty headers@>=
+begin
+for p_array:= 0 to nkp-1 do begin
+ out_integer(npp[p_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!mvalue_arrays=arrays_per_kind;
+@!mvalue_entries=entries_per_array;
+
+@ @<Types...@>=
+mvalue_array_type=0..mvalue_arrays;
+mvalue_entry_type=0..mvalue_entries;
+mvalue_node=
+record
+ fn_val: fix_word;
+end;
+
+@ @<Global...@>=
+@!mvalues:array[mvalue_array_type,mvalue_entry_type] of mvalue_node;
+@!npm:array[mvalue_array_type] of integer;
+@!nkm:integer;
+@!nkcm:integer;
+@!nwm:integer;
+@!m_array:integer;
+@!m_number:integer;
+
+@ @<Set init...@>=
+for m_array := 0 to mvalue_arrays do begin
+ npm[m_array]:=0;
+ @<Null out the mvalue@>;
+ end;
+nkm:=-1;
+nkcm:=-1;
+
+@ @<Read font mvalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+m_array:=get_integer;
+if m_array>mvalue_arrays then
+ flush_error('This FONTMVALUE table index is too big for my present size')
+else if m_array<0 then
+ flush_error('This FONTMVALUE index is negative')
+else begin
+ if m_array>nkm then nkm:=m_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an mvalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an mvalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>mvalue_code then
+ flush_error('This property name doesn''t belong in an MVALUE list')
+else begin
+ m_number:=get_integer;
+ if m_number>mvalue_entries then
+ flush_error('This MVALUE index is too big for my present table size')
+ else if m_number<0 then
+ flush_error('This MVALUE index is negative')
+ else begin
+ while npm[m_array]<m_number do begin
+ incr(npm[m_array]); @<Null out the mvalue@>;
+ end;
+ @<Read all of an mvalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the mvalue@>=
+begin
+mvalues[m_array,npm[m_array]].fn_val:=0;
+end
+
+@ @<Read all of an mvalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single mvalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single mvalue value@>=
+begin
+get_name;
+case cur_code of
+ mvalue_val_code:
+ mvalues[m_array,m_number].fn_val:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for mvalues@>=
+begin
+nwm:=0;
+for m_array := 0 to nkm do begin
+ incr(npm[m_array]);
+ nwm := nwm + npm[m_array];
+ end;
+incr(nkm);
+end
+
+@ @<Output the mvalues@>=
+begin
+for m_array:= 0 to nkm-1 do
+ for m_number:=0 to npm[m_array]-1 do begin
+ out_scaled(mvalues[m_array,m_number].fn_val);
+ end;
+end
+
+@ @<Output the mvalue headers@>=
+begin
+for m_array:= 0 to nkm-1 do begin
+ out_integer(npm[m_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!fvalue_arrays=arrays_per_kind;
+@!fvalue_entries=entries_per_array;
+
+@ @<Types...@>=
+fvalue_array_type=0..fvalue_arrays;
+fvalue_entry_type=0..fvalue_entries;
+fvalue_node=
+record
+ fn_val: fix_word;
+end;
+
+@ @<Global...@>=
+@!fvalues:array[fvalue_array_type,fvalue_entry_type] of fvalue_node;
+@!npf:array[fvalue_array_type] of integer;
+@!nkf:integer;
+@!nkcf:integer;
+@!nwf:integer;
+@!f_array:integer;
+@!f_number:integer;
+
+@ @<Set init...@>=
+for f_array := 0 to fvalue_arrays do begin
+ npf[f_array]:=0;
+ @<Null out the fvalue@>;
+ end;
+nkf:=-1;
+nkcf:=-1;
+
+@ @<Read font fvalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+f_array:=get_integer;
+if f_array>fvalue_arrays then
+ flush_error('This FONTFVALUE table index is too big for my present size')
+else if f_array<0 then
+ flush_error('This FONTFVALUE index is negative')
+else begin
+ if f_array>nkf then nkf:=f_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an fvalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an fvalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>fvalue_code then
+ flush_error('This property name doesn''t belong in an FVALUE list')
+else begin
+ f_number:=get_integer;
+ if f_number>fvalue_entries then
+ flush_error('This FVALUE index is too big for my present table size')
+ else if f_number<0 then
+ flush_error('This FVALUE index is negative')
+ else begin
+ while npf[f_array]<f_number do begin
+ incr(npf[f_array]); @<Null out the fvalue@>;
+ end;
+ @<Read all of an fvalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the fvalue@>=
+begin
+fvalues[f_array,npf[f_array]].fn_val:=0;
+end
+
+@ @<Read all of an fvalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single fvalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single fvalue value@>=
+begin
+get_name;
+case cur_code of
+ fvalue_val_code:
+ fvalues[f_array,f_number].fn_val:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for fvalues@>=
+begin
+nwf:=0;
+for f_array := 0 to nkf do begin
+ incr(npf[f_array]);
+ nwf := nwf + npf[f_array];
+ end;
+incr(nkf);
+end
+
+@ @<Output the fvalues@>=
+begin
+for f_array:= 0 to nkf-1 do
+ for f_number:=0 to npf[f_array]-1 do begin
+ out_scaled(fvalues[f_array,f_number].fn_val);
+ end;
+end
+
+@ @<Output the fvalue headers@>=
+begin
+for f_array:= 0 to nkf-1 do begin
+ out_integer(npf[f_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!ivalue_arrays=arrays_per_kind;
+@!ivalue_entries=entries_per_array;
+
+@ @<Types...@>=
+ivalue_array_type=0..ivalue_arrays;
+ivalue_entry_type=0..ivalue_entries;
+ivalue_node=
+record
+ in_val: integer;
+end;
+
+@ @<Global...@>=
+@!ivalues:array[ivalue_array_type,ivalue_entry_type] of ivalue_node;
+@!npi:array[ivalue_array_type] of integer;
+@!font_i_array:boolean;
+@!nki:integer;
+@!nkci:integer;
+@!nwi:integer;
+@!i_array:integer;
+@!i_number:integer;
+
+@ @<Set init...@>=
+for i_array := 0 to ivalue_arrays do begin
+ npi[i_array]:=0;
+ @<Null out the ivalue@>;
+ end;
+nki:=-1;
+nkci:=-1;
+
+@ @<Read font ivalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+i_array:=get_integer;
+if i_array>ivalue_arrays then
+ flush_error('This FONTIVALUE table index is too big for my present size')
+else if i_array<0 then
+ flush_error('This FONTIVALUE index is negative')
+else begin
+ if i_array>nki then nki:=i_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an ivalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an ivalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>ivalue_code then
+ flush_error('This property name doesn''t belong in an IVALUE list')
+else begin
+ i_number:=get_integer;
+ if i_number>ivalue_entries then
+ flush_error('This IVALUE index is too big for my present table size')
+ else if i_number<0 then
+ flush_error('This IVALUE index is negative')
+ else begin
+ while npi[i_array]<i_number do begin
+ incr(npi[i_array]); @<Null out the ivalue@>;
+ end;
+ @<Read all of an ivalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the ivalue@>=
+begin
+ivalues[i_array,npi[i_array]].in_val:=0;
+end
+
+@ @<Read all of an ivalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single ivalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single ivalue value@>=
+begin
+get_name;
+case cur_code of
+ ivalue_val_code:
+ ivalues[i_array,i_number].in_val:=get_integer;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for ivalues@>=
+begin
+nwi:=0;
+for i_array := 0 to nki do begin
+ incr(npi[i_array]);
+ nwi := nwi + npi[i_array];
+ end;
+incr(nki);
+end
+
+@ @<Output the ivalues@>=
+begin
+for i_array:= 0 to nki-1 do
+ for i_number:=0 to npi[i_array]-1 do begin
+ out_integer(ivalues[i_array,i_number].in_val);
+ end;
+end
+
+@ @<Output the ivalue headers@>=
+begin
+for i_array:= 0 to nki-1 do begin
+ out_integer(npi[i_array]);
+ end;
+end
+
+@ @<Compute the new header information for OFM files@>=
+begin
+@<Header information for ivalues@>;
+@<Header information for fvalues@>;
+@<Header information for mvalues@>;
+@<Header information for rules@>;
+@<Header information for glues@>;
+@<Header information for penalties@>;
+end
+
+@ @<Output the new information for OFM files@>=
+begin
+@<Output the ivalue headers@>;
+@<Output the fvalue headers@>;
+@<Output the mvalue headers@>;
+@<Output the rule headers@>;
+@<Output the glue headers@>;
+@<Output the penalty headers@>;
+@<Output the ivalues@>;
+@<Output the fvalues@>;
+@<Output the rules@>;
+@<Output the glues@>;
+@<Output the penalties@>;
+end
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{PLtoTF} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.
diff --git a/Build/source/texk/web2c/omegaware/otangle.ch b/Build/source/texk/web2c/omegaware/otangle.ch
new file mode 100644
index 00000000000..3e85ff8bbc7
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/otangle.ch
@@ -0,0 +1,474 @@
+% otangle.ch: web2c changes to file tangle.ch
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tangle.ch.
+%
+% otangle.ch for C compilation with web2c.
+%
+% 10/9/82 (HT) Original version
+% 11/29 (HT) New version, with conversion to lowercase handled properly
+% Also, new control sequence:
+% @=...text...@> Put ...text... verbatim on a line
+% by itself in the Pascal output.
+% (argument must fit on one line)
+% This control sequence facilitates putting #include "gcons.h"
+% (for example) in files meant for the pc compiler.
+% Also, changed command line usage, so that the absence of a
+% change file implies no change file, rather than one with the
+% same name as the web file, with .ch at the end.
+% 1/15/83 (HT) Changed to work with version 1.2, which incorporates the
+% above change (though unbundling the output line breaking),
+% so mainly had to remove stuff.
+% 2/17 (HT) Fixed bug that caused 0-9 in identifiers to be converted to
+% Q-Y on output.
+% 3/18 (HT) Brought up to work with Version 1.5. Added -r command line
+% flag to cause a .rpl file to be written with all the lines
+% of the .web file that were replaced because of the .ch file
+% (useful for comparing with previous .rpl files, to see if a
+% change file will still work with a new version of a .web file)
+% Also, made it write a newline just before exit.
+% 4/12 (PC) Merged with Pavel's version, including adding a call to exit()
+% at the end depending upon the value of history.
+% 4/16 (PC) Brought up to date with version 1.5 released April, 1983.
+% 6/28 (HWT) Brought up to date with version 1.7 released June, 1983.
+% With new change file format, the -r option is now unnecessary.
+% 7/17 (HWT) Brought up to date with version 2.0 released July, 1983.
+% 12/18/83 (ETM) Brought up to date with version 2.5 released November, 1983.
+% 11/07/84 (ETM) Brought up to date with version 2.6.
+% 12/15/85 (ETM) Brought up to date with version 2.8.
+% 03/07/88 (ETM) Converted for use with WEB2C
+% 01/02/89 (PAM) Cosmetic upgrade to version 2.9
+% 11/30/89 (KB) Version 4.
+% (more recent changes in the ChangeLog)
+
+@x [0] Print only changes.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+\let\maybe=\iffalse
+\def\title{TANGLE changes for C}
+@z
+
+@x [?] Define and call parse_arguments.
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin @<Set initial values@>@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+ @<Set initial values@>@/
+@z
+
+@x [8] Constants: increase id lengths, for TeX--XeT and tex2pdf.
+@!buf_size=100; {maximum length of input line}
+@y
+@!buf_size=3000; {maximum length of input line}
+@z
+@x
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@y
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@z
+
+@x
+@!stack_size=50; {number of simultaneous levels of macro expansion}
+@!max_id_length=12; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=7; {identifiers must be unique if chopped to this length}
+ {note that 7 is more strict than \PASCAL's 8, but this can be varied}
+@y
+@!stack_size=100; {number of simultaneous levels of macro expansion}
+@!max_id_length=50; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=25; {identifiers must be unique if chopped to this length}
+@z
+
+% [??] The text_char type is used as an array index into xord. The
+% default type `char' produces signed integers, which are bad array
+% indices in C.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+@d text_char == char {the data type of characters in text files}
+@y
+@d text_char == ASCII_code {the data type of characters in text files}
+@z
+
+@x [17] enable maximum character set
+for i:=1 to @'37 do xchr[i]:=' ';
+for i:=@'200 to @'377 do xchr[i]:=' ';
+@y
+for i:=1 to @'37 do xchr[i]:=chr(i);
+for i:=@'200 to @'377 do xchr[i]:=chr(i);
+@z
+
+@x [20] terminal output: use standard i/o
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@y
+@d term_out==stdout
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@z
+
+@x
+@<Globals...@>=
+@!term_out:text_file; {the terminal as an output file}
+@y
+@z
+
+@x [21] init terminal
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal. Here is one way to do this
+on the \PASCAL\ system that was used in \.{TANGLE}'s initial development:
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(term_out,'TTY:'); {send |term_out| output to the terminal}
+@y
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal.
+@^system dependencies@>
+
+@<Set init...@>=
+ {Nothing need be done for C.}
+@z
+
+@x [22] flush terminal buffer
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+@y
+@d update_terminal == fflush(term_out) {empty the terminal output buffer}
+@z
+
+@x [24] open input files
+begin reset(web_file); reset(change_file);
+@y
+begin reset(web_file, web_name);
+if chg_name then reset(change_file, chg_name);
+@z
+
+@x [26] Open output files (except for the pool file).
+rewrite(Pascal_file); rewrite(pool);
+@y
+rewrite (Pascal_file, pascal_name);
+@z
+
+@x [28] Fix f^.
+ begin buffer[limit]:=xord[f^]; get(f);
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do get(f);
+@y
+ begin buffer[limit]:=xord[getc(f)];
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do vgetc(f);
+@z
+
+@x [??] Fix `jump_out'.
+@d fatal_error(#)==begin new_line; print(#); error; mark_fatal; jump_out;
+ end
+
+@<Error handling...@>=
+procedure jump_out;
+begin goto end_of_TANGLE;
+end;
+@y
+@d jump_out==uexit(1)
+@d fatal_error(#)==begin new_line; write(stderr, #);
+ error; mark_fatal; uexit(1);
+ end
+@z
+
+@x [38] Provide for a larger `byte_mem' and `tok_mem'. Extra capacity:
+@d ww=2 {we multiply the byte capacity by approximately this amount}
+@d zz=3 {we multiply the token capacity by approximately this amount}
+@y
+@d ww=3 {we multiply the byte capacity by approximately this amount}
+@d zz=4 {we multiply the token capacity by approximately this amount}
+@z
+
+@x [58] Remove conversion to uppercase
+ begin if buffer[i]>="a" then chopped_id[s]:=buffer[i]-@'40
+ else chopped_id[s]:=buffer[i];
+@y
+ begin chopped_id[s]:=buffer[i];
+@z
+
+@x [63] Remove conversion to uppercase
+ begin if c>="a" then c:=c-@'40; {merge lowercase with uppercase}
+@y
+ begin
+@z
+
+@x [64] Delayed pool file opening.
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+@y
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin
+ {Avoid creating empty pool files.}
+ if string_ptr = 65536 then begin
+ {Change |".web"| to |".pool"| and use the current directory.}
+ pool_name := basename_change_suffix (web_name, '.web', '.pool');
+ rewrite (pool, pool_name);
+ end;
+ equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+@z
+
+@x [105] Accept DIV, div, MOD, and mod
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) ))or@|
+@^uppercase@>
+@y
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="d")and(out_contrib[2]="i")and(out_contrib[3]="v")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) or@|
+ ((out_contrib[1]="m")and(out_contrib[2]="o")and(out_contrib[3]="d")) ))or@|
+@z
+
+@x [110] lowercase ids
+@^uppercase@>
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D")) then@/ goto bad_case
+@y
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="d")and(out_buf[out_ptr-2]="i")and
+ (out_buf[out_ptr-1]="v"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D"))or @/
+ ((out_buf[out_ptr-3]="m")and(out_buf[out_ptr-2]="o")and
+ (out_buf[out_ptr-1]="d")) then@/ goto bad_case
+@z
+
+@x [114] lowercase operators (`and', `or', etc.)
+and_sign: begin out_contrib[1]:="A"; out_contrib[2]:="N"; out_contrib[3]:="D";
+@^uppercase@>
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="N"; out_contrib[2]:="O"; out_contrib[3]:="T";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="I"; out_contrib[2]:="N";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="O"; out_contrib[2]:="R"; send_out(ident,2);
+@y
+and_sign: begin out_contrib[1]:="a"; out_contrib[2]:="n"; out_contrib[3]:="d";
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="n"; out_contrib[2]:="o"; out_contrib[3]:="t";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="i"; out_contrib[2]:="n";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="o"; out_contrib[2]:="r"; send_out(ident,2);
+@z
+
+@x [116] Remove conversion to uppercase
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to uppercase,
+with underlines removed. Extremely long identifiers must be chopped.
+
+(Some \PASCAL\ compilers work with lowercase letters instead of
+uppercase. If this module of \.{TANGLE} is changed, it's also necessary
+to change from uppercase to lowercase in the modules that are
+listed in the index under ``uppercase''.)
+@^system dependencies@>
+@^uppercase@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+"a",up_to("z"): begin out_contrib[1]:=cur_char-@'40; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if out_contrib[k]>="a" then out_contrib[k]:=out_contrib[k]-@'40
+ else if out_contrib[k]="_" then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+@y
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to lowercase,
+with underlines removed. Extremely long identifiers must be chopped.
+@^system dependencies@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"),
+"a",up_to("z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if out_contrib[k]="_" then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+@z
+
+@x [??] Fix casting bug
+@d add_in(#)==begin accumulator:=accumulator+next_sign*(#); next_sign:=+1;
+ end
+@y
+@d add_in(#)==begin accumulator:=accumulator+next_sign*intcast(#); next_sign:=+1;
+ end
+@z
+
+@x [179] make term_in = input
+any error stop will set |debug_cycle| to zero.
+@y
+any error stop will set |debug_cycle| to zero.
+
+@d term_in==stdin
+@z
+
+@x
+@!term_in:text_file; {the user's terminal as an input file}
+@y
+@z
+
+@x [180] remove term_in reset
+reset(term_in,'TTY:','/I'); {open |term_in| as the terminal, don't do a |get|}
+@y
+@z
+
+@x [182] write newline just before exit; use value of |history|
+print_ln(banner); {print a ``banner line''}
+@y
+print (banner); {print a ``banner line''}
+print_ln (version_string);
+@z
+
+@x
+@<Print the job |history|@>;
+@y
+@<Print the job |history|@>;
+new_line;
+if (history <> spotless) and (history <> harmless_message)
+then uexit (1)
+else uexit (0);
+@z
+
+@x [188] System-dependent changes.
+This module should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TANGLE} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous modules preserve the module numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new modules, can be inserted here; then only the index
+itself will get a new module number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 3; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('otangle');
+
+ end else if argument_is ('help') then begin
+ usage_help (OTANGLE_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc) then begin
+ write_ln (stderr, 'otangle: Need one or two file arguments.');
+ usage ('otangle');
+ end;
+
+ {Supply |".web"| and |".ch"| extensions if necessary.}
+ web_name := extend_filename (cmdline (optind), 'web');
+ if optind + 2 = argc then begin
+ chg_name := extend_filename (cmdline (optind + 1), 'ch');
+ end;
+
+ {Change |".web"| to |".p"| and use the current directory.}
+ pascal_name := basename_change_suffix (web_name, '.web', '.p');
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Globals...@>=
+@!web_name,@!chg_name,@!pascal_name,@!pool_name:c_string;
+@z
diff --git a/Build/source/texk/web2c/omegaware/otangle.web b/Build/source/texk/web2c/omegaware/otangle.web
new file mode 100644
index 00000000000..4bd5a028ee2
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/otangle.web
@@ -0,0 +1,3328 @@
+% otangle.web: Omega version of file tangle.web
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original tangle.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 0 was released in December, 1981.
+% Version 1 was released in September, 1982, with version 0 of TeX.
+% Slight changes were made in October, 1982, for version 0.6 of TeX.
+% Version 1.2 introduced {:nnn} comments, added @@= and @@\ (December, 1982).
+% Version 1.4 added "history" (February, 1983).
+% Version 1.5 conformed to TeX version 0.96 and fixed @@\ (March, 1983).
+% Version 1.7 introduced the new change file format (June, 1983).
+% Version 2.0 was released in July, 1983, with version 0.999 of TeX.
+% Version 2.5 was released in November, 1983, with version 1.0 of TeX.
+% Version 2.6 fixed a bug: force-line-break after a constant (August, 1984).
+% Version 2.7 fixed the definition of check_sum_prime (May, 1985).
+% Version 2.8 fixed a bug in change_buffer movement (August, 1985).
+% Version 2.9 allows nonnumeric macros before their def (December, 1988).
+% Version 3, for Sewell's book, fixed long-line bug in input_ln (March, 1989).
+% Version 4 was major change to allow 8-bit input (September, 1989).
+% Version 4.1 conforms to ANSI standard for-loop rules (September, 1990).
+% Version 4.2 fixes stat report if phase one dies (March, 1991).
+% Version 4.3 fixes @@ bug in verbatim, catches extra } (September, 1991).
+% Version 4.4 activates debug_help on errors as advertised (February, 1993).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\def\pb{$\.|\ldots\.|$} % Pascal brackets (|...|)
+\def\v{\.{\char'174}} % vertical (|) in typewriter font
+\mathchardef\BA="3224 % double arrow
+\def\({} % kludge for alphabetizing certain module names
+
+\def\title{OTANGLE}
+\def\contentspagenumber{123} % should be odd
+\def\topofcontents{\null\vfill
+ \titlefalse % include headline on the contents page
+ \def\rheader{\mainfont Appendix E\hfil \contentspagenumber}
+ \centerline{\titlefont The {\ttitlefont OTANGLE} processor}
+ \vskip 15pt
+ \centerline{(Version 4.4)}
+ \vfill}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+This program converts a \.{WEB} file to a \PASCAL\ file. It was written
+by D. E. Knuth in September, 1981; a somewhat similar {\mc SAIL} program had
+been developed in March, 1979. Since this program describes itself, a
+bootstrapping process involving hand-translation had to be used to get started.
+
+For large \.{WEB} files one should have a large memory, since \.{TANGLE} keeps
+all the \PASCAL\ text in memory (in an abbreviated form). The program uses
+a few features of the local \PASCAL\ compiler that may need to be changed in
+other installations:
+
+\yskip\item{1)} Case statements have a default.
+\item{2)} Input-output routines may need to be adapted for use with a particular
+character set and/or for printing messages on the user's terminal.
+
+\yskip\noindent
+These features are also present in the \PASCAL\ version of \TeX, where they
+are used in a similar (but more complex) way. System-dependent portions
+of \.{TANGLE} can be identified by looking at the entries for `system
+dependencies' in the index below.
+@!@^system dependencies@>
+
+The ``banner line'' defined here should be changed whenever \.{TANGLE}
+is modified.
+
+@d banner=='This is OTANGLE, Version 4.4'
+
+@ The program begins with a fairly normal header, made up of pieces that
+@^system dependencies@>
+will mostly be filled in later. The \.{WEB} input comes from files |web_file|
+and |change_file|, the \PASCAL\ output goes to file |Pascal_file|,
+and the string pool output goes to file |pool|.
+
+If it is necessary to abort the job because of a fatal error, the program
+calls the `|jump_out|' procedure, which goes to the label |end_of_TANGLE|.
+
+@d end_of_TANGLE = 9999 {go here to wrap it up}
+
+@p @t\4@>@<Compiler directives@>@/
+program OTANGLE(@!web_file,@!change_file,@!Pascal_file,@!pool);
+label end_of_TANGLE; {go here to finish}
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+@<Error handling procedures@>@/
+procedure initialize;
+ var @<Local variables for initialization@>@/
+ begin @<Set initial values@>@/
+ end;
+
+@ Some of this code is optional for use when debugging only;
+such material is enclosed between the delimiters |debug| and $|gubed|$.
+Other parts, delimited by |stat| and $|tats|$, are optionally included if
+statistics about \.{TANGLE}'s memory usage are desired.
+
+@d debug==@{ {change this to `$\\{debug}\equiv\null$' when debugging}
+@d gubed==@t@>@} {change this to `$\\{gubed}\equiv\null$' when debugging}
+@f debug==begin
+@f gubed==end
+@#
+@d stat==@{ {change this to `$\\{stat}\equiv\null$'
+ when gathering usage statistics}
+@d tats==@t@>@} {change this to `$\\{tats}\equiv\null$'
+ when gathering usage statistics}
+@f stat==begin
+@f tats==end
+
+@ The \PASCAL\ compiler used to develop this system has ``compiler
+directives'' that can appear in comments whose first character is a dollar sign.
+In production versions of \.{TANGLE} these directives tell the compiler that
+@^system dependencies@>
+it is safe to avoid range checks and to leave out the extra code it inserts
+for the \PASCAL\ debugger's benefit, although interrupts will occur if
+there is arithmetic overflow.
+
+@<Compiler directives@>=
+@{@&$C-,A+,D-@} {no range check, catch arithmetic overflow, no debug overhead}
+@!debug @{@&$C+,D+@}@+ gubed {but turn everything on when debugging}
+
+@ Labels are given symbolic names by the following definitions. We insert
+the label `|exit|:' just before the `\ignorespaces|end|\unskip' of a
+procedure in which we have used the `|return|' statement defined below;
+the label `|restart|' is occasionally used at the very beginning of a
+procedure; and the label `|reswitch|' is occasionally used just prior to
+a \&{case} statement in which some cases change the conditions and we wish to
+branch to the newly applicable case.
+Loops that are set up with the \&{loop} construction defined below are
+commonly exited by going to `|done|' or to `|found|' or to `|not_found|',
+and they are sometimes repeated by going to `|continue|'.
+
+@d exit=10 {go here to leave a procedure}
+@d restart=20 {go here to start a procedure again}
+@d reswitch=21 {go here to start a case statement again}
+@d continue=22 {go here to resume a loop}
+@d done=30 {go here to exit a loop}
+@d found=31 {go here when you've found it}
+@d not_found=32 {go here when you've found something else}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
+@d do_nothing == {empty statement}
+@d return == goto exit {terminate a procedure call}
+@f return == nil
+@f loop == xclause
+
+@ We assume that |case| statements may include a default case that applies
+if no matching label is found. Thus, we shall use constructions like
+@^system dependencies@>
+$$\vbox{\halign{#\hfil\cr
+|case x of|\cr
+1: $\langle\,$code for $x=1\,\rangle$;\cr
+3: $\langle\,$code for $x=3\,\rangle$;\cr
+|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
+|endcases|\cr}}$$
+since most \PASCAL\ compilers have plugged this hole in the language by
+incorporating some sort of default mechanism. For example, the compiler
+used to develop \.{WEB} and \TeX\ allows `|others|:' as a default label,
+and other \PASCAL s allow syntaxes like `\ignorespaces|else|\unskip' or
+`\&{otherwise}' or `\\{otherwise}:', etc. The definitions of |othercases|
+and |endcases| should be changed to agree with local conventions. (Of
+course, if no default mechanism is available, the |case| statements of
+this program must be extended by listing all remaining cases. The author
+would have taken the trouble to modify \.{TANGLE} so that such extensions
+were done automatically, if he had not wanted to encourage \PASCAL\
+compiler writers to make this important change in \PASCAL, where it belongs.)
+
+@d othercases == others: {default for cases not listed explicitly}
+@d endcases == @+end {follows the default case in an extended |case| statement}
+@f othercases == else
+@f endcases == end
+
+@ The following parameters are set big enough to handle \TeX, so they
+should be sufficient for most applications of \.{TANGLE}.
+
+@<Constants...@>=
+@!buf_size=100; {maximum length of input line}
+@!max_bytes=65535; {|1/ww| times the number of bytes in identifiers,
+ strings, and module names; must be less than 65536}
+@!max_toks=65535; {|1/zz| times the number of bytes in compressed \PASCAL\ code;
+ must be less than 65536}
+@!max_names=10239; {number of identifiers, strings, module names;
+ must be less than 10240}
+@!max_texts=10239; {number of replacement texts, must be less than 10240}
+@!hash_size=353; {should be prime}
+@!longest_name=400; {module names shouldn't be longer than this}
+@!line_length=72; {lines of \PASCAL\ output have at most this many characters}
+@!out_buf_size=144; {length of output buffer, should be twice |line_length|}
+@!stack_size=50; {number of simultaneous levels of macro expansion}
+@!max_id_length=12; {long identifiers are chopped to this length, which must
+ not exceed |line_length|}
+@!unambig_length=7; {identifiers must be unique if chopped to this length}
+ {note that 7 is more strict than \PASCAL's 8, but this can be varied}
+
+@ A global variable called |history| will contain one of four values
+at the end of every run: |spotless| means that no unusual messages were
+printed; |harmless_message| means that a message of possible interest
+was printed but no serious errors were detected; |error_message| means that
+at least one error was found; |fatal_message| means that the program
+terminated abnormally. The value of |history| does not influence the
+behavior of the program; it is simply computed for the convenience
+of systems that might want to use such information.
+
+@d spotless=0 {|history| value for normal jobs}
+@d harmless_message=1 {|history| value when non-serious info was printed}
+@d error_message=2 {|history| value when an error was noted}
+@d fatal_message=3 {|history| value when we had to stop prematurely}
+@#
+@d mark_harmless==@t@>@+if history=spotless then history:=harmless_message
+@d mark_error==history:=error_message
+@d mark_fatal==history:=fatal_message
+@d biggest_char=65535
+@d number_chars=65536
+
+@<Glob...@>=@!history:spotless..fatal_message; {how bad was this run?}
+
+@ @<Set init...@>=history:=spotless;
+
+@* The character set.
+One of the main goals in the design of \.{WEB} has been to make it readily
+portable between a wide variety of computers. Yet \.{WEB} by its very
+nature must use a greater variety of characters than most computer
+programs deal with, and character encoding is one of the areas in which
+existing machines differ most widely from each other.
+
+To resolve this problem, all input to \.{WEAVE} and \.{TANGLE} is converted
+to an internal eight-bit code that is essentially standard ASCII, the ``American
+Standard Code for Information Interchange.'' The conversion is done
+immediately when each character is read in. Conversely, characters are
+converted from ASCII to the user's external representation just before
+they are output. (The original ASCII code was seven bits only; \.{WEB} now
+allows eight bits in an attempt to keep up with modern times.)
+
+Such an internal code is relevant to users of \.{WEB} only because it is
+the code used for preprocessed constants like \.{"A"}. If you are writing
+a program in \.{WEB} that makes use of such one-character constants, you
+should convert your input to ASCII form, like \.{WEAVE} and \.{TANGLE} do.
+Otherwise \.{WEB}'s internal coding scheme does not affect you.
+@^ASCII code@>
+
+Here is a table of the standard visible ASCII codes:
+$$\def\:{\char\count255\global\advance\count255 by 1}
+\count255='40
+\vbox{
+\hbox{\hbox to 40pt{\it\hfill0\/\hfill}%
+\hbox to 40pt{\it\hfill1\/\hfill}%
+\hbox to 40pt{\it\hfill2\/\hfill}%
+\hbox to 40pt{\it\hfill3\/\hfill}%
+\hbox to 40pt{\it\hfill4\/\hfill}%
+\hbox to 40pt{\it\hfill5\/\hfill}%
+\hbox to 40pt{\it\hfill6\/\hfill}%
+\hbox to 40pt{\it\hfill7\/\hfill}}
+\vskip 4pt
+\hrule
+\def\^{\vrule height 10.5pt depth 4.5pt}
+\halign{\hbox to 0pt{\hskip -24pt\O{#0}\hfill}&\^
+\hbox to 40pt{\tt\hfill#\hfill\^}&
+&\hbox to 40pt{\tt\hfill#\hfill\^}\cr
+04&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+05&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+06&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+07&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+10&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+11&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+12&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+13&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+14&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+15&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+16&\:&\:&\:&\:&\:&\:&\:&\:\cr\noalign{\hrule}
+17&\:&\:&\:&\:&\:&\:&\:\cr}
+\hrule width 280pt}$$
+(Actually, of course, code @'040 is an invisible blank space.) Code @'136
+was once an upward arrow (\.{\char'13}), and code @'137 was
+once a left arrow (\.^^X), in olden times when the first draft
+of ASCII code was prepared; but \.{WEB} works with today's standard
+ASCII in which those codes represent circumflex and underline as shown.
+
+@<Types...@>=
+@!ASCII_code=0..255; {eight-bit numbers, a subrange of the integers}
+
+@ The original \PASCAL\ compiler was designed in the late 60s, when six-bit
+character sets were common, so it did not make provision for lowercase
+letters. Nowadays, of course, we need to deal with both capital and small
+letters in a convenient way, so \.{WEB} assumes that it is being used
+with a \PASCAL\ whose character set contains at least the characters of
+standard ASCII as listed above. Some \PASCAL\ compilers use the original
+name |char| for the data type associated with the characters in text files,
+while other \PASCAL s consider |char| to be a 64-element subrange of a larger
+data type that has some other name.
+
+In order to accommodate this difference, we shall use the name |text_char|
+to stand for the data type of the characters in the input and output
+files. We shall also assume that |text_char| consists of the elements
+|chr(first_text_char)| through |chr(last_text_char)|, inclusive. The
+following definitions should be adjusted if necessary.
+@^system dependencies@>
+
+@d text_char == char {the data type of characters in text files}
+@d first_text_char=0 {ordinal number of the smallest element of |text_char|}
+@d last_text_char=255 {ordinal number of the largest element of |text_char|}
+
+@<Types...@>=
+@!text_file=packed file of text_char;
+
+@ The \.{WEAVE} and \.{TANGLE} processors convert between ASCII code and
+the user's external character set by means of arrays |xord| and |xchr|
+that are analogous to \PASCAL's |ord| and |chr| functions.
+
+@<Globals...@>=
+@!xord: array [text_char] of ASCII_code;
+ {specifies conversion of input characters}
+@!xchr: array [ASCII_code] of text_char;
+ {specifies conversion of output characters}
+
+@ If we assume that every system using \.{WEB} is able to read and write the
+visible characters of standard ASCII (although not necessarily using the
+ASCII codes to represent them), the following assignment statements initialize
+most of the |xchr| array properly, without needing any system-dependent
+changes. For example, the statement \.{xchr[@@\'101]:=\'A\'} that appears
+in the present \.{WEB} file might be encoded in, say, {\mc EBCDIC} code
+on the external medium on which it resides, but \.{TANGLE} will convert from
+this external code to ASCII and back again. Therefore the assignment
+statement \.{XCHR[65]:=\'A\'} will appear in the corresponding \PASCAL\ file,
+and \PASCAL\ will compile this statement so that |xchr[65]| receives the
+character \.A in the external (|char|) code. Note that it would be quite
+incorrect to say \.{xchr[@@\'101]:="A"}, because |"A"| is a constant of
+type |integer|, not |char|, and because we have $|"A"|=65$ regardless of
+the external character set.
+
+@<Set init...@>=
+xchr[@'40]:=' ';
+xchr[@'41]:='!';
+xchr[@'42]:='"';
+xchr[@'43]:='#';
+xchr[@'44]:='$';
+xchr[@'45]:='%';
+xchr[@'46]:='&';
+xchr[@'47]:='''';@/
+xchr[@'50]:='(';
+xchr[@'51]:=')';
+xchr[@'52]:='*';
+xchr[@'53]:='+';
+xchr[@'54]:=',';
+xchr[@'55]:='-';
+xchr[@'56]:='.';
+xchr[@'57]:='/';@/
+xchr[@'60]:='0';
+xchr[@'61]:='1';
+xchr[@'62]:='2';
+xchr[@'63]:='3';
+xchr[@'64]:='4';
+xchr[@'65]:='5';
+xchr[@'66]:='6';
+xchr[@'67]:='7';@/
+xchr[@'70]:='8';
+xchr[@'71]:='9';
+xchr[@'72]:=':';
+xchr[@'73]:=';';
+xchr[@'74]:='<';
+xchr[@'75]:='=';
+xchr[@'76]:='>';
+xchr[@'77]:='?';@/
+xchr[@'100]:='@@';
+xchr[@'101]:='A';
+xchr[@'102]:='B';
+xchr[@'103]:='C';
+xchr[@'104]:='D';
+xchr[@'105]:='E';
+xchr[@'106]:='F';
+xchr[@'107]:='G';@/
+xchr[@'110]:='H';
+xchr[@'111]:='I';
+xchr[@'112]:='J';
+xchr[@'113]:='K';
+xchr[@'114]:='L';
+xchr[@'115]:='M';
+xchr[@'116]:='N';
+xchr[@'117]:='O';@/
+xchr[@'120]:='P';
+xchr[@'121]:='Q';
+xchr[@'122]:='R';
+xchr[@'123]:='S';
+xchr[@'124]:='T';
+xchr[@'125]:='U';
+xchr[@'126]:='V';
+xchr[@'127]:='W';@/
+xchr[@'130]:='X';
+xchr[@'131]:='Y';
+xchr[@'132]:='Z';
+xchr[@'133]:='[';
+xchr[@'134]:='\';
+xchr[@'135]:=']';
+xchr[@'136]:='^';
+xchr[@'137]:='_';@/
+xchr[@'140]:='`';
+xchr[@'141]:='a';
+xchr[@'142]:='b';
+xchr[@'143]:='c';
+xchr[@'144]:='d';
+xchr[@'145]:='e';
+xchr[@'146]:='f';
+xchr[@'147]:='g';@/
+xchr[@'150]:='h';
+xchr[@'151]:='i';
+xchr[@'152]:='j';
+xchr[@'153]:='k';
+xchr[@'154]:='l';
+xchr[@'155]:='m';
+xchr[@'156]:='n';
+xchr[@'157]:='o';@/
+xchr[@'160]:='p';
+xchr[@'161]:='q';
+xchr[@'162]:='r';
+xchr[@'163]:='s';
+xchr[@'164]:='t';
+xchr[@'165]:='u';
+xchr[@'166]:='v';
+xchr[@'167]:='w';@/
+xchr[@'170]:='x';
+xchr[@'171]:='y';
+xchr[@'172]:='z';
+xchr[@'173]:='{';
+xchr[@'174]:='|';
+xchr[@'175]:='}';
+xchr[@'176]:='~';@/
+xchr[0]:=' '; xchr[@'177]:=' '; {these ASCII codes are not used}
+
+@ Some of the ASCII codes below @'40 have been given symbolic names in
+\.{WEAVE} and \.{TANGLE} because they are used with a special meaning.
+
+@d and_sign=@'4 {equivalent to `\.{and}'}
+@d not_sign=@'5 {equivalent to `\.{not}'}
+@d set_element_sign=@'6 {equivalent to `\.{in}'}
+@d tab_mark=@'11 {ASCII code used as tab-skip}
+@d line_feed=@'12 {ASCII code thrown away at end of line}
+@d form_feed=@'14 {ASCII code used at end of page}
+@d carriage_return=@'15 {ASCII code used at end of line}
+@d left_arrow=@'30 {equivalent to `\.{:=}'}
+@d not_equal=@'32 {equivalent to `\.{<>}'}
+@d less_or_equal=@'34 {equivalent to `\.{<=}'}
+@d greater_or_equal=@'35 {equivalent to `\.{>=}'}
+@d equivalence_sign=@'36 {equivalent to `\.{==}'}
+@d or_sign=@'37 {equivalent to `\.{or}'}
+
+@ When we initialize the |xord| array and the remaining parts of |xchr|,
+it will be convenient to make use of an index variable, |i|.
+
+@<Local variables for init...@>=
+@!i:0..255;
+
+@ Here now is the system-dependent part of the character set.
+If \.{WEB} is being implemented on a garden-variety \PASCAL\ for which
+only standard ASCII codes will appear in the input and output files, you
+don't need to make any changes here. But if you have, for example, an extended
+character set like the one in Appendix~C of {\sl The \TeX book}, the first
+line of code in this module should be changed to
+$$\hbox{|for i:=1 to @'37 do xchr[i]:=chr(i);|}$$
+\.{WEB}'s character set is essentially identical to \TeX's, even with respect to
+characters less than @'40.
+@^system dependencies@>
+
+Changes to the present module will make \.{WEB} more friendly on computers
+that have an extended character set, so that one can type things like
+\.^^Z\ instead of \.{<>}. If you have an extended set of characters that
+are easily incorporated into text files, you can assign codes arbitrarily
+here, giving an |xchr| equivalent to whatever characters the users of
+\.{WEB} are allowed to have in their input files, provided that unsuitable
+characters do not correspond to special codes like |carriage_return|
+that are listed above.
+
+(The present file \.{TANGLE.WEB} does not contain any of the non-ASCII
+characters, because it is intended to be used with all implementations of
+\.{WEB}. It was originally created on a Stanford system that has a
+convenient extended character set, then ``sanitized'' by applying another
+program that transliterated all of the non-standard characters into
+standard equivalents.)
+
+@<Set init...@>=
+for i:=1 to @'37 do xchr[i]:=' ';
+for i:=@'200 to @'377 do xchr[i]:=' ';
+
+@ The following system-independent code makes the |xord| array contain a
+suitable inverse to the information in |xchr|.
+
+@<Set init...@>=
+for i:=first_text_char to last_text_char do xord[chr(i)]:=" ";
+for i:=1 to @'377 do xord[xchr[i]]:=i;
+xord[' ']:=" ";
+
+@* Input and output.
+The input conventions of this program are intended to be very much like those
+of \TeX\ (except, of course, that they are much simpler, because much less
+needs to be done). Furthermore they are identical to those of \.{WEAVE}.
+Therefore people who need to make modifications to all three systems
+should be able to do so without too many headaches.
+
+We use the standard \PASCAL\ input/output procedures in several places that
+\TeX\ cannot, since \.{TANGLE} does not have to deal with files that are named
+dynamically by the user, and since there is no input from the terminal.
+
+@ Terminal output is done by writing on file |term_out|, which is assumed to
+consist of characters of type |text_char|:
+@^system dependencies@>
+
+@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
+@d print_ln(#)==write_ln(term_out,#) {`|print|' and then start new line}
+@d new_line==write_ln(term_out) {start new line}
+@d print_nl(#)== {print information starting on a new line}
+ begin new_line; print(#);
+ end
+
+@<Globals...@>=
+@!term_out:text_file; {the terminal as an output file}
+
+@ Different systems have different ways of specifying that the output on a
+certain file will appear on the user's terminal. Here is one way to do this
+on the \PASCAL\ system that was used in \.{TANGLE}'s initial development:
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(term_out,'TTY:'); {send |term_out| output to the terminal}
+
+@ The |update_terminal| procedure is called when we want
+to make sure that everything we have output to the terminal so far has
+actually left the computer's internal buffers and been sent.
+@^system dependencies@>
+
+@d update_terminal == break(term_out) {empty the terminal output buffer}
+
+@ The main input comes from |web_file|; this input may be overridden
+by changes in |change_file|. (If |change_file| is empty, there are no changes.)
+
+@<Globals...@>=
+@!web_file:text_file; {primary input}
+@!change_file:text_file; {updates}
+
+@ The following code opens the input files. Since these files were listed
+in the program header, we assume that the \PASCAL\ runtime system has
+already checked that suitable file names have been given; therefore no
+additional error checking needs to be done.
+@^system dependencies@>
+
+@p procedure open_input; {prepare to read |web_file| and |change_file|}
+begin reset(web_file); reset(change_file);
+end;
+
+@ The main output goes to |Pascal_file|, and string pool constants are
+written to the |pool| file.
+
+@<Globals...@>=
+@!Pascal_file: text_file;
+@!pool: text_file;
+
+@ The following code opens |Pascal_file| and |pool|.
+Since these files were listed in the program header, we assume that the
+\PASCAL\ runtime system has checked that suitable external file names have
+been given.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(Pascal_file); rewrite(pool);
+
+@ Input goes into an array called |buffer|.
+
+@<Globals...@>=@!buffer: array[0..buf_size] of ASCII_code;
+
+@ The |input_ln| procedure brings the next line of input from the specified
+file into the |buffer| array and returns the value |true|, unless the file has
+already been entirely read, in which case it returns |false|. The conventions
+of \TeX\ are followed; i.e., |ASCII_code| numbers representing the next line
+of the file are input into |buffer[0]|, |buffer[1]|, \dots,
+|buffer[limit-1]|; trailing blanks are ignored;
+and the global variable |limit| is set to the length of the
+@^system dependencies@>
+line. The value of |limit| must be strictly less than |buf_size|.
+
+We assume that none of the |ASCII_code| values
+of |buffer[j]| for |0<=j<limit| is equal to 0, @'177, |line_feed|, |form_feed|,
+or |carriage_return|.
+
+@p function input_ln(var f:text_file):boolean;
+ {inputs a line or returns |false|}
+var final_limit:0..buf_size; {|limit| without trailing blanks}
+begin limit:=0; final_limit:=0;
+if eof(f) then input_ln:=false
+else begin while not eoln(f) do
+ begin buffer[limit]:=xord[f^]; get(f);
+ incr(limit);
+ if buffer[limit-1]<>" " then final_limit:=limit;
+ if limit=buf_size then
+ begin while not eoln(f) do get(f);
+ decr(limit); {keep |buffer[buf_size]| empty}
+ if final_limit>limit then final_limit:=limit;
+ print_nl('! Input line too long'); loc:=0; error;
+@.Input line too long@>
+ end;
+ end;
+ read_ln(f); limit:=final_limit; input_ln:=true;
+ end;
+end;
+
+@* Reporting errors to the user.
+The \.{TANGLE} processor operates in two phases: first it inputs the source
+file and stores a compressed representation of the program, then it produces
+the \PASCAL\ output from the compressed representation.
+
+The global variable |phase_one| tells whether we are in Phase I or not.
+
+@<Globals...@>=
+@!phase_one: boolean; {|true| in Phase I, |false| in Phase II}
+
+@ If an error is detected while we are debugging,
+we usually want to look at the contents of memory.
+A special procedure will be declared later for this purpose.
+
+@<Error handling...@>=
+@!debug @+ procedure debug_help; forward;@+ gubed
+
+@ During the first phase, syntax errors are reported to the user by saying
+$$\hbox{`|err_print('! Error message')|'},$$
+followed by `|jump_out|' if no recovery from the error is provided.
+This will print the error message followed by an indication of where the error
+was spotted in the source file. Note that no period follows the error message,
+since the error routine will automatically supply a period.
+
+Errors that are noticed during the second phase are reported to the user
+in the same fashion, but the error message will be
+followed by an indication of where the error was spotted in the output file.
+
+The actual error indications are provided by a procedure called |error|.
+
+@d err_print(#)==begin new_line; print(#); error;
+ end
+
+@<Error handling...@>=
+procedure error; {prints '\..' and location of error message}
+var j: 0..out_buf_size; {index into |out_buf|}
+@!k,@!l: 0..buf_size; {indices into |buffer|}
+begin if phase_one then @<Print error location based on input buffer@>
+else @<Print error location based on output buffer@>;
+update_terminal; mark_error;
+@!debug debug_skipped:=debug_cycle; debug_help;@+gubed
+end;
+
+@ The error locations during Phase I can be indicated by using the global
+variables |loc|, |line|, and |changing|, which tell respectively the first
+unlooked-at position in |buffer|, the current line number, and whether or not
+the current line is from |change_file| or |web_file|.
+This routine should be modified on systems whose standard text editor
+has special line-numbering conventions.
+@^system dependencies@>
+
+@<Print error location based on input buffer@>=
+begin if changing then print('. (change file ')@+else print('. (');
+print_ln('l.', line:1, ')');
+if loc>=limit then l:=limit else l:=loc;
+for k:=1 to l do
+ if buffer[k-1]=tab_mark then print(' ')
+ else print(xchr[buffer[k-1]]); {print the characters already read}
+new_line;
+for k:=1 to l do print(' '); {space out the next line}
+for k:=l+1 to limit do print(xchr[buffer[k-1]]); {print the part not yet read}
+print(' '); {this space separates the message from future asterisks}
+end
+
+@ The position of errors detected during the second phase can be indicated
+by outputting the partially-filled output buffer, which contains |out_ptr|
+entries.
+
+@<Print error location based on output...@>=
+begin print_ln('. (l.',line:1,')');
+for j:=1 to out_ptr do print(xchr[out_buf[j-1]]); {print current partial line}
+print('... '); {indicate that this information is partial}
+end
+
+@ The |jump_out| procedure just cuts across all active procedure levels
+and jumps out of the program. This is the only non-local |goto| statement
+in \.{TANGLE}. It is used when no recovery from a particular error has
+been provided.
+
+Some \PASCAL\ compilers do not implement non-local |goto| statements.
+@^system dependencies@>
+In such cases the code that appears at label |end_of_TANGLE| should be
+copied into the |jump_out| procedure, followed by a call to a system procedure
+that terminates the program.
+
+@d fatal_error(#)==begin new_line; print(#); error; mark_fatal; jump_out;
+ end
+
+@<Error handling...@>=
+procedure jump_out;
+begin goto end_of_TANGLE;
+end;
+
+@ Sometimes the program's behavior is far different from what it should be,
+and \.{TANGLE} prints an error message that is really for the \.{TANGLE}
+maintenance person, not the user. In such cases the program says
+|confusion('indication of where we are')|.
+
+@d confusion(#)==fatal_error('! This can''t happen (',#,')')
+@.This can't happen@>
+
+@ An overflow stop occurs if \.{TANGLE}'s tables aren't large enough.
+
+@d overflow(#)==fatal_error('! Sorry, ',#,' capacity exceeded')
+@.Sorry, x capacity exceeded@>
+
+
+@* Data structures.
+Most of the user's \PASCAL\ code is packed into eight-bit integers
+in two large arrays called |byte_mem| and |tok_mem|.
+The |byte_mem| array holds the names of identifiers, strings, and modules;
+the |tok_mem| array holds the replacement texts
+for macros and modules. Allocation is sequential, since things are deleted only
+during Phase II, and only in a last-in-first-out manner.
+
+Auxiliary arrays |byte_start| and |tok_start| are used as directories to
+|byte_mem| and |tok_mem|, and the |link|, |ilk|, |equiv|, and |text_link|
+arrays give further information about names. These auxiliary arrays
+consist of sixteen-bit items.
+
+@<Types...@>=
+@!eight_bits=0..255; {unsigned one-byte quantity}
+@!sixteen_bits=integer; {not quite a two-byte quantity}
+
+@ \.{TANGLE} has been designed to avoid the need for indices that are more
+than sixteen bits wide, so that it can be used on most computers. But
+there are programs that need more than 65536 tokens, and some programs
+even need more than 65536 bytes; \TeX\ is one of these. To get around
+this problem, a slight complication has been added to the data structures:
+|byte_mem| and |tok_mem| are two-dimensional arrays, whose first index is
+either 0 or 1. (For generality, the first index is actually allowed to run
+between 0 and |ww-1| in |byte_mem|, or between 0 and |zz-1| in |tok_mem|,
+where |ww| and |zz| are set to 2 and~3; the program will work for any
+positive values of |ww| and |zz|, and it can be simplified in obvious ways
+if |ww=1| or |zz=1|.)
+
+@d ww=2 {we multiply the byte capacity by approximately this amount}
+@d zz=3 {we multiply the token capacity by approximately this amount}
+
+@<Globals...@>=
+@!byte_mem: packed array [0..ww-1,0..max_bytes] of ASCII_code;
+ {characters of names}
+@!tok_mem: packed array [0..zz-1,0..max_toks] of eight_bits; {tokens}
+@!byte_start: array [0..max_names] of sixteen_bits; {directory into |byte_mem|}
+@!tok_start: array [0..max_texts] of sixteen_bits; {directory into |tok_mem|}
+@!link: array [0..max_names] of sixteen_bits; {hash table or tree links}
+@!ilk: array [0..max_names] of sixteen_bits; {type codes or tree links}
+@!equiv: array [0..max_names] of sixteen_bits; {info corresponding to names}
+@!text_link: array [0..max_texts] of sixteen_bits; {relates replacement texts}
+
+@ The names of identifiers are found by computing a hash address |h| and
+then looking at strings of bytes signified by |hash[h]|, |link[hash[h]]|,
+|link[link[hash[h]]]|, \dots, until either finding the desired name
+or encountering a zero.
+
+A `|name_pointer|' variable, which signifies a name, is an index into
+|byte_start|. The actual sequence of characters in the name pointed to by
+|p| appears in positions |byte_start[p]| to |byte_start[p+ww]-1|, inclusive,
+in the segment of |byte_mem| whose first index is |p mod ww|. Thus, when
+|ww=2| the even-numbered name bytes appear in |byte_mem[0,@t$*$@>]|
+and the odd-numbered ones appear in |byte_mem[1,@t$*$@>]|.
+The pointer 0 is used for undefined module names; we don't
+want to use it for the names of identifiers, since 0 stands for a null
+pointer in a linked list.
+
+Strings are treated like identifiers; the first character (a double-quote)
+distinguishes a string from an alphabetic name, but for \.{TANGLE}'s purposes
+strings behave like numeric macros. (A `string' here refers to the
+strings delimited by double-quotes that \.{TANGLE} processes. \PASCAL\
+string constants delimited by single-quote marks are not given such special
+treatment; they simply appear as sequences of characters in the \PASCAL\
+texts.) The total number of strings in the string
+pool is called |string_ptr|, and the total number of names in |byte_mem|
+is called |name_ptr|. The total number of bytes occupied in
+|byte_mem[w,@t$*$@>]| is called |byte_ptr[w]|.
+
+We usually have |byte_start[name_ptr+w]=byte_ptr[(name_ptr+w) mod ww]|
+for |0<=w<ww|, since these are the starting positions for the next |ww|
+names to be stored in |byte_mem|.
+
+@d length(#)==byte_start[#+ww]-byte_start[#] {the length of a name}
+
+@<Types...@>=
+@!name_pointer=0..max_names; {identifies a name}
+
+@ @<Global...@>=
+@!name_ptr:name_pointer; {first unused position in |byte_start|}
+@!string_ptr:name_pointer; {next number to be given to a string of length |<>1|}
+@!byte_ptr:array [0..ww-1] of 0..max_bytes;
+ {first unused position in |byte_mem|}
+@!pool_check_sum:integer; {sort of a hash for the whole string pool}
+
+@ @<Local variables for init...@>=
+@!wi: 0..ww-1; {to initialize the |byte_mem| indices}
+
+@ @<Set init...@>=
+for wi:=0 to ww-1 do
+ begin byte_start[wi]:=0; byte_ptr[wi]:=0;
+ end;
+byte_start[ww]:=0; {this makes name 0 of length zero}
+name_ptr:=1; string_ptr:=number_chars; pool_check_sum:=271828;
+
+@ Replacement texts are stored in |tok_mem|, using similar conventions.
+A `|text_pointer|' variable is an index into |tok_start|, and the
+replacement text that corresponds to |p| runs from positions
+|tok_start[p]| to |tok_start[p+zz]-1|, inclusive, in the segment of
+|tok_mem| whose first index is |p mod zz|. Thus, when |zz=2| the
+even-numbered replacement texts appear in |tok_mem[0,@t$*$@>]| and the
+odd-numbered ones appear in |tok_mem[1,@t$*$@>]|. Furthermore,
+|text_link[p]| is used to connect pieces of text that have the same name,
+as we shall see later. The pointer 0 is used for undefined replacement
+texts.
+
+The first position of |tok_mem[z,@t$*$@>]| that is unoccupied by
+replacement text is called |tok_ptr[z]|, and the first unused location of
+|tok_start| is called |text_ptr|. We usually have the identity
+|tok_start[text_ptr+z]=tok_ptr[(text_ptr+z) mod zz]|, for |0<=z<zz|, since
+these are the starting positions for the next |zz| replacement texts to
+be stored in |tok_mem|.
+
+@<Types...@>=
+@!text_pointer=0..max_texts; {identifies a replacement text}
+
+@ It is convenient to maintain a variable |z| that is equal to |text_ptr
+mod zz|, so that we always insert tokens into segment |z| of |tok_mem|.
+
+@<Glob...@>=
+@t\hskip1em@>@!text_ptr:text_pointer; {first unused position in |tok_start|}
+@t\hskip1em@>@!tok_ptr:array[0..zz-1] of 0..max_toks;
+ {first unused position in a given segment of |tok_mem|}
+@t\hskip1em@>@!z:0..zz-1; {current segment of |tok_mem|}
+stat @!max_tok_ptr:array[0..zz-1] of 0..max_toks;
+ {largest values assumed by |tok_ptr|}
+tats
+
+@ @<Local variables for init...@>=
+@!zi:0..zz-1; {to initialize the |tok_mem| indices}
+
+@ @<Set init...@>=
+for zi:=0 to zz-1 do
+ begin tok_start[zi]:=0; tok_ptr[zi]:=0;
+ end;
+tok_start[zz]:=0; {this makes replacement text 0 of length zero}
+text_ptr:=1; z:=1 mod zz;
+
+@ Four types of identifiers are distinguished by their |ilk|:
+
+\yskip\hang |normal| identifiers will appear in the \PASCAL\ program as
+ordinary identifiers since they have not been defined to be macros; the
+corresponding value in the |equiv| array
+for such identifiers is a link in a secondary hash table that
+is used to check whether any two of them agree in their first |unambig_length|
+characters after underline symbols are removed and lowercase letters are
+changed to uppercase.
+
+\yskip\hang |numeric| identifiers have been defined to be numeric macros;
+their |equiv| value contains the corresponding numeric value plus $2^{15}$.
+Strings are treated as numeric macros.
+
+\yskip\hang |simple| identifiers have been defined to be simple macros;
+their |equiv| value points to the corresponding replacement text.
+
+\yskip\hang |parametric| identifiers have been defined to be parametric macros;
+like simple identifiers, their |equiv| value points to the replacement text.
+
+@d normal=0 {ordinary identifiers have |normal| ilk}
+@d numeric=1 {numeric macros and strings have |numeric| ilk}
+@d simple=2 {simple macros have |simple| ilk}
+@d parametric=3 {parametric macros have |parametric| ilk}
+
+@ The names of modules are stored in |byte_mem| together
+with the identifier names, but a hash table is not used for them because
+\.{TANGLE} needs to be able to recognize a module name when given a prefix of
+that name. A conventional binary seach tree is used to retrieve module names,
+with fields called |llink| and |rlink| in place of |link| and |ilk|. The
+root of this tree is |rlink[0]|. If |p| is a pointer to a module name,
+|equiv[p]| points to its replacement text, just as in simple and parametric
+macros, unless this replacement text has not yet been defined (in which case
+|equiv[p]=0|).
+
+@d llink==link {left link in binary search tree for module names}
+@d rlink==ilk {right link in binary search tree for module names}
+
+@<Set init...@>=
+rlink[0]:=0; {the binary search tree starts out with nothing in it}
+equiv[0]:=0; {the undefined module has no replacement text}
+
+@ Here is a little procedure that prints the text of a given name.
+
+@p procedure print_id(@!p:name_pointer); {print identifier or module name}
+var k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+begin if p>=name_ptr then print('IMPOSSIBLE')
+else begin w:=p mod ww;
+ for k:=byte_start[p] to byte_start[p+ww]-1 do print(xchr[byte_mem[w,k]]);
+ end;
+end;
+
+@* Searching for identifiers.
+The hash table described above is updated by the |id_lookup| procedure,
+which finds a given identifier and returns a pointer to its index in
+|byte_start|. If the identifier was not already present, it is inserted with
+a given |ilk| code; and an error message is printed if the identifier is being
+doubly defined.
+
+Because of the way \.{TANGLE}'s scanning mechanism works, it is most convenient
+to let |id_lookup| search for an identifier that is present in the |buffer|
+array. Two other global variables specify its position in the buffer: the
+first character is |buffer[id_first]|, and the last is |buffer[id_loc-1]|.
+Furthermore, if the identifier is really a string, the global variable
+|double_chars| tells how many of the characters in the buffer appear
+twice (namely \.{@@@@} and \.{""}), since this additional information makes
+it easy to calculate the true length of the string. The final double-quote
+of the string is not included in its ``identifier,'' but the first one is,
+so the string length is |id_loc-id_first-double_chars-1|.
+
+We have mentioned that |normal| identifiers belong to two hash tables,
+one for their true names as they appear in the \.{WEB} file and the other
+when they have been reduced to their first |unambig_length| characters.
+The hash tables are kept by the method of simple chaining, where the
+heads of the individual lists appear in the |hash| and |chop_hash| arrays.
+If |h| is a hash code, the primary hash table list starts at |hash[h]| and
+proceeds through |link| pointers; the secondary hash table list starts at
+|chop_hash[h]| and proceeds through |equiv| pointers. Of course, the same
+identifier will probably have two different values of |h|.
+
+The |id_lookup| procedure uses an auxiliary array called |chopped_id| to
+contain up to |unambig_length| characters of the current identifier, if
+it is necessary to compute the secondary hash code. (This array could be
+declared local to |id_lookup|, but in general we are making all array
+declarations global in this program, because some compilers and some machine
+architectures make dynamic array allocation inefficient.)
+
+@<Glob...@>=
+@!id_first:0..buf_size; {where the current identifier begins in the buffer}
+@!id_loc:0..buf_size; {just after the current identifier in the buffer}
+@!double_chars:0..buf_size; {correction to length in case of strings}
+@#
+@!hash,@!chop_hash:array [0..hash_size] of sixteen_bits; {heads of hash lists}
+@!chopped_id:array [0..unambig_length] of ASCII_code; {chopped identifier}
+
+@ Initially all the hash lists are empty.
+
+@<Local variables for init...@>=
+@!h:0..hash_size; {index into hash-head arrays}
+
+@ @<Set init...@>=
+for h:=0 to hash_size-1 do
+ begin hash[h]:=0; chop_hash[h]:=0;
+ end;
+
+@ Here now is the main procedure for finding identifiers (and strings).
+The parameter |t| is set to |normal| except when the identifier is
+a macro name that is just being defined; in the latter case, |t| will be
+|numeric|, |simple|, or |parametric|.
+
+@p function id_lookup(@!t:eight_bits):name_pointer; {finds current identifier}
+label found, not_found;
+var c:eight_bits; {byte being chopped}
+@!i:0..buf_size; {index into |buffer|}
+@!h:0..hash_size; {hash code}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!l:0..buf_size; {length of the given identifier}
+@!p,@!q:name_pointer; {where the identifier is being sought}
+@!s:0..unambig_length; {index into |chopped_id|}
+begin l:=id_loc-id_first; {compute the length}
+@<Compute the hash code |h|@>;
+@<Compute the name location |p|@>;
+if (p=name_ptr)or(t<>normal) then
+ @<Update the tables and check for possible errors@>;
+id_lookup:=p;
+end;
+
+@ A simple hash code is used: If the sequence of
+ASCII codes is $c_1c_2\ldots c_m$, its hash value will be
+$$(2^{n-1}c_1+2^{n-2}c_2+\cdots+c_n)\,\bmod\,|hash_size|.$$
+
+@<Compute the hash...@>=
+h:=buffer[id_first]; i:=id_first+1;
+while i<id_loc do
+ begin h:=(h+h+buffer[i]) mod hash_size; incr(i);
+ end
+
+@ If the identifier is new, it will be placed in position |p=name_ptr|,
+otherwise |p| will point to its existing location.
+
+@<Compute the name location...@>=
+p:=hash[h];
+while p<>0 do
+ begin if length(p)=l then
+ @<Compare name |p| with current identifier, |goto found| if equal@>;
+ p:=link[p];
+ end;
+p:=name_ptr; {the current identifier is new}
+link[p]:=hash[h]; hash[h]:=p; {insert |p| at beginning of hash list}
+found:
+
+@ @<Compare name |p|...@>=
+begin i:=id_first; k:=byte_start[p]; w:=p mod ww;
+while (i<id_loc)and(buffer[i]=byte_mem[w,k]) do
+ begin incr(i); incr(k);
+ end;
+if i=id_loc then goto found; {all characters agree}
+end
+
+@ @<Update the tables...@>=
+begin if ((p<>name_ptr)and(t<>normal)and(ilk[p]=normal)) or
+ ((p=name_ptr)and(t=normal)and(buffer[id_first]<>"""")) then
+ @<Compute the secondary hash code |h| and put the first characters
+ into the auxiliary array |chopped_id|@>;
+if p<>name_ptr then
+ @<Give double-definition error, if necessary, and change |p| to type |t|@>
+else @<Enter a new identifier into the table at position |p|@>;
+end
+
+@ The following routine, which is called into play when it is necessary to
+look at the secondary hash table, computes the same hash function as before
+(but on the chopped data), and places a zero after the chopped identifier
+in |chopped_id| to serve as a convenient sentinel.
+
+@<Compute the secondary...@>=
+begin i:=id_first; s:=0; h:=0;
+while (i<id_loc)and(s<unambig_length) do
+ begin if buffer[i]<>"_" then
+ begin if buffer[i]>="a" then chopped_id[s]:=buffer[i]-@'40
+ else chopped_id[s]:=buffer[i];
+ h:=(h+h+chopped_id[s]) mod hash_size; incr(s);
+ end;
+ incr(i);
+ end;
+chopped_id[s]:=0;
+end
+
+@ If a nonnumeric macro has appeared before it was defined, \.{TANGLE}
+will still work all right; after all, such behavior is typical of the
+replacement texts for modules, which act very much like macros.
+However, an undefined numeric macro may not be used on the right-hand
+side of another numeric macro definition, so \.{TANGLE} finds it
+simplest to make a blanket rule that numeric macros should be defined
+before they are used. The following routine gives an error message and
+also fixes up any damage that may have been caused.
+
+@<Give double...@>= {now |p<>name_ptr| and |t<>normal|}
+begin if ilk[p]=normal then
+ begin if t=numeric then err_print('! This identifier has already appeared');
+@.This identifier has already...@>
+ @<Remove |p| from secondary hash table@>;
+ end
+else err_print('! This identifier was defined before');
+@.This identifier was defined...@>
+ilk[p]:=t;
+end
+
+@ When we have to remove a secondary hash entry, because a |normal| identifier
+is changing to another |ilk|, the hash code |h| and chopped identifier have
+already been computed.
+
+@<Remove |p| from secondary...@>=
+q:=chop_hash[h];
+if q=p then chop_hash[h]:=equiv[p]
+else begin while equiv[q]<>p do q:=equiv[q];
+ equiv[q]:=equiv[p];
+ end
+
+@ The following routine could make good use of a generalized |pack| procedure
+that puts items into just part of a packed array instead of the whole thing.
+
+@<Enter a new identifier...@>=
+begin if (t=normal)and(buffer[id_first]<>"""") then
+ @<Check for ambiguity and update secondary hash@>;
+w:=name_ptr mod ww; k:=byte_ptr[w];
+if k+l>max_bytes then overflow('byte memory');
+if name_ptr>max_names-ww then overflow('name');
+i:=id_first; {get ready to move the identifier into |byte_mem|}
+while i<id_loc do
+ begin byte_mem[w,k]:=buffer[i]; incr(k); incr(i);
+ end;
+byte_ptr[w]:=k; byte_start[name_ptr+ww]:=k; incr(name_ptr);
+if buffer[id_first]<>"""" then ilk[p]:=t
+else @<Define and output a new string of the pool@>;
+end
+
+@ @<Check for ambig...@>=
+begin q:=chop_hash[h];
+while q<>0 do
+ begin @<Check if |q| conflicts with |p|@>;
+ q:=equiv[q];
+ end;
+equiv[p]:=chop_hash[h]; chop_hash[h]:=p; {put |p| at front of secondary list}
+end
+
+@ @<Check if |q| conflicts...@>=
+begin k:=byte_start[q]; s:=0; w:=q mod ww;
+while (k<byte_start[q+ww]) and (s<unambig_length) do
+ begin c:=byte_mem[w,k];
+ if c<>"_" then
+ begin if c>="a" then c:=c-@'40; {merge lowercase with uppercase}
+ if chopped_id[s]<>c then goto not_found;
+ incr(s);
+ end;
+ incr(k);
+ end;
+if (k=byte_start[q+ww])and(chopped_id[s]<>0) then goto not_found;
+print_nl('! Identifier conflict with ');
+@.Identifier conflict...@>
+for k:=byte_start[q] to byte_start[q+ww]-1 do print(xchr[byte_mem[w,k]]);
+error; q:=0; {only one conflict will be printed, since |equiv[0]=0|}
+not_found:
+end
+
+@ We compute the string pool check sum by working modulo a prime number
+that is large but not so large that overflow might occur.
+
+@d check_sum_prime==@'3777777667 {$2^{29}-73$}
+@^preprocessed strings@>
+
+@<Define and output a new string...@>=
+begin ilk[p]:=numeric; {strings are like numeric macros}
+if l-double_chars=2 then {this string is for a single character}
+ equiv[p]:=buffer[id_first+1]+1073741824
+else begin equiv[p]:=string_ptr+1073741824;
+ l:=l-double_chars-1;
+ if l>99 then err_print('! Preprocessed string is too long');
+@.Preprocessed string is too long@>
+ incr(string_ptr);
+ write(pool,xchr["0"+l div 10],xchr["0"+l mod 10]); {output the length}
+ pool_check_sum:=pool_check_sum+pool_check_sum+l;
+ while pool_check_sum>check_sum_prime do
+ pool_check_sum:=pool_check_sum-check_sum_prime;
+ i:=id_first+1;
+ while i<id_loc do
+ begin write(pool,xchr[buffer[i]]); {output characters of string}
+ pool_check_sum:=pool_check_sum+pool_check_sum+buffer[i];
+ while pool_check_sum>check_sum_prime do
+ pool_check_sum:=pool_check_sum-check_sum_prime;
+ if (buffer[i]="""") or (buffer[i]="@@") then
+ i:=i+2 {omit second appearance of doubled character}
+ else incr(i);
+ end;
+ write_ln(pool);
+ end;
+end
+
+@* Searching for module names.
+The |mod_lookup| procedure finds the module name |mod_text[1..l]| in the
+search tree, after inserting it if necessary, and returns a pointer to
+where it was found.
+
+@<Glob...@>=
+@!mod_text:array [0..longest_name] of ASCII_code; {name being sought for}
+
+@ According to the rules of \.{WEB}, no module name
+should be a proper prefix of another, so a ``clean'' comparison should
+occur between any two names. The result of |mod_lookup| is 0 if this
+prefix condition is violated. An error message is printed when such violations
+are detected during phase two of \.{WEAVE}.
+
+@d less=0 {the first name is lexicographically less than the second}
+@d equal=1 {the first name is equal to the second}
+@d greater=2 {the first name is lexicographically greater than the second}
+@d prefix=3 {the first name is a proper prefix of the second}
+@d extension=4 {the first name is a proper extension of the second}
+
+@p function mod_lookup(@!l:sixteen_bits):name_pointer; {finds module name}
+label found;
+var c:less..extension; {comparison between two names}
+@!j:0..longest_name; {index into |mod_text|}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!p:name_pointer; {current node of the search tree}
+@!q:name_pointer; {father of node |p|}
+begin c:=greater; q:=0; p:=rlink[0]; {|rlink[0]| is the root of the tree}
+while p<>0 do
+ begin @<Set \(|c| to the result of comparing the given name to
+ name |p|@>;
+ q:=p;
+ if c=less then p:=llink[q]
+ else if c=greater then p:=rlink[q]
+ else goto found;
+ end;
+@<Enter a new module name into the tree@>;
+found: if c<>equal then
+ begin err_print('! Incompatible section names'); p:=0;
+@.Incompatible module names@>
+ end;
+mod_lookup:=p;
+end;
+
+@ @<Enter a new module name...@>=
+w:=name_ptr mod ww; k:=byte_ptr[w];
+if k+l>max_bytes then overflow('byte memory');
+if name_ptr>max_names-ww then overflow('name');
+p:=name_ptr;
+if c=less then llink[q]:=p else rlink[q]:=p;
+llink[p]:=0; rlink[p]:=0; c:=equal; equiv[p]:=0;
+for j:=1 to l do byte_mem[w,k+j-1]:=mod_text[j];
+byte_ptr[w]:=k+l; byte_start[name_ptr+ww]:=k+l; incr(name_ptr);
+
+@ @<Set \(|c|...@>=
+begin k:=byte_start[p]; w:=p mod ww; c:=equal; j:=1;
+while (k<byte_start[p+ww]) and (j<=l) and (mod_text[j]=byte_mem[w,k]) do
+ begin incr(k); incr(j);
+ end;
+if k=byte_start[p+ww] then
+ if j>l then c:=equal
+ else c:=extension
+else if j>l then c:=prefix
+else if mod_text[j]<byte_mem[w,k] then c:=less
+else c:=greater;
+end
+
+@ The |prefix_lookup| procedure is supposed to find exactly one module
+name that has |mod_text[1..l]| as a prefix. Actually the algorithm silently
+accepts also the situation that some module name is a prefix of
+|mod_text[1..l]|, because the user who painstakingly typed in more than
+necessary probably doesn't want to be told about the wasted effort.
+
+@p function prefix_lookup(@!l:sixteen_bits):name_pointer; {finds name extension}
+var c:less..extension; {comparison between two names}
+@!count:0..max_names; {the number of hits}
+@!j:0..longest_name; {index into |mod_text|}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+@!p:name_pointer; {current node of the search tree}
+@!q:name_pointer; {another place to resume the search after one branch is done}
+@!r:name_pointer; {extension found}
+begin q:=0; p:=rlink[0]; count:=0; r:=0; {begin search at root of tree}
+while p<>0 do
+ begin @<Set \(|c|...@>;
+ if c=less then p:=llink[p]
+ else if c=greater then p:=rlink[p]
+ else begin r:=p; incr(count); q:=rlink[p]; p:=llink[p];
+ end;
+ if p=0 then
+ begin p:=q; q:=0;
+ end;
+ end;
+if count<>1 then
+ if count=0 then err_print('! Name does not match')
+@.Name does not match@>
+ else err_print('! Ambiguous prefix');
+@.Ambiguous prefix@>
+prefix_lookup:=r; {the result will be 0 if there was no match}
+end;
+
+@* Tokens.
+Replacement texts, which represent \PASCAL\ code in a compressed format,
+appear in |tok_mem| as mentioned above. The codes in
+these texts are called `tokens'; some tokens occupy two consecutive
+eight-bit byte positions, and the others take just one byte.
+
+If $p>0$ points to a replacement text, |tok_start[p]| is the |tok_mem| position
+of the first eight-bit code of that text. If |text_link[p]=0|,
+this is the replacement text for a macro, otherwise it is the replacement
+text for a module. In the latter case |text_link[p]| is either equal to
+|module_flag|, which means that there is no further text for this module, or
+|text_link[p]| points to a
+continuation of this replacement text; such links are created when
+several modules have \PASCAL\ texts with the same name, and they also
+tie together all the \PASCAL\ texts of unnamed modules.
+The replacement text pointer for the first unnamed module
+appears in |text_link[0]|, and the most recent such pointer is |last_unnamed|.
+
+@d module_flag==max_texts {final |text_link| in module replacement texts}
+
+@<Glob...@>=
+@!last_unnamed:text_pointer; {most recent replacement text of unnamed module}
+
+@ @<Set init...@>= last_unnamed:=0; text_link[0]:=0;
+
+@ If the first byte of a token is less than @'200, the token occupies a
+single byte. Otherwise we make a sixteen-bit token by combining two consecutive
+bytes |a| and |b|. If |@'200<=a<@'250|, then $(a-@'200)\times2^8+b$ points
+to an identifier; if |@'250<=a<@'320|, then
+$(a-@'250)\times2^8+b$ points to a module name; otherwise, i.e., if
+|@'320<=a<@'400|, then $(a-@'320)\times2^8+b$ is the number of the module
+in which the current replacement text appears.
+
+Codes less than @'200 are 7-bit ASCII codes that represent themselves.
+In particular, a single-character identifier like `|x|' will be a one-byte
+token, while all longer identifiers will occupy two bytes.
+
+Some of the 7-bit ASCII codes will not be present, however, so we can
+use them for special purposes. The following symbolic names are used:
+
+\yskip\hang |param| denotes insertion of a parameter. This occurs only in
+the replacement texts of parametric macros, outside of single-quoted strings
+in those texts.
+
+\hang |begin_comment| denotes \.{@@\{}, which will become either
+\.{\{} or \.{[}.
+
+\hang |end_comment| denotes \.{@@\}}, which will become either
+\.{\}} or \.{]}.
+
+\hang |octal| denotes the \.{@@\'} that precedes an octal constant.
+
+\hang |hex| denotes the \.{@@"} that precedes a hexadecimal constant.
+
+\hang |check_sum| denotes the \.{@@\char'44} that denotes the string pool
+check sum.
+
+\hang |join| denotes the concatenation of adjacent items with no
+space or line breaks allowed between them (the \.{@@\&} operation of \.{WEB}).
+
+\hang |double_dot| denotes `\.{..}' in \PASCAL.
+
+\hang |verbatim| denotes the \.{@@=} that begins a verbatim \PASCAL\ string.
+It is also used for the end of the string.
+
+\hang |force_line| denotes the \.{@@\\} that forces a new line in the
+\PASCAL\ output.
+@^ASCII code@>
+
+@d param=0 {ASCII null code will not appear}
+@d verbatim=@'2 {extended ASCII alpha should not appear}
+@d force_line=@'3 {extended ASCII beta should not appear}
+@d begin_comment=@'11 {ASCII tab mark will not appear}
+@d end_comment=@'12 {ASCII line feed will not appear}
+@d octal=@'14 {ASCII form feed will not appear}
+@d hex=@'15 {ASCII carriage return will not appear}
+@d double_dot=@'40 {ASCII space will not appear except in strings}
+@d check_sum=@'175 {will not be confused with right brace}
+@d join=@'177 {ASCII delete will not appear}
+
+@ The following procedure is used to enter a two-byte value into
+|tok_mem| when a replacement text is being generated.
+
+@p procedure store_two_bytes(@!x:sixteen_bits);
+ {stores high byte, then low byte}
+begin if tok_ptr[z]+2>max_toks then overflow('token');
+tok_mem[z,tok_ptr[z]]:=x div@'400; {this could be done by a shift command}
+tok_mem[z,tok_ptr[z]+1]:=x mod@'400; {this could be done by a logical and}
+tok_ptr[z]:=tok_ptr[z]+2;
+end;
+
+@ When \.{TANGLE} is being operated in debug mode, it has a procedure to display
+a replacement text in symbolic form. This procedure has not been spruced up to
+generate a real great format, but at least the results are not as bad as
+a memory dump.
+
+@p @!debug procedure print_repl(@!p:text_pointer);
+var k:0..max_toks; {index into |tok_mem|}
+@!a: sixteen_bits; {current byte(s)}
+@!zp: 0..zz-1; {segment of |tok_mem| being accessed}
+begin if p>=text_ptr then print('BAD')
+else begin k:=tok_start[p]; zp:=p mod zz;
+ while k<tok_start[p+zz] do
+ begin a:=tok_mem[zp,k];
+ if a>=@'200 then @<Display two-byte token starting with |a|@>
+ else @<Display one-byte token |a|@>;
+ incr(k);
+ end;
+ end;
+end;
+gubed
+
+@ @<Display two-byte...@>=
+begin incr(k);
+if a<@'250 then {identifier or string}
+ begin a:=(a-@'200)*@'400+tok_mem[zp,k]; print_id(a);
+ if byte_mem[a mod ww,byte_start[a]]="""" then print('"')
+ else print(' ');
+ end
+else if a<@'320 then {module name}
+ begin print('@@<'); print_id((a-@'250)*@'400+tok_mem[zp,k]);
+ print('@@>');
+ end
+else begin a:=(a-@'320)*@'400+tok_mem[zp,k]; {module number}
+ print('@@',xchr["{"],a:1,'@@',xchr["}"]); {can't use right brace
+ between \&{debug} and \&{gubed}}
+ end;
+end
+
+@ @<Display one-byte...@>=
+case a of
+begin_comment: print('@@',xchr["{"]);
+end_comment: print('@@',xchr["}"]); {can't use right brace
+ between \&{debug} and \&{gubed}}
+octal: print('@@''');
+hex: print('@@"');
+check_sum: print('@@$');
+param: print('#');
+"@@": print('@@@@');
+verbatim: print('@@=');
+force_line: print('@@\');
+othercases print(xchr[a])
+endcases
+
+@* Stacks for output.
+Let's make sure that our data structures contain enough information to
+produce the entire \PASCAL\ program as desired, by working next on the
+algorithms that actually do produce that program.
+
+@ The output process uses a stack to keep track of what is going on at
+different ``levels'' as the macros are being expanded.
+Entries on this stack have five parts:
+
+\yskip\hang |end_field| is the |tok_mem| location where the replacement
+text of a particular level will end;
+
+\hang |byte_field| is the |tok_mem| location from which the next token
+on a particular level will be read;
+
+\hang |name_field| points to the name corresponding to a particular level;
+
+\hang |repl_field| points to the replacement text currently being read
+at a particular level;
+
+\hang |mod_field| is the module number, or zero if this is a macro.
+
+\yskip\noindent The current values of these five quantities are referred to
+quite frequently, so they are stored in a separate place instead of in
+the |stack| array. We call the current values |cur_end|, |cur_byte|,
+|cur_name|, |cur_repl|, and |cur_mod|.
+
+The global variable |stack_ptr| tells how many levels of output are
+currently in progress. The end of all output occurs when the stack is
+empty, i.e., when |stack_ptr=0|.
+
+@<Types...@>=
+@t\4@>@!output_state=record
+ @!end_field: sixteen_bits; {ending location of replacement text}
+ @!byte_field: sixteen_bits; {present location within replacement text}
+ @!name_field: name_pointer; {|byte_start| index for text being output}
+ @!repl_field: text_pointer; {|tok_start| index for text being output}
+ @!mod_field: 0..@'27777; {module number or zero if not a module}
+ end;
+
+@ @d cur_end==cur_state.end_field {current ending location in |tok_mem|}
+@d cur_byte==cur_state.byte_field {location of next output byte in |tok_mem|}
+@d cur_name==cur_state.name_field {pointer to current name being expanded}
+@d cur_repl==cur_state.repl_field {pointer to current replacement text}
+@d cur_mod==cur_state.mod_field {current module number being expanded}
+
+@<Globals...@>=
+@!cur_state : output_state; {|cur_end|, |cur_byte|, |cur_name|,
+ |cur_repl|, |cur_mod|}
+@!stack : array [1..stack_size] of output_state; {info for non-current levels}
+@!stack_ptr: 0..stack_size; {first unused location in the output state stack}
+
+@ It is convenient to keep a global variable |zo| equal to |cur_repl mod zz|.
+
+@<Glob...@>=
+@!zo:0..zz-1; {the segment of |tok_mem| from which output is coming}
+
+@ Parameters must also be stacked. They are placed in
+|tok_mem| just above the other replacement texts, and dummy parameter
+`names' are placed in |byte_start| just after the other names.
+The variables |text_ptr| and |tok_ptr[z]| essentially serve as parameter
+stack pointers during the output phase, so there is no need for a separate
+data structure to handle this problem.
+
+@ There is an implicit stack corresponding to meta-comments that are output
+via \.{@@\{} and \.{@@\}}. But this stack need not be represented in detail,
+because we only need to know whether it is empty or not. A global variable
+|brace_level| tells how many items would be on this stack if it were present.
+
+@<Globals...@>=
+@!brace_level: eight_bits; {current depth of $\.{@@\{}\ldots\.{@@\}}$ nesting}
+
+@ To get the output process started, we will perform the following
+initialization steps. We may assume that |text_link[0]| is nonzero, since it
+points to the \PASCAL\ text in the first unnamed module that generates
+code; if there are no such modules, there is nothing to output, and an
+error message will have been generated before we do any of the initialization.
+
+@<Initialize the output stacks@>=
+stack_ptr:=1; brace_level:=0; cur_name:=0; cur_repl:=text_link[0];
+zo:=cur_repl mod zz; cur_byte:=tok_start[cur_repl];
+cur_end:=tok_start[cur_repl+zz]; cur_mod:=0;
+
+@ When the replacement text for name |p| is to be inserted into the output,
+the following subroutine is called to save the old level of output and get
+the new one going.
+
+@p procedure push_level(@!p:name_pointer); {suspends the current level}
+begin if stack_ptr=stack_size then overflow('stack')
+else begin stack[stack_ptr]:=cur_state; {save |cur_end|, |cur_byte|, etc.}
+ incr(stack_ptr);
+ cur_name:=p; cur_repl:=equiv[p]; zo:=cur_repl mod zz;
+ cur_byte:=tok_start[cur_repl]; cur_end:=tok_start[cur_repl+zz];
+ cur_mod:=0;
+ end;
+end;
+
+@ When we come to the end of a replacement text, the |pop_level| subroutine
+does the right thing: It either moves to the continuation of this replacement
+text or returns the state to the most recently stacked level. Part of this
+subroutine, which updates the parameter stack, will be given later when we
+study the parameter stack in more detail.
+
+@p procedure pop_level; {do this when |cur_byte| reaches |cur_end|}
+label exit;
+begin if text_link[cur_repl]=0 then {end of macro expansion}
+ begin if ilk[cur_name]=parametric then
+ @<Remove a parameter from the parameter stack@>;
+ end
+else if text_link[cur_repl]<module_flag then {link to a continuation}
+ begin cur_repl:=text_link[cur_repl]; {we will stay on the same level}
+ zo:=cur_repl mod zz;
+ cur_byte:=tok_start[cur_repl]; cur_end:=tok_start[cur_repl+zz];
+ return;
+ end;
+decr(stack_ptr); {we will go down to the previous level}
+if stack_ptr>0 then
+ begin cur_state:=stack[stack_ptr]; zo:=cur_repl mod zz;
+ end;
+exit: end;
+
+@ The heart of the output procedure is the |get_output| routine, which produces
+the next token of output that is not a reference to a macro. This procedure
+handles all the stacking and unstacking that is necessary. It returns the
+value |number| if the next output has a numeric value (the value of a
+numeric macro or string), in which case |cur_val| has been set to the
+number in question. The procedure also returns the value |module_number|
+if the next output begins or ends the replacement text of some module,
+in which case |cur_val| is that module's number (if beginning) or the
+negative of that value (if ending). And it returns the value |identifier|
+if the next output is an identifier of length two or more, in which case
+|cur_val| points to that identifier name.
+
+@d number=@'200 {code returned by |get_output| when next output is numeric}
+@d module_number=@'201 {code returned by |get_output| for module numbers}
+@d identifier=@'202 {code returned by |get_output| for identifiers}
+
+@<Globals...@>=
+@!cur_val:integer; {additional information corresponding to output token}
+
+@ If |get_output| finds that no more output remains, it returns the value zero.
+
+@p function get_output:sixteen_bits; {returns next token after macro expansion}
+label restart, done, found;
+var a:sixteen_bits; {value of current byte}
+@!b:eight_bits; {byte being copied}
+@!bal:sixteen_bits; {excess of \.( versus \.) while copying a parameter}
+@!k:0..max_bytes; {index into |byte_mem|}
+@!w:0..ww-1; {segment of |byte_mem|}
+begin restart: if stack_ptr=0 then
+ begin a:=0; goto found;
+ end;
+if cur_byte=cur_end then
+ begin cur_val:=-cur_mod; pop_level;
+ if cur_val=0 then goto restart;
+ a:=module_number; goto found;
+ end;
+a:=tok_mem[zo,cur_byte]; incr(cur_byte);
+if a<@'200 then {one-byte token}
+ if a=param then
+ @<Start scanning current macro parameter, |goto restart|@>
+ else goto found;
+a:=(a-@'200)*@'400+tok_mem[zo,cur_byte]; incr(cur_byte);
+if a<@'24000 then {|@'24000=(@'250-@'200)*@'400|}
+ @<Expand macro |a| and |goto found|, or |goto restart| if no output found@>;
+if a<@'50000 then {|@'50000=(@'320-@'200)*@'400|}
+ @<Expand module |a-@'24000|, |goto restart|@>;
+cur_val:=a-@'50000; a:=module_number; cur_mod:=cur_val;
+found:
+@!debug if trouble_shooting then debug_help;@;@+gubed@/
+get_output:=a;
+end;
+
+@ The user may have forgotten to give any \PASCAL\ text for a module name,
+or the \PASCAL\ text may have been associated with a different name by mistake.
+
+@<Expand module |a-...@>=
+begin a:=a-@'24000;
+if equiv[a]<>0 then push_level(a)
+else if a<>0 then
+ begin print_nl('! Not present: <'); print_id(a); print('>'); error;
+@.Not present: <section name>@>
+ end;
+goto restart;
+end
+
+@ @<Expand macro ...@>=
+begin case ilk[a] of
+normal: begin cur_val:=a; a:=identifier;
+ end;
+numeric: begin cur_val:=equiv[a]-1073741824; a:=number;
+ end;
+simple: begin push_level(a); goto restart;
+ end;
+parametric: begin @<Put a parameter on the parameter stack,
+ or |goto restart| if error occurs@>;
+ push_level(a); goto restart;
+ end;
+othercases confusion('output')
+endcases;@/
+goto found;
+end
+
+@ We come now to the interesting part, the job of putting a parameter on
+the parameter stack. First we pop the stack if necessary until getting to
+a level that hasn't ended. Then the next character must be a `\.(';
+and since parentheses are balanced on each level, the entire parameter must
+be present, so we can copy it without difficulty.
+
+@<Put a parameter...@>=
+while (cur_byte=cur_end)and(stack_ptr>0) do pop_level;
+if (stack_ptr=0)or(tok_mem[zo,cur_byte]<>"(") then
+ begin print_nl('! No parameter given for '); print_id(a); error;
+@.No parameter given for macro@>
+ goto restart;
+ end;
+@<Copy the parameter into |tok_mem|@>;
+equiv[name_ptr]:=text_ptr; ilk[name_ptr]:=simple; w:=name_ptr mod ww;
+k:=byte_ptr[w];
+@!debug if k=max_bytes then overflow('byte memory');
+byte_mem[w,k]:="#"; incr(k); byte_ptr[w]:=k;
+gubed {this code has set the parameter identifier for debugging printouts}
+if name_ptr>max_names-ww then overflow('name');
+byte_start[name_ptr+ww]:=k; incr(name_ptr);
+if text_ptr>max_texts-zz then overflow('text');
+text_link[text_ptr]:=0; tok_start[text_ptr+zz]:=tok_ptr[z];
+incr(text_ptr);
+z:=text_ptr mod zz
+
+@ The |pop_level| routine undoes the effect of parameter-pushing when
+a parameter macro is finished:
+
+@<Remove a parameter...@>=
+begin decr(name_ptr); decr(text_ptr);
+z:=text_ptr mod zz;
+stat if tok_ptr[z]>max_tok_ptr[z] then max_tok_ptr[z]:=tok_ptr[z];
+tats {the maximum value of |tok_ptr| occurs just before parameter popping}
+tok_ptr[z]:=tok_start[text_ptr];
+@!debug decr(byte_ptr[name_ptr mod ww]);@+gubed
+end
+
+@ When a parameter occurs in a replacement text, we treat it as a simple
+macro in position (|name_ptr-1|):
+
+@<Start scanning...@>=
+begin push_level(name_ptr-1); goto restart;
+end
+
+@ Similarly, a |param| token encountered as we copy a parameter is converted
+into a simple macro call for |name_ptr-1|.
+Some care is needed to handle cases like \\{macro}|(#; print('#)'))|; the
+\.{\#} token will have been changed to |param| outside of strings, but we
+still must distinguish `real' parentheses from those in strings.
+
+@d app_repl(#)==begin if tok_ptr[z]=max_toks then overflow('token');
+ tok_mem[z,tok_ptr[z]]:=#; incr(tok_ptr[z]); end
+
+@<Copy the parameter...@>=
+bal:=1; incr(cur_byte); {skip the opening `\.('}
+loop@+ begin b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ if b=param then store_two_bytes(name_ptr+@'77777)
+ else begin if b>=@'200 then
+ begin app_repl(b);
+ b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ end
+ else case b of
+ "(": incr(bal);
+ ")": begin decr(bal);
+ if bal=0 then goto done;
+ end;
+ "'": repeat app_repl(b);
+ b:=tok_mem[zo,cur_byte]; incr(cur_byte);
+ until b="'"; {copy string, don't change |bal|}
+ othercases do_nothing
+ endcases;
+ app_repl(b);
+ end;
+ end;
+done:
+
+@* Producing the output.
+The |get_output| routine above handles most of the complexity of output
+generation, but there are two further considerations that have a nontrivial
+effect on \.{TANGLE}'s algorithms.
+
+First, we want to make sure that the output is broken into lines not
+exceeding |line_length| characters per line, where these breaks occur at
+valid places (e.g., not in the middle of a string or a constant or an
+identifier, not between `\.<' and `\.>', not at a `\.{@@\&}' position
+where quantities are being joined together). Therefore we assemble the
+output into a buffer before deciding where the line breaks will appear.
+However, we make very little attempt to make ``logical'' line breaks that
+would enhance the readability of the output; people are supposed to read
+the input of \.{TANGLE} or the \TeX ed output of \.{WEAVE}, but not the
+tangled-up output. The only concession to readability is that a break after
+a semicolon will be made if possible, since commonly used ``pretty
+printing'' routines give better results in such cases.
+
+Second, we want to decimalize non-decimal constants, and to combine integer
+quantities that are added or subtracted, because \PASCAL\ doesn't allow
+constant expressions in subrange types or in case labels. This means we
+want to have a procedure that treats a construction like \.{(E-15+17)}
+as equivalent to `\.{(E+2)}', while also leaving `\.{(1E-15+17)}' and
+`\.{(E-15+17*y)}' untouched. Consider also `\.{-15+17.5}' versus
+`\.{-15+17..5}'. We shall not combine integers preceding or following
+\.*, \./, \.{div}, \.{mod}, or \.{@@\&}. Note that if |y| has been defined
+to equal $-2$, we must expand `\.{x*y}' into `\.{x*(-2)}'; but `\.{x-y}'
+can expand into `\.{x+2}' and we can even change `\.{x - y mod z}' to
+@^mod@>
+`\.{x + 2 mod z}' because \PASCAL\ has a nonstandard \&{mod} operation!
+
+The following solution to these problems has been adopted: An array
+|out_buf| contains characters that have been generated but not yet output,
+and there are three pointers into this array. One of these, |out_ptr|, is
+the number of characters currently in the buffer, and we will have
+|1<=out_ptr<=line_length| most of the time. The second is |break_ptr|,
+which is the largest value |<=out_ptr| such that we are definitely entitled
+to end a line by outputting the characters |out_buf[1..(break_ptr-1)]|;
+we will always have |break_ptr<=line_length|. Finally, |semi_ptr| is either
+zero or the largest known value of a legal break after a semicolon or comment
+on the current line; we will always have |semi_ptr<=break_ptr|.
+
+@<Globals...@>=
+@!out_buf: array [0..out_buf_size] of ASCII_code; {assembled characters}
+@!out_ptr: 0..out_buf_size; {first available place in |out_buf|}
+@!break_ptr: 0..out_buf_size; {last breaking place in |out_buf|}
+@!semi_ptr: 0..out_buf_size; {last semicolon breaking place in |out_buf|}
+
+@ Besides having those three pointers,
+the output process is in one of several states:
+
+\yskip\hang |num_or_id| means that the last item in the buffer is a number or
+identifier, hence a blank space or line break must be inserted if the next
+item is also a number or identifier.
+
+\yskip\hang |unbreakable| means that the last item in the buffer was followed
+by the \.{@@\&} operation that inhibits spaces between it and the next item.
+
+\yskip\hang |sign| means that the last item in the buffer is to be followed
+by \.+ or \.-, depending on whether |out_app| is positive or negative.
+
+\yskip\hang |sign_val| means that the decimal equivalent of
+$\vert|out_val|\vert$ should be appended to the buffer. If |out_val<0|,
+or if |out_val=0| and |last_sign<0|, the number should be preceded by a minus
+sign. Otherwise it should be preceded by the character |out_sign| unless
+|out_sign=0|; the |out_sign| variable is either 0 or \.{"\ "} or \.{"+"}.
+
+\yskip\hang |sign_val_sign| is like |sign_val|, but also append \.+ or \.-
+afterwards, depending on whether |out_app| is positive or negative.
+
+\yskip\hang |sign_val_val| is like |sign_val|, but also append the decimal
+equivalent of |out_app| including its sign, using |last_sign| in case
+|out_app=0|.
+
+\yskip\hang |misc| means none of the above.
+
+\yskip\noindent
+For example, the output buffer and output state run through the following
+sequence as we generate characters from `\.{(x-15+19-2)}':
+$$\vbox{\halign{$\hfil#\hfil$\quad&#\hfil&\quad\hfil#\hfil&\quad
+\hfil#\hfil&\quad\hfil#\hfil&\quad\hfil#\hfil\quad&\hfil#\hfil\cr
+output&|out_buf|&|out_state|&|out_sign|&|out_val|&|out_app|&|last_sign|\cr
+\noalign{\vskip 3pt}
+(&\.(&|misc|\cr
+x&\.{(x}&|num_or_id|\cr
+-&\.{(x}&|sign|&&&$-1$&$-1$\cr
+15&\.{(x}&|sign_val|&\.{"+"}&$-15$&&$-15$\cr
++&\.{(x}&|sign_val_sign|&\.{"+"}&$-15$&$+1$&$+1$\cr
+19&\.{(x}&|sign_val_val|&\.{"+"}&$-15$&$+19$&$+1$\cr
+-&\.{(x}&|sign_val_sign|&\.{"+"}&$+4$&$-1$&$-1$\cr
+2&\.{(x}&|sign_val_val|&\.{"+"}&$+4$&$-2$&$-2$\cr
+)&\.{(x+2)}&|misc|\cr}}$$
+At each stage we have put as much into the buffer as possible without
+knowing what is coming next. Examples like `\.{x-0.1}' indicate why
+|last_sign| is needed to associate the proper sign with an output of zero.
+
+In states |num_or_id|, |unbreakable|, and |misc| the last item in the buffer
+lies between |break_ptr| and |out_ptr-1|, inclusive; in the other states we
+have |break_ptr=out_ptr|.
+
+The numeric values assigned to |num_or_id|, etc., have been chosen to
+shorten some of the program logic; for example, the program makes use of
+the fact that |sign+2=sign_val_sign|.
+
+@d misc=0 {state associated with special characters}
+@d num_or_id=1 {state associated with numbers and identifiers}
+@d sign=2 {state associated with pending \.+ or \.-}
+@d sign_val=num_or_id+2 {state associated with pending sign and value}
+@d sign_val_sign=sign+2 {|sign_val| followed by another pending sign}
+@d sign_val_val=sign_val+2 {|sign_val| followed by another pending value}
+@d unbreakable=sign_val_val+1 {state associated with \.{@@\&}}
+
+@<Globals...@>=
+@!out_state:eight_bits; {current status of partial output}
+@!out_val,@!out_app:integer; {pending values}
+@!out_sign:ASCII_code; {sign to use if appending |out_val>=0|}
+@!last_sign:-1..+1; {sign to use if appending a zero}
+
+@ During the output process, |line| will equal the number of the next line
+to be output.
+
+@<Initialize the output buffer@>=
+out_state:=misc; out_ptr:=0; break_ptr:=0; semi_ptr:=0; out_buf[0]:=0; line:=1;
+
+@ Here is a routine that is invoked when |out_ptr>line_length|
+or when it is time to flush out the final line. The |flush_buffer| procedure
+often writes out the line up to the current |break_ptr| position, then moves the
+remaining information to the front of |out_buf|. However, it prefers to
+write only up to |semi_ptr|, if the residual line won't be too long.
+
+@d check_break==if out_ptr>line_length then flush_buffer
+
+@p procedure flush_buffer; {writes one line to output file}
+var k:0..out_buf_size; {index into |out_buf|}
+@!b:0..out_buf_size; {value of |break_ptr| upon entry}
+begin b:=break_ptr;
+if (semi_ptr<>0)and(out_ptr-semi_ptr<=line_length) then break_ptr:=semi_ptr;
+for k:=1 to break_ptr do write(Pascal_file,xchr[out_buf[k-1]]);
+write_ln(Pascal_file); incr(line);
+if line mod 100 = 0 then
+ begin print('.');
+ if line mod 500 = 0 then print(line:1);
+ update_terminal; {progress report}
+ end;
+if break_ptr<out_ptr then
+ begin if out_buf[break_ptr]=" " then
+ begin incr(break_ptr); {drop space at break}
+ if break_ptr>b then b:=break_ptr;
+ end;
+ for k:=break_ptr to out_ptr-1 do out_buf[k-break_ptr]:=out_buf[k];
+ end;
+out_ptr:=out_ptr-break_ptr; break_ptr:=b-break_ptr; semi_ptr:=0;
+if out_ptr>line_length then
+ begin err_print('! Long line must be truncated'); out_ptr:=line_length;
+@.Long line must be truncated@>
+ end;
+end;
+
+@ @<Empty the last line from the buffer@>=
+break_ptr:=out_ptr; semi_ptr:=0; flush_buffer;
+if brace_level<>0 then
+ err_print('! Program ended at brace level ',brace_level:1);
+@.Program ended at brace level n@>
+
+@ Another simple and useful routine appends the decimal equivalent of
+a nonnegative integer to the output buffer.
+
+@d app(#)==begin out_buf[out_ptr]:=#; incr(out_ptr); {append a single character}
+ end
+
+@p procedure app_val(@!v:integer); {puts |v| into buffer, assumes |v>=0|}
+var k:0..out_buf_size; {index into |out_buf|}
+begin k:=out_buf_size; {first we put the digits at the very end of |out_buf|}
+repeat out_buf[k]:=v mod 10; v:=v div 10; decr(k);
+until v=0;
+repeat incr(k); app(out_buf[k]+"0");
+until k=out_buf_size; {then we append them, most significant first}
+end;
+
+@ The output states are kept up to date by the output routines, which are
+called |send_out|, |send_val|, and |send_sign|. The |send_out| procedure
+has two parameters: |t| tells the type of information being sent and
+|v| contains the information proper. Some information may also be passed
+in the array |out_contrib|.
+
+\yskip\hang If |t=misc| then |v| is a character to be output.
+
+\hang If |t=str| then |v| is the length of a string or something like `\.{<>}'
+in |out_contrib|.
+
+\hang If |t=ident| then |v| is the length of an identifier in |out_contrib|.
+
+\hang If |t=frac| then |v| is the length of a fraction and/or exponent in
+|out_contrib|.
+
+@d str=1 {|send_out| code for a string}
+@d ident=2 {|send_out| code for an identifier}
+@d frac=3 {|send_out| code for a fraction}
+
+@<Glob...@>=
+@!out_contrib:array[1..line_length] of ASCII_code; {a contribution to |out_buf|}
+
+@ A slightly subtle point in the following code is that the user may ask
+for a |join| operation (i.e., \.{@@\&}) following whatever is being sent
+out. We will see later that |join| is implemented in part by calling
+|send_out(frac,0)|.
+
+@p procedure send_out(@!t:eight_bits; @!v:sixteen_bits);
+ {outputs |v| of type |t|}
+label restart;
+var k: 0..line_length; {index into |out_contrib|}
+begin @<Get the buffer ready for appending the new information@>;
+if t<>misc then for k:=1 to v do app(out_contrib[k])
+else app(v);
+check_break;
+if (t=misc)and((v=";")or(v="}")) then
+ begin semi_ptr:=out_ptr; break_ptr:=out_ptr;
+ end;
+if t>=ident then out_state:=num_or_id {|t=ident| or |frac|}
+else out_state:=misc {|t=str| or |misc|}
+end;
+
+@ Here is where the buffer states for signs and values collapse into simpler
+states, because we are about to append something that doesn't combine with
+the previous integer constants.
+
+We use an ASCII-code trick: Since |","-1="+"| and |","+1="-"|, we have
+|","-c=@t sign of $c$@>|, when $\vert c\vert=1$.
+
+@<Get the buffer ready...@>=
+restart: case out_state of
+num_or_id: if t<>frac then
+ begin break_ptr:=out_ptr;
+ if t=ident then app(" ");
+ end;
+sign: begin app(","-out_app); check_break; break_ptr:=out_ptr;
+ end;
+sign_val,sign_val_sign: begin @<Append \(|out_val| to buffer@>;
+ out_state:=out_state-2; goto restart;
+ end;
+sign_val_val: @<Reduce |sign_val_val| to |sign_val| and |goto restart|@>;
+misc: if t<>frac then break_ptr:=out_ptr;@/
+othercases do_nothing {this is for |unbreakable| state}
+endcases
+
+@ @<Append \(|out_val|...@>=
+if (out_val<0)or((out_val=0)and(last_sign<0)) then app("-")
+else if out_sign>0 then app(out_sign);
+app_val(abs(out_val)); check_break;
+
+@ @<Reduce |sign_val_val|...@>=
+begin if (t=frac)or(@<Contribution is \.* or \./ or \.{DIV} or \.{MOD}@>) then
+ begin @<Append \(|out_val| to buffer@>;
+ out_sign:="+"; out_val:=out_app;
+ end
+else out_val:=out_val+out_app;
+out_state:=sign_val; goto restart;
+end
+
+@ @<Contribution is \.*...@>=
+((t=ident)and(v=3)and@|
+ (((out_contrib[1]="D")and(out_contrib[2]="I")and(out_contrib[3]="V")) or@|
+ ((out_contrib[1]="M")and(out_contrib[2]="O")and(out_contrib[3]="D")) ))or@|
+@^uppercase@>
+ ((t=misc)and((v="*")or(v="/")))
+
+@ The following routine is called with $v=\pm1$ when a plus or minus sign is
+appended to the output. It extends \PASCAL\ to allow repeated signs
+(e.g., `\.{--}' is equivalent to `\.+'), rather than to give an error message.
+The signs following `\.E' in real constants are treated as part of a fraction,
+so they are not seen by this routine.
+
+@p procedure send_sign(@!v:integer);
+begin case out_state of
+sign, sign_val_sign: out_app:=out_app*v;
+sign_val:begin out_app:=v; out_state:=sign_val_sign;
+ end;
+sign_val_val: begin out_val:=out_val+out_app; out_app:=v;
+ out_state:=sign_val_sign;
+ end;
+othercases begin break_ptr:=out_ptr; out_app:=v; out_state:=sign;
+ end
+endcases;@/
+last_sign:=out_app;
+end;
+
+@ When a (signed) integer value is to be output, we call |send_val|.
+
+@d bad_case=666 {this is a label used below}
+
+@p procedure send_val(@!v:integer); {output the (signed) value |v|}
+label bad_case, {go here if we can't keep |v| in the output state}
+ exit;
+begin case out_state of
+num_or_id: begin @<If previous output was \.{DIV} or \.{MOD}, |goto bad_case|@>;
+ out_sign:=" "; out_state:=sign_val; out_val:=v; break_ptr:=out_ptr;
+ last_sign:=+1;
+ end;
+misc: begin @<If previous output was \.* or \./, |goto bad_case|@>;
+ out_sign:=0; out_state:=sign_val; out_val:=v; break_ptr:=out_ptr;
+ last_sign:=+1;
+ end;
+@t\4@>@<Handle cases of |send_val| when |out_state| contains a sign@>@;
+othercases goto bad_case
+endcases;@/
+return;
+bad_case: @<Append the decimal value of |v|, with parentheses if negative@>;
+exit: end;
+
+@ @<Handle cases of |send_val|...@>=
+sign: begin out_sign:="+"; out_state:=sign_val; out_val:=out_app*v;
+ end;
+sign_val: begin out_state:=sign_val_val; out_app:=v;
+ err_print('! Two numbers occurred without a sign between them');
+ end;
+sign_val_sign: begin out_state:=sign_val_val; out_app:=out_app*v;
+ end;
+sign_val_val: begin out_val:=out_val+out_app; out_app:=v;
+ err_print('! Two numbers occurred without a sign between them');
+@.Two numbers occurred...@>
+ end;
+
+@ @<If previous output was \.*...@>=
+if (out_ptr=break_ptr+1)and((out_buf[break_ptr]="*")or(out_buf[break_ptr]="/"))
+ then goto bad_case
+
+@ @<If previous output was \.{DIV}...@>=
+if (out_ptr=break_ptr+3)or
+ ((out_ptr=break_ptr+4)and(out_buf[break_ptr]=" ")) then
+@^uppercase@>
+ if ((out_buf[out_ptr-3]="D")and(out_buf[out_ptr-2]="I")and
+ (out_buf[out_ptr-1]="V"))or @/
+ ((out_buf[out_ptr-3]="M")and(out_buf[out_ptr-2]="O")and
+ (out_buf[out_ptr-1]="D")) then@/ goto bad_case
+
+@ @<Append the decimal value...@>=
+if v>=0 then
+ begin if out_state=num_or_id then
+ begin break_ptr:=out_ptr; app(" ");
+ end;
+ app_val(v); check_break; out_state:=num_or_id;
+ end
+else begin app("("); app("-"); app_val(-v); app(")"); check_break;
+ out_state:=misc;
+ end
+
+@* The big output switch.
+To complete the output process, we need a routine that takes the results
+of |get_output| and feeds them to |send_out|, |send_val|, or |send_sign|.
+This procedure `|send_the_output|' will be invoked just once, as follows:
+
+@<Phase II: Output the contents of the compressed tables@>=
+if text_link[0]=0 then
+ begin print_nl('! No output was specified.'); mark_harmless;
+@.No output was specified@>
+ end
+else begin print_nl('Writing the output file'); update_terminal;@/
+ @<Initialize the output stacks@>;
+ @<Initialize the output buffer@>;
+ send_the_output;@/
+ @<Empty the last line...@>;
+ print_nl('Done.');
+ end
+
+@ A many-way switch is used to send the output:
+
+@d get_fraction=2 {this label is used below}
+
+@p procedure send_the_output;
+label get_fraction, {go here to finish scanning a real constant}
+ reswitch, continue;
+var cur_char:eight_bits; {the latest character received}
+ @!k:0..line_length; {index into |out_contrib|}
+ @!j:0..max_bytes; {index into |byte_mem|}
+ @!w:0..ww-1; {segment of |byte_mem|}
+ @!n:integer; {number being scanned}
+begin while stack_ptr>0 do
+ begin cur_char:=get_output;
+ reswitch: case cur_char of
+ 0: do_nothing; {this case might arise if output ends unexpectedly}
+ @t\4@>@<Cases related to identifiers@>@;
+ @t\4@>@<Cases related to constants, possibly leading to
+ |get_fraction| or |reswitch|@>@;
+ "+","-": send_sign(","-cur_char);
+ @t\4@>@<Cases like \.{<>} and \.{:=}@>@;
+ "'": @<Send a string, |goto reswitch|@>;
+ @<Other printable characters@>: send_out(misc,cur_char);
+ @t\4@>@<Cases involving \.{@@\{} and \.{@@\}}@>@;
+ join: begin send_out(frac,0); out_state:=unbreakable;
+ end;
+ verbatim: @<Send verbatim string@>;
+ force_line: @<Force a line break@>;
+ othercases err_print('! Can''t output ASCII code ',cur_char:1)
+@.Can't output ASCII code n@>
+ endcases;@/
+ goto continue;
+ get_fraction: @<Special code to finish real constants@>;
+ continue: end;
+end;
+
+@ @<Cases like \.{<>}...@>=
+and_sign: begin out_contrib[1]:="A"; out_contrib[2]:="N"; out_contrib[3]:="D";
+@^uppercase@>
+ send_out(ident,3);
+ end;
+not_sign: begin out_contrib[1]:="N"; out_contrib[2]:="O"; out_contrib[3]:="T";
+ send_out(ident,3);
+ end;
+set_element_sign: begin out_contrib[1]:="I"; out_contrib[2]:="N";
+ send_out(ident,2);
+ end;
+or_sign: begin out_contrib[1]:="O"; out_contrib[2]:="R"; send_out(ident,2);
+ end;
+left_arrow: begin out_contrib[1]:=":"; out_contrib[2]:="="; send_out(str,2);
+ end;
+not_equal: begin out_contrib[1]:="<"; out_contrib[2]:=">"; send_out(str,2);
+ end;
+less_or_equal: begin out_contrib[1]:="<"; out_contrib[2]:="="; send_out(str,2);
+ end;
+greater_or_equal: begin out_contrib[1]:=">"; out_contrib[2]:="=";
+ send_out(str,2);
+ end;
+equivalence_sign: begin out_contrib[1]:="="; out_contrib[2]:="=";
+ send_out(str,2);
+ end;
+double_dot: begin out_contrib[1]:="."; out_contrib[2]:="."; send_out(str,2);
+ end;
+
+@ Please don't ask how all of the following characters can actually get
+through \.{TANGLE} outside of strings. It seems that |""""| and |"{"|
+cannot actually occur at this point of the program, but they have
+been included just in case \.{TANGLE} changes.
+
+If \.{TANGLE} is producing code for a \PASCAL\ compiler that uses `\.{(.}'
+and `\.{.)}' instead of square brackets (e.g., on machines with {\mc EBCDIC}
+code), one should remove |"["| and |"]"| from this list and put them into
+the preceding module in the appropriate way. Similarly, some compilers
+want `\.\^' to be converted to `\.{@@}'.
+@^system dependencies@>@^EBCDIC@>
+
+@<Other printable characters@>=
+"!","""","#","$","%","&","(",")","*",",","/",":",";","<","=",">","?",
+"@@","[","\","]","^","_","`","{","|"
+
+@ Single-character identifiers represent themselves, while longer ones
+appear in |byte_mem|. All must be converted to uppercase,
+with underlines removed. Extremely long identifiers must be chopped.
+
+(Some \PASCAL\ compilers work with lowercase letters instead of
+uppercase. If this module of \.{TANGLE} is changed, it's also necessary
+to change from uppercase to lowercase in the modules that are
+listed in the index under ``uppercase''.)
+@^system dependencies@>
+@^uppercase@>
+
+@d up_to(#)==#-24,#-23,#-22,#-21,#-20,#-19,#-18,#-17,#-16,#-15,#-14,
+ #-13,#-12,#-11,#-10,#-9,#-8,#-7,#-6,#-5,#-4,#-3,#-2,#-1,#
+
+@<Cases related to identifiers@>=
+"A",up_to("Z"): begin out_contrib[1]:=cur_char; send_out(ident,1);
+ end;
+"a",up_to("z"): begin out_contrib[1]:=cur_char-@'40; send_out(ident,1);
+ end;
+identifier: begin k:=0; j:=byte_start[cur_val]; w:=cur_val mod ww;
+ while (k<max_id_length)and(j<byte_start[cur_val+ww]) do
+ begin incr(k); out_contrib[k]:=byte_mem[w,j]; incr(j);
+ if out_contrib[k]>="a" then out_contrib[k]:=out_contrib[k]-@'40
+ else if out_contrib[k]="_" then decr(k);
+ end;
+ send_out(ident,k);
+ end;
+
+@ After sending a string, we need to look ahead at the next character, in order
+to see if there were two consecutive single-quote marks. Afterwards we go to
+|reswitch| to process the next character.
+
+@<Send a string...@>=
+begin k:=1; out_contrib[1]:="'";
+repeat if k<line_length then incr(k);
+out_contrib[k]:=get_output;
+until (out_contrib[k]="'")or(stack_ptr=0);
+if k=line_length then err_print('! String too long');
+@.String too long@>
+send_out(str,k); cur_char:=get_output;
+if cur_char="'" then out_state:=unbreakable;
+goto reswitch;
+end
+
+@ Sending a verbatim string is similar, but we don't have to look ahead.
+
+@<Send verbatim string@>=
+begin k:=0;
+repeat if k<line_length then incr(k);
+out_contrib[k]:=get_output;
+until (out_contrib[k]=verbatim)or(stack_ptr=0);
+if k=line_length then err_print('! Verbatim string too long');
+@.Verbatim string too long@>
+send_out(str,k-1);
+end
+
+@ In order to encourage portable software, \.{TANGLE} complains
+if the constants get dangerously close to the largest value representable
+on a 32-bit computer ($2^{31}-1$).
+
+@d digits=="0","1","2","3","4","5","6","7","8","9"
+
+@<Cases related to constants...@>=
+digits: begin n:=0;
+ repeat cur_char:=cur_char-"0";
+ if n>=@'1463146314 then err_print('! Constant too big')
+@.Constant too big@>
+ else n:=10*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"9")or(cur_char<"0");
+ send_val(n); k:=0;
+ if cur_char="e" then cur_char:="E";
+@^uppercase@>
+ if cur_char="E" then goto get_fraction
+ else goto reswitch;
+ end;
+check_sum: send_val(pool_check_sum);
+octal: begin n:=0; cur_char:="0";
+ repeat cur_char:=cur_char-"0";
+ if n>=@'2000000000 then err_print('! Constant too big')
+ else n:=8*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"7")or(cur_char<"0");
+ send_val(n); goto reswitch;
+ end;
+hex: begin n:=0; cur_char:="0";
+ repeat if cur_char>="A" then cur_char:=cur_char+10-"A"
+ else cur_char:=cur_char-"0";
+ if n>=@"8000000 then err_print('! Constant too big')
+ else n:=16*n+cur_char;
+ cur_char:=get_output;
+ until (cur_char>"F")or(cur_char<"0")or@|
+ ((cur_char>"9")and(cur_char<"A"));
+ send_val(n); goto reswitch;
+ end;
+number: send_val(cur_val);
+".": begin k:=1; out_contrib[1]:="."; cur_char:=get_output;
+ if cur_char="." then
+ begin out_contrib[2]:="."; send_out(str,2);
+ end
+ else if (cur_char>="0")and(cur_char<="9") then goto get_fraction
+ else begin send_out(misc,"."); goto reswitch;
+ end;
+ end;
+
+@ The following code appears at label `|get_fraction|', when we want to
+scan to the end of a real constant. The first |k| characters of a fraction
+have already been placed in |out_contrib|, and |cur_char| is the next character.
+
+@<Special code...@>=
+repeat if k<line_length then incr(k);
+out_contrib[k]:=cur_char; cur_char:=get_output;
+if (out_contrib[k]="E")and((cur_char="+")or(cur_char="-")) then
+@^uppercase@>
+ begin if k<line_length then incr(k);
+ out_contrib[k]:=cur_char; cur_char:=get_output;
+ end
+else if cur_char="e" then cur_char:="E";
+until (cur_char<>"E")and((cur_char<"0")or(cur_char>"9"));
+if k=line_length then err_print('! Fraction too long');
+@.Fraction too long@>
+send_out(frac,k); goto reswitch
+
+@ Some \PASCAL\ compilers do not recognize comments in braces, so the
+comments must be delimited by `\.{(*}' and `\.{*)}'.
+@^system dependencies@>
+In such cases the statement `|send_out(misc,"{")|' that appears here should
+be replaced by `\ignorespaces|begin out_contrib[1]:="("; out_contrib[2]:="*";
+send_out(str,2); end|', and a similar change should be made to
+`|send_out(misc,"}")|'.
+
+@<Cases involving \.{@@\{} and \.{@@\}}@>=
+begin_comment: begin if brace_level=0 then send_out(misc,"{")
+ else send_out(misc,"[");
+ incr(brace_level);
+ end;
+end_comment: if brace_level>0 then
+ begin decr(brace_level);
+ if brace_level=0 then send_out(misc,"}")
+ else send_out(misc,"]");
+ end
+ else err_print('! Extra @@}');
+@.Extra \AT!\}@>
+module_number: begin if brace_level=0 then send_out(misc,"{")
+ else send_out(misc,"[");
+ if cur_val<0 then
+ begin send_out(misc,":"); send_val(-cur_val);
+ end
+ else begin send_val(cur_val); send_out(misc,":");
+ end;
+ if brace_level=0 then send_out(misc,"}")
+ else send_out(misc,"]");
+ end;
+
+@ @<Force a line break@>=
+begin send_out(str,0); {normalize the buffer}
+while out_ptr>0 do
+ begin if out_ptr<=line_length then break_ptr:=out_ptr;
+ flush_buffer;
+ end;
+out_state:=misc;
+end
+
+@* Introduction to the input phase.
+We have now seen that \.{TANGLE} will be able to output the full
+\PASCAL\ program, if we can only get that program into the byte memory in
+the proper format. The input process is something like the output process
+in reverse, since we compress the text as we read it in and we expand it
+as we write it out.
+
+There are three main input routines. The most interesting is the one that gets
+the next token of a \PASCAL\ text; the other two are used to scan rapidly past
+\TeX\ text in the \.{WEB} source code. One of the latter routines will jump to
+the next token that starts with `\.{@@}', and the other skips to the end
+of a \PASCAL\ comment.
+
+@ But first we need to consider the low-level routine |get_line|
+that takes care of merging |change_file| into |web_file|. The |get_line|
+procedure also updates the line numbers for error messages.
+
+@<Globals...@>=
+@!ii:integer; {general purpose |for| loop variable in the outer block}
+@!line:integer; {the number of the current line in the current file}
+@!other_line:integer; {the number of the current line in the input file that
+ is not currently being read}
+@!temp_line:integer; {used when interchanging |line| with |other_line|}
+@!limit:0..buf_size; {the last character position occupied in the buffer}
+@!loc:0..buf_size; {the next character position to be read from the buffer}
+@!input_has_ended: boolean; {if |true|, there is no more input}
+@!changing: boolean; {if |true|, the current line is from |change_file|}
+
+@ As we change |changing| from |true| to |false| and back again, we must
+remember to swap the values of |line| and |other_line| so that the |err_print|
+routine will be sure to report the correct line number.
+
+@d change_changing==
+ changing := not changing;
+ temp_line:=other_line; other_line:=line; line:=temp_line
+ {|line @t$\null\BA\null$@> other_line|}
+
+@ When |changing| is |false|, the next line of |change_file| is kept in
+|change_buffer[0..change_limit]|, for purposes of comparison with the next
+line of |web_file|. After the change file has been completely input, we
+set |change_limit:=0|, so that no further matches will be made.
+
+@<Globals...@>=
+@!change_buffer:array[0..buf_size] of ASCII_code;
+@!change_limit:0..buf_size; {the last position occupied in |change_buffer|}
+
+@ Here's a simple function that checks if the two buffers are different.
+
+@p function lines_dont_match:boolean;
+label exit;
+var k:0..buf_size; {index into the buffers}
+begin lines_dont_match:=true;
+if change_limit<>limit then return;
+if limit>0 then
+ for k:=0 to limit-1 do if change_buffer[k]<>buffer[k] then return;
+lines_dont_match:=false;
+exit: end;
+
+@ Procedure |prime_the_change_buffer| sets |change_buffer| in preparation
+for the next matching operation. Since blank lines in the change file are
+not used for matching, we have |(change_limit=0)and not changing| if and
+only if the change file is exhausted. This procedure is called only
+when |changing| is true; hence error messages will be reported correctly.
+
+@p procedure prime_the_change_buffer;
+label continue, done, exit;
+var k:0..buf_size; {index into the buffers}
+begin change_limit:=0; {this value will be used if the change file ends}
+@<Skip over comment lines in the change file; |return| if end of file@>;
+@<Skip to the next nonblank line; |return| if end of file@>;
+@<Move |buffer| and |limit| to |change_buffer| and |change_limit|@>;
+exit: end;
+
+@ While looking for a line that begins with \.{@@x} in the change file,
+we allow lines that begin with \.{@@}, as long as they don't begin with
+\.{@@y} or \.{@@z} (which would probably indicate that the change file is
+fouled up).
+
+@<Skip over comment lines in the change file...@>=
+loop@+ begin incr(line);
+ if not input_ln(change_file) then return;
+ if limit<2 then goto continue;
+ if buffer[0]<>"@@" then goto continue;
+ if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if buffer[1]="x" then goto done;
+ if (buffer[1]="y")or(buffer[1]="z") then
+ begin loc:=2; err_print('! Where is the matching @@x?');
+@.Where is the match...@>
+ end;
+continue: end;
+done:
+
+@ Here we are looking at lines following the \.{@@x}.
+
+@<Skip to the next nonblank line...@>=
+repeat incr(line);
+ if not input_ln(change_file) then
+ begin err_print('! Change file ended after @@x');
+@.Change file ended...@>
+ return;
+ end;
+until limit>0;
+
+@ @<Move |buffer| and |limit| to |change_buffer| and |change_limit|@>=
+begin change_limit:=limit;
+if limit>0 then for k:=0 to limit-1 do change_buffer[k]:=buffer[k];
+end
+
+@ The following procedure is used to see if the next change entry should
+go into effect; it is called only when |changing| is false.
+The idea is to test whether or not the current
+contents of |buffer| matches the current contents of |change_buffer|.
+If not, there's nothing more to do; but if so, a change is called for:
+All of the text down to the \.{@@y} is supposed to match. An error
+message is issued if any discrepancy is found. Then the procedure
+prepares to read the next line from |change_file|.
+
+@p procedure check_change; {switches to |change_file| if the buffers match}
+label exit;
+var n:integer; {the number of discrepancies found}
+@!k:0..buf_size; {index into the buffers}
+begin if lines_dont_match then return;
+n:=0;
+loop@+ begin change_changing; {now it's |true|}
+ incr(line);
+ if not input_ln(change_file) then
+ begin err_print('! Change file ended before @@y');
+@.Change file ended...@>
+ change_limit:=0; change_changing; {|false| again}
+ return;
+ end;
+ @<If the current line starts with \.{@@y},
+ report any discrepancies and |return|@>;
+ @<Move |buffer| and |limit|...@>;
+ change_changing; {now it's |false|}
+ incr(line);
+ if not input_ln(web_file) then
+ begin err_print('! WEB file ended during a change');
+@.WEB file ended...@>
+ input_has_ended:=true; return;
+ end;
+ if lines_dont_match then incr(n);
+ end;
+exit: end;
+
+@ @<If the current line starts with \.{@@y}...@>=
+if limit>1 then if buffer[0]="@@" then
+ begin if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if (buffer[1]="x")or(buffer[1]="z") then
+ begin loc:=2; err_print('! Where is the matching @@y?');
+@.Where is the match...@>
+ end
+ else if buffer[1]="y" then
+ begin if n>0 then
+ begin loc:=2; err_print('! Hmm... ',n:1,
+ ' of the preceding lines failed to match');
+@.Hmm... n of the preceding...@>
+ end;
+ return;
+ end;
+ end
+
+@ @<Initialize the input system@>=
+open_input; line:=0; other_line:=0;@/
+changing:=true; prime_the_change_buffer; change_changing;@/
+limit:=0; loc:=1; buffer[0]:=" "; input_has_ended:=false;
+
+@ The |get_line| procedure is called when |loc>limit|; it puts the next
+line of merged input into the buffer and updates the other variables
+appropriately. A space is placed at the right end of the line.
+
+@p procedure get_line; {inputs the next line}
+label restart;
+begin restart: if changing then
+ @<Read from |change_file| and maybe turn off |changing|@>;
+if not changing then
+ begin @<Read from |web_file| and maybe turn on |changing|@>;
+ if changing then goto restart;
+ end;
+loc:=0; buffer[limit]:=" ";
+end;
+
+@ @<Read from |web_file|...@>=
+begin incr(line);
+if not input_ln(web_file) then input_has_ended:=true
+else if limit=change_limit then
+ if buffer[0]=change_buffer[0] then
+ if change_limit>0 then check_change;
+end
+
+@ @<Read from |change_file|...@>=
+begin incr(line);
+if not input_ln(change_file) then
+ begin err_print('! Change file ended without @@z');
+@.Change file ended...@>
+ buffer[0]:="@@"; buffer[1]:="z"; limit:=2;
+ end;
+if limit>1 then {check if the change has ended}
+ if buffer[0]="@@" then
+ begin if (buffer[1]>="X")and(buffer[1]<="Z") then
+ buffer[1]:=buffer[1]+"z"-"Z"; {lowercasify}
+ if (buffer[1]="x")or(buffer[1]="y") then
+ begin loc:=2; err_print('! Where is the matching @@z?');
+@.Where is the match...@>
+ end
+ else if buffer[1]="z" then
+ begin prime_the_change_buffer; change_changing;
+ end;
+ end;
+end
+
+@ At the end of the program, we will tell the user if the change file
+had a line that didn't match any relevant line in |web_file|.
+
+@<Check that all changes have been read@>=
+if change_limit<>0 then {|changing| is false}
+ begin for ii:=0 to change_limit do buffer[ii]:=change_buffer[ii];
+ limit:=change_limit; changing:=true; line:=other_line; loc:=change_limit;
+ err_print('! Change file entry did not match');
+@.Change file entry did not match@>
+ end
+
+@ Important milestones are reached during the input phase when certain
+control codes are sensed.
+
+Control codes in \.{WEB} begin with `\.{@@}', and the next character
+identifies the code. Some of these are of interest only to \.{WEAVE},
+so \.{TANGLE} ignores them; the others are converted by \.{TANGLE} into
+internal code numbers by the |control_code| function below. The ordering
+of these internal code numbers has been chosen to simplify the program logic;
+larger numbers are given to the control codes that denote more significant
+milestones.
+
+@d ignore=0 {control code of no interest to \.{TANGLE}}
+@d control_text=@'203 {control code for `\.{@@t}', `\.{@@\^}', etc.}
+@d format=@'204 {control code for `\.{@@f}'}
+@d definition=@'205 {control code for `\.{@@d}'}
+@d begin_Pascal=@'206 {control code for `\.{@@p}'}
+@d module_name=@'207 {control code for `\.{@@<}'}
+@d new_module=@'210 {control code for `\.{@@\ }' and `\.{@@*}'}
+
+@p function control_code(@!c:ASCII_code):eight_bits; {convert |c| after \.{@@}}
+begin case c of
+"@@": control_code:="@@"; {`quoted' at sign}
+"'": control_code:=octal; {precedes octal constant}
+"""": control_code:=hex; {precedes hexadecimal constant}
+"$": control_code:=check_sum; {string pool check sum}
+" ",tab_mark: control_code:=new_module; {beginning of a new module}
+"*": begin print('*',module_count+1:1);
+ update_terminal; {print a progress report}
+ control_code:=new_module; {beginning of a new module}
+ end;
+"D","d": control_code:=definition; {macro definition}
+"F","f": control_code:=format; {format definition}
+"{": control_code:=begin_comment; {begin-comment delimiter}
+"}": control_code:=end_comment; {end-comment delimiter}
+"P","p": control_code:=begin_Pascal; {\PASCAL\ text in unnamed module}
+"T","t","^",".",":": control_code:=control_text; {control text to be ignored}
+"&": control_code:=join; {concatenate two tokens}
+"<": control_code:=module_name; {beginning of a module name}
+"=": control_code:=verbatim; {beginning of \PASCAL\ verbatim mode}
+"\": control_code:=force_line; {force a new line in \PASCAL\ output}
+othercases control_code:=ignore {ignore all other cases}
+endcases;
+end;
+
+@ The |skip_ahead| procedure reads through the input at fairly high speed
+until finding the next non-ignorable control code, which it returns.
+
+@p function skip_ahead:eight_bits; {skip to next control code}
+label done;
+var c:eight_bits; {control code found}
+begin loop begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin c:=new_module; goto done;
+ end;
+ end;
+ buffer[limit+1]:="@@";
+ while buffer[loc]<>"@@" do incr(loc);
+ if loc<=limit then
+ begin loc:=loc+2; c:=control_code(buffer[loc-1]);
+ if (c<>ignore)or(buffer[loc-1]=">") then goto done;
+ end;
+ end;
+done: skip_ahead:=c;
+end;
+
+@ The |skip_comment| procedure reads through the input at somewhat high speed
+until finding the first unmatched right brace or until coming to the end
+of the file. It ignores characters following `\.\\' characters, since all
+braces that aren't nested are supposed to be hidden in that way. For
+example, consider the process of skipping the first comment below,
+where the string containing the right brace has been typed as \.{\`\\.\\\}\'}
+in the \.{WEB} file.
+
+@p procedure skip_comment; {skips to next unmatched `\.\}'}
+label exit;
+var bal:eight_bits; {excess of left braces}
+@!c:ASCII_code; {current character}
+begin bal:=0;
+loop@+ begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin err_print('! Input ended in mid-comment');
+@.Input ended in mid-comment@>
+ return;
+ end;
+ end;
+ c:=buffer[loc]; incr(loc);
+ @<Do special things when |c="@@", "\", "{", "}"|; |return| at end@>;
+ end;
+exit:end;
+
+@ @<Do special things when |c="@@"...@>=
+if c="@@" then
+ begin c:=buffer[loc];
+ if (c<>" ")and(c<>tab_mark)and(c<>"*")and(c<>"z")and(c<>"Z") then incr(loc)
+ else begin err_print('! Section ended in mid-comment');
+@.Section ended in mid-comment@>
+ decr(loc); return;
+ end
+ end
+else if (c="\")and(buffer[loc]<>"@@") then incr(loc)
+else if c="{" then incr(bal)
+else if c="}" then
+ begin if bal=0 then return;
+ decr(bal);
+ end
+
+@* Inputting the next token.
+As stated above, \.{TANGLE}'s most interesting input procedure is the
+|get_next| routine that inputs the next token. However, the procedure
+isn't especially difficult.
+
+In most cases the tokens output by |get_next| have the form used in
+replacement texts, except that two-byte tokens are not produced.
+An identifier that isn't one letter long is represented by the
+output `|identifier|', and in such a case the global variables
+|id_first| and |id_loc| will have been set to the appropriate values
+needed by the |id_lookup| procedure. A string that begins with a
+double-quote is also considered an |identifier|, and in such a case
+the global variable |double_chars| will also have been set appropriately.
+Control codes produce the corresponding output of the |control_code|
+function above; and if that code is |module_name|, the value of |cur_module|
+will point to the |byte_start| entry for that module name.
+
+Another global variable, |scanning_hex|, is |true| during the time that
+the letters \.A through \.F should be treated as if they were digits.
+
+@<Globals...@>=
+@!cur_module: name_pointer; {name of module just scanned}
+@!scanning_hex: boolean; {are we scanning a hexadecimal constant?}
+
+@ @<Set init...@>=
+scanning_hex:=false;
+
+@ At the top level, |get_next| is a multi-way switch based on the next
+character in the input buffer. A |new_module| code is inserted at the
+very end of the input file.
+
+@p function get_next:eight_bits; {produces the next input token}
+label restart,done,found;
+var c:eight_bits; {the current character}
+@!d:eight_bits; {the next character}
+@!j,@!k:0..longest_name; {indices into |mod_text|}
+begin restart: if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin c:=new_module; goto found;
+ end;
+ end;
+c:=buffer[loc]; incr(loc);
+if scanning_hex then @<Go to |found| if |c| is a hexadecimal digit,
+ otherwise set |scanning_hex:=false|@>;
+case c of
+"A",up_to("Z"),"a",up_to("z"): @<Get an identifier@>;
+"""": @<Get a preprocessed string@>;
+"@@": @<Get control code and possible module name@>;
+@t\4@>@<Compress two-symbol combinations like `\.{:=}'@>@;
+" ",tab_mark: goto restart; {ignore spaces and tabs}
+"{": begin skip_comment; goto restart;
+ end;
+"}": begin err_print('! Extra }'); goto restart;
+@.Extra \}@>
+ end;
+othercases if c>=128 then goto restart {ignore nonstandard characters}
+ else do_nothing
+endcases;
+found:@!debug if trouble_shooting then debug_help;@;@+gubed@/
+get_next:=c;
+end;
+
+@ @<Go to |found| if |c| is a hexadecimal digit...@>=
+if ((c>="0")and(c<="9"))or((c>="A")and(c<="F")) then goto found
+else scanning_hex:=false
+
+@ Note that the following code substitutes \.{@@\{} and \.{@@\}} for the
+respective combinations `\.{(*}' and `\.{*)}'. Explicit braces should be used
+for \TeX\ comments in \PASCAL\ text.
+
+@d compress(#)==begin if loc<=limit then begin c:=#; incr(loc); end; end
+
+@<Compress two-symbol...@>=
+".": if buffer[loc]="." then compress(double_dot)
+ else if buffer[loc]=")" then compress("]");
+":": if buffer[loc]="=" then compress(left_arrow);
+"=": if buffer[loc]="=" then compress(equivalence_sign);
+">": if buffer[loc]="=" then compress(greater_or_equal);
+"<": if buffer[loc]="=" then compress(less_or_equal)
+ else if buffer[loc]=">" then compress(not_equal);
+"(": if buffer[loc]="*" then compress(begin_comment)
+ else if buffer[loc]="." then compress("[");
+"*": if buffer[loc]=")" then compress(end_comment);
+
+@ We have to look at the preceding character to make sure this isn't part
+of a real constant, before trying to find an identifier starting with
+`\.e' or `\.E'.
+
+@<Get an identifier@>=
+begin if ((c="e")or(c="E"))and(loc>1) then
+ if (buffer[loc-2]<="9")and(buffer[loc-2]>="0") then c:=0;
+if c<>0 then
+ begin decr(loc); id_first:=loc;
+ repeat incr(loc); d:=buffer[loc];
+ until ((d<"0")or((d>"9")and(d<"A"))or((d>"Z")and(d<"a"))or(d>"z")) and
+ (d<>"_");
+ if loc>id_first+1 then
+ begin c:=identifier; id_loc:=loc;
+ end;
+ end
+else c:="E"; {exponent of a real constant}
+end
+
+@ A string that starts and ends with double-quote marks is converted into
+an identifier that behaves like a numeric macro by means of the following
+piece of the program.
+@^preprocessed strings@>
+
+@<Get a preprocessed string@>=
+begin double_chars:=0; id_first:=loc-1;
+repeat d:=buffer[loc]; incr(loc);
+ if (d="""")or(d="@@") then
+ if buffer[loc]=d then
+ begin incr(loc); d:=0; incr(double_chars);
+ end
+ else begin if d="@@" then err_print('! Double @@ sign missing')
+@.Double \AT! sign missing@>
+ end
+ else if loc>limit then
+ begin err_print('! String constant didn''t end'); d:="""";
+@.String constant didn't end@>
+ end;
+until d="""";
+id_loc:=loc-1; c:=identifier;
+end
+
+@ After an \.{@@} sign has been scanned, the next character tells us
+whether there is more work to do.
+
+@<Get control code and possible module name@>=
+begin c:=control_code(buffer[loc]); incr(loc);
+if c=ignore then goto restart
+else if c=hex then scanning_hex:=true
+else if c=module_name then
+ @<Scan the \(module name and make |cur_module| point to it@>
+else if c=control_text then
+ begin repeat c:=skip_ahead;
+ until c<>"@@";
+ if buffer[loc-1]<>">" then
+ err_print('! Improper @@ within control text');
+@.Improper \AT! within control text@>
+ goto restart;
+ end;
+end
+
+@ @<Scan the \(module name...@>=
+begin @<Put module name into |mod_text[1..k]|@>;
+if k>3 then
+ begin if (mod_text[k]=".")and(mod_text[k-1]=".")and(mod_text[k-2]=".") then
+ cur_module:=prefix_lookup(k-3)
+ else cur_module:=mod_lookup(k);
+ end
+else cur_module:=mod_lookup(k);
+end
+
+@ Module names are placed into the |mod_text| array with consecutive spaces,
+tabs, and carriage-returns replaced by single spaces. There will be no
+spaces at the beginning or the end. (We set |mod_text[0]:=" "| to facilitate
+this, since the |mod_lookup| routine uses |mod_text[1]| as the first
+character of the name.)
+
+@<Set init...@>=mod_text[0]:=" ";
+
+@ @<Put module name...@>=
+k:=0;
+loop@+ begin if loc>limit then
+ begin get_line;
+ if input_has_ended then
+ begin err_print('! Input ended in section name');
+@.Input ended in section name@>
+ goto done;
+ end;
+ end;
+ d:=buffer[loc];
+ @<If end of name, |goto done|@>;
+ incr(loc); if k<longest_name-1 then incr(k);
+ if (d=" ")or(d=tab_mark) then
+ begin d:=" "; if mod_text[k-1]=" " then decr(k);
+ end;
+ mod_text[k]:=d;
+ end;
+done: @<Check for overlong name@>;
+if (mod_text[k]=" ")and(k>0) then decr(k);
+
+@ @<If end of name,...@>=
+if d="@@" then
+ begin d:=buffer[loc+1];
+ if d=">" then
+ begin loc:=loc+2; goto done;
+ end;
+ if (d=" ")or(d=tab_mark)or(d="*") then
+ begin err_print('! Section name didn''t end'); goto done;
+@.Section name didn't end@>
+ end;
+ incr(k); mod_text[k]:="@@"; incr(loc); {now |d=buffer[loc]| again}
+ end
+
+@ @<Check for overlong name@>=
+if k>=longest_name-2 then
+ begin print_nl('! Section name too long: ');
+@.Section name too long@>
+ for j:=1 to 25 do print(xchr[mod_text[j]]);
+ print('...'); mark_harmless;
+ end
+
+@* Scanning a numeric definition.
+When \.{TANGLE} looks at the \PASCAL\ text following the `\.=' of a numeric
+macro definition, it calls on the precedure |scan_numeric(p)|, where |p|
+points to the name that is to be defined. This procedure evaluates the
+right-hand side, which must consist entirely of integer constants and
+defined numeric macros connected with \.+ and \.- signs (no parentheses).
+It also sets the global variable |next_control| to the control code that
+terminated this definition.
+
+A definition ends with the control codes |definition|, |format|, |module_name|,
+|begin_Pascal|, and |new_module|, all of which can be recognized
+by the fact that they are the largest values |get_next| can return.
+
+@d end_of_definition(#)==(#>=format)
+ {is |#| a control code ending a definition?}
+
+@<Global...@>=
+@!next_control:eight_bits; {control code waiting to be acted upon}
+
+@ The evaluation of a numeric expression makes use of two variables called the
+|accumulator| and the |next_sign|. At the beginning, |accumulator| is zero and
+|next_sign| is $+1$. When a \.+ or \.- is scanned, |next_sign| is multiplied
+by the value of that sign. When a numeric value is scanned, it is multiplied by
+|next_sign| and added to the |accumulator|, then |next_sign| is reset to $+1$.
+
+@d add_in(#)==begin accumulator:=accumulator+next_sign*(#); next_sign:=+1;
+ end
+
+@p procedure scan_numeric(@!p:name_pointer); {defines numeric macros}
+label reswitch, done;
+var accumulator:integer; {accumulates sums}
+@!next_sign:-1..+1; {sign to attach to next value}
+@!q:name_pointer; {points to identifiers being evaluated}
+@!val:integer; {constants being evaluated}
+begin @<Set \(|accumulator| to the value of the right-hand side@>;
+if abs(accumulator)>=1073741824 then
+ begin err_print('! Value too big: ',accumulator:1); accumulator:=0;
+@.Value too big@>
+ end;
+equiv[p]:=accumulator+1073741824;
+ {name |p| now is defined to equal |accumulator|}
+end;
+
+@ @<Set \(|accumulator| to the value of the right-hand side@>=
+accumulator:=0; next_sign:=+1;
+loop@+ begin next_control:=get_next;
+ reswitch: case next_control of
+ digits: begin @<Set |val| to value of decimal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ octal: begin @<Set |val| to value of octal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ hex: begin @<Set |val| to value of hexadecimal constant, and
+ set |next_control| to the following token@>;
+ add_in(val); goto reswitch;
+ end;
+ identifier: begin q:=id_lookup(normal);
+ if ilk[q]<>numeric then
+ begin next_control:="*"; goto reswitch; {leads to error}
+ end;
+ add_in(equiv[q]-1073741824);
+ end;
+ "+": do_nothing;
+ "-": next_sign:=-next_sign;
+ format, definition, module_name, begin_Pascal, new_module: goto done;
+ ";": err_print('! Omit semicolon in numeric definition');
+@.Omit semicolon in numeric def...@>
+ othercases @<Signal error, flush rest of the definition@>
+ endcases;
+ end;
+done:
+
+@ @<Signal error, flush rest...@>=
+begin err_print('! Improper numeric definition will be flushed');
+@.Improper numeric definition...@>
+repeat next_control:=skip_ahead
+until end_of_definition(next_control);
+if next_control=module_name then
+ begin {we want to scan the module name too}
+ loc:=loc-2; next_control:=get_next;
+ end;
+accumulator:=0; goto done;
+end
+
+@ @<Set |val| to value of decimal...@>=
+val:=0;
+repeat val:=10*val+next_control-"0"; next_control:=get_next;
+until (next_control>"9")or(next_control<"0")
+
+@ @<Set |val| to value of octal...@>=
+val:=0; next_control:="0";
+repeat val:=8*val+next_control-"0"; next_control:=get_next;
+until (next_control>"7")or(next_control<"0")
+
+@ @<Set |val| to value of hex...@>=
+val:=0; next_control:="0";
+repeat if next_control>="A" then next_control:=next_control+"0"+10-"A";
+val:=16*val+next_control-"0"; next_control:=get_next;
+until (next_control>"F")or(next_control<"0")or@|
+ ((next_control>"9")and(next_control<"A"))
+
+@* Scanning a macro definition.
+The rules for generating the replacement texts corresponding to simple
+macros, parametric macros, and \PASCAL\ texts of a module are almost
+identical, so a single procedure is used for all three cases. The
+differences are that
+
+\yskip\item{a)} The sign |#| denotes a parameter only when it appears
+outside of strings in a parametric macro; otherwise it stands for the
+ASCII character |#|. (This is not used in standard \PASCAL, but some
+\PASCAL s allow, for example, `\.{/\#}' after a certain kind of file name.)
+
+\item{b)}Module names are not allowed in simple macros or parametric macros;
+in fact, the appearance of a module name terminates such macros and denotes
+the name of the current module.
+
+\item{c)}The symbols \.{@@d} and \.{@@f} and \.{@@p} are not allowed after
+module names, while they terminate macro definitions.
+
+@ Therefore there is a procedure |scan_repl| whose parameter |t| specifies
+either |simple| or |parametric| or |module_name|. After |scan_repl| has
+acted, |cur_repl_text| will point to the replacement text just generated, and
+|next_control| will contain the control code that terminated the activity.
+
+@<Globals...@>=
+@!cur_repl_text:text_pointer; {replacement text formed by |scan_repl|}
+
+@ @p procedure scan_repl(@!t:eight_bits); {creates a replacement text}
+label continue, done, found, reswitch;
+var a:sixteen_bits; {the current token}
+@!b:ASCII_code; {a character from the buffer}
+@!bal:eight_bits; {left parentheses minus right parentheses}
+begin bal:=0;
+loop@+ begin continue: a:=get_next;
+ case a of
+ "(": incr(bal);
+ ")": if bal=0 then err_print('! Extra )')
+@.Extra )@>
+ else decr(bal);
+ "'": @<Copy a string from the buffer to |tok_mem|@>;
+ "#": if t=parametric then a:=param;
+ @t\4@>@<In cases that |a| is a non-ASCII token (|identifier|,
+ |module_name|, etc.), either process it and change |a| to a byte
+ that should be stored, or |goto continue| if |a| should be ignored,
+ or |goto done| if |a| signals the end of this replacement text@>@;
+ othercases do_nothing
+ endcases;@/
+ app_repl(a); {store |a| in |tok_mem|}
+ end;
+done: next_control:=a;
+@<Make sure the parentheses balance@>;
+if text_ptr>max_texts-zz then overflow('text');
+cur_repl_text:=text_ptr; tok_start[text_ptr+zz]:=tok_ptr[z];
+incr(text_ptr);
+if z=zz-1 then z:=0@+else incr(z);
+end;
+
+@ @<Make sure the parentheses balance@>=
+if bal>0 then
+ begin if bal=1 then err_print('! Missing )')
+ else err_print('! Missing ',bal:1,' )''s');
+@.Missing n )@>
+ while bal>0 do
+ begin app_repl(")"); decr(bal);
+ end;
+ end
+
+@ @<In cases that |a| is...@>=
+identifier: begin a:=id_lookup(normal); app_repl((a div @'400)+@'200);
+ a:=a mod @'400;
+ end;
+module_name: if t<>module_name then goto done
+ else begin app_repl((cur_module div @'400)+@'250);
+ a:=cur_module mod @'400;
+ end;
+verbatim: @<Copy verbatim string from the buffer to |tok_mem|@>;
+definition, format, begin_Pascal: if t<>module_name then goto done
+ else begin err_print('! @@',xchr[buffer[loc-1]],
+@.\AT!p is ignored in Pascal text@>
+@.\AT!d is ignored in Pascal text@>
+@.\AT!f is ignored in Pascal text@>
+ ' is ignored in Pascal text'); goto continue;
+ end;
+new_module: goto done;
+
+@ @<Copy a string...@>=
+begin b:="'";
+loop@+ begin app_repl(b);
+ if b="@@" then
+ if buffer[loc]="@@" then incr(loc) {store only one \.{@@}}
+ else err_print('! You should double @@ signs in strings');
+@.You should double \AT! signs@>
+ if loc=limit then
+ begin err_print('! String didn''t end');
+@.String didn't end@>
+ buffer[loc]:="'"; buffer[loc+1]:=0;
+ end;
+ b:=buffer[loc]; incr(loc);
+ if b="'" then
+ begin if buffer[loc]<>"'" then goto found
+ else begin incr(loc); app_repl("'");
+ end;
+ end;
+ end;
+found: end {now |a| holds the final |"'"| that will be stored}
+
+@ @<Copy verbatim string...@>=
+begin app_repl(verbatim);
+buffer[limit+1]:="@@";
+reswitch: if buffer[loc]="@@" then
+ begin if loc<limit then if buffer[loc+1]="@@" then
+ begin app_repl("@@");
+ loc:=loc+2;
+ goto reswitch;
+ end;
+ end
+else begin app_repl(buffer[loc]);
+ incr(loc);
+ goto reswitch;
+ end;
+if loc>=limit then err_print('! Verbatim string didn''t end')
+@.Verbatim string didn't end@>
+else if buffer[loc+1]<>">" then
+ err_print('! You should double @@ signs in verbatim strings');
+@.You should double \AT! signs@>
+loc:=loc+2;
+end {another |verbatim| byte will be stored, since |a=verbatim|}
+
+@ The following procedure is used to define a simple or parametric macro,
+just after the `\.{==}' of its definition has been scanned.
+
+@p procedure define_macro(@!t:eight_bits);
+var p:name_pointer; {the identifier being defined}
+begin p:=id_lookup(t); scan_repl(t);@/
+equiv[p]:=cur_repl_text; text_link[cur_repl_text]:=0;
+end;
+
+@* Scanning a module.
+The |scan_module| procedure starts when `\.{@@\ }' or `\.{@@*}' has been
+sensed in the input, and it proceeds until the end of that module. It
+uses |module_count| to keep track of the current module number; with luck,
+\.{WEAVE} and \.{TANGLE} will both assign the same numbers to modules.
+
+@<Globals...@>=
+@!module_count:0..@'27777; {the current module number}
+
+@ The top level of |scan_module| is trivial.
+@p procedure scan_module;
+label continue, done, exit;
+var p:name_pointer; {module name for the current module}
+begin incr(module_count);
+@<Scan the \(definition part of the current module@>;
+@<Scan the \PASCAL\ part of the current module@>;
+exit: end;
+
+@ @<Scan the \(definition part...@>=
+next_control:=0;
+loop@+ begin continue: while next_control<=format do
+ begin next_control:=skip_ahead;
+ if next_control=module_name then
+ begin {we want to scan the module name too}
+ loc:=loc-2; next_control:=get_next;
+ end;
+ end;
+ if next_control<>definition then goto done;
+ next_control:=get_next; {get identifier name}
+ if next_control<>identifier then
+ begin err_print('! Definition flushed, must start with ',
+@.Definition flushed...@>
+ 'identifier of length > 1'); goto continue;
+ end;
+ next_control:=get_next; {get token after the identifier}
+ if next_control="=" then
+ begin scan_numeric(id_lookup(numeric)); goto continue;
+ end
+ else if next_control=equivalence_sign then
+ begin define_macro(simple); goto continue;
+ end
+ else @<If the next text is `|(#)==|', call |define_macro|
+ and |goto continue|@>;
+ err_print('! Definition flushed since it starts badly');
+@.Definition flushed...@>
+ end;
+done:
+
+@ @<If the next text is `|(#)==|'...@>=
+if next_control="(" then
+ begin next_control:=get_next;
+ if next_control="#" then
+ begin next_control:=get_next;
+ if next_control=")" then
+ begin next_control:=get_next;
+ if next_control="=" then
+ begin err_print('! Use == for macros');
+@.Use == for macros@>
+ next_control:=equivalence_sign;
+ end;
+ if next_control=equivalence_sign then
+ begin define_macro(parametric); goto continue;
+ end;
+ end;
+ end;
+ end;
+
+@ @<Scan the \PASCAL...@>=
+case next_control of
+begin_Pascal:p:=0;
+module_name: begin p:=cur_module;
+ @<Check that |=| or |==| follows this module name, otherwise |return|@>;
+ end;
+othercases return
+endcases;@/
+@<Insert the module number into |tok_mem|@>;
+scan_repl(module_name); {now |cur_repl_text| points to the replacement text}
+@<Update the data structure so that the replacement text is accessible@>;
+
+@ @<Check that |=|...@>=
+repeat next_control:=get_next;
+until next_control<>"+"; {allow optional `\.{+=}'}
+if (next_control<>"=")and(next_control<>equivalence_sign) then
+ begin err_print('! Pascal text flushed, = sign is missing');
+@.Pascal text flushed...@>
+ repeat next_control:=skip_ahead;
+ until next_control=new_module;
+ return;
+ end
+
+@ @<Insert the module number...@>=
+store_two_bytes(@'150000+module_count); {|@'150000=@'320*@'400|}
+
+@ @<Update the data...@>=
+if p=0 then {unnamed module}
+ begin text_link[last_unnamed]:=cur_repl_text; last_unnamed:=cur_repl_text;
+ end
+else if equiv[p]=0 then equiv[p]:=cur_repl_text {first module of this name}
+else begin p:=equiv[p];
+ while text_link[p]<module_flag do p:=text_link[p]; {find end of list}
+ text_link[p]:=cur_repl_text;
+ end;
+text_link[cur_repl_text]:=module_flag;
+ {mark this replacement text as a nonmacro}
+
+@* Debugging.
+The \PASCAL\ debugger with which \.{TANGLE} was developed allows breakpoints
+to be set, and variables can be read and changed, but procedures cannot be
+executed. Therefore a `|debug_help|' procedure has been inserted in the main
+loops of each phase of the program; when |ddt| and |dd| are set to appropriate
+values, symbolic printouts of various tables will appear.
+
+The idea is to set a breakpoint inside the |debug_help| routine, at the
+place of `\ignorespaces|breakpoint:|\unskip' below. Then when
+|debug_help| is to be activated, set |trouble_shooting| equal to |true|.
+The |debug_help| routine will prompt you for values of |ddt| and |dd|,
+discontinuing this when |ddt<=0|; thus you type $2n+1$ integers, ending
+with zero or a negative number. Then control either passes to the
+breakpoint, allowing you to look at and/or change variables (if you typed
+zero), or to exit the routine (if you typed a negative value).
+
+Another global variable, |debug_cycle|, can be used to skip silently
+past calls on |debug_help|. If you set |debug_cycle>1|, the program stops
+only every |debug_cycle| times |debug_help| is called; however,
+any error stop will set |debug_cycle| to zero.
+
+@<Globals...@>=
+@!debug@!trouble_shooting:boolean; {is |debug_help| wanted?}
+@!ddt:integer; {operation code for the |debug_help| routine}
+@!dd:integer; {operand in procedures performed by |debug_help|}
+@!debug_cycle:integer; {threshold for |debug_help| stopping}
+@!debug_skipped:integer; {we have skipped this many |debug_help| calls}
+@!term_in:text_file; {the user's terminal as an input file}
+gubed
+
+@ The debugging routine needs to read from the user's terminal.
+@^system dependencies@>
+@<Set init...@>=
+@!debug trouble_shooting:=true; debug_cycle:=1; debug_skipped:=0;@/
+trouble_shooting:=false; debug_cycle:=99999; {use these when it almost works}
+reset(term_in,'TTY:','/I'); {open |term_in| as the terminal, don't do a |get|}
+gubed
+
+@ @d breakpoint=888 {place where a breakpoint is desirable}
+@^system dependencies@>
+
+@p @!debug procedure debug_help; {routine to display various things}
+label breakpoint,exit;
+var k:integer; {index into various arrays}
+begin incr(debug_skipped);
+if debug_skipped<debug_cycle then return;
+debug_skipped:=0;
+loop@+ begin write(term_out,'#'); update_terminal; {prompt}
+ read(term_in,ddt); {read a list of integers}
+ if ddt<0 then return
+ else if ddt=0 then
+ begin goto breakpoint;@\ {go to every label at least once}
+ breakpoint: ddt:=0;@\
+ end
+ else begin read(term_in,dd);
+ case ddt of
+ 1: print_id(dd);
+ 2: print_repl(dd);
+ 3: for k:=1 to dd do print(xchr[buffer[k]]);
+ 4: for k:=1 to dd do print(xchr[mod_text[k]]);
+ 5: for k:=1 to out_ptr do print(xchr[out_buf[k]]);
+ 6: for k:=1 to dd do print(xchr[out_contrib[k]]);
+ othercases print('?')
+ endcases;
+ end;
+ end;
+exit:end;
+gubed
+
+@* The main program.
+We have defined plenty of procedures, and it is time to put the last
+pieces of the puzzle in place. Here is where \.{TANGLE} starts, and where
+it ends.
+@^system dependencies@>
+
+@p begin initialize;
+@<Initialize the input system@>;
+print_ln(banner); {print a ``banner line''}
+@<Phase I: Read all the user's text and compress it into |tok_mem|@>;
+stat for ii:=0 to zz-1 do max_tok_ptr[ii]:=tok_ptr[ii];@+tats@;@/
+@<Phase II:...@>;
+end_of_TANGLE:
+if string_ptr>number_chars then @<Finish off the string pool file@>;
+stat @<Print statistics about memory usage@>;@+tats@;@/
+@t\4\4@>{here files should be closed if the operating system requires it}
+@<Print the job |history|@>;
+end.
+
+@ @<Phase I:...@>=
+phase_one:=true;
+module_count:=0;
+repeat next_control:=skip_ahead;
+until next_control=new_module;
+while not input_has_ended do scan_module;
+@<Check that all changes have been read@>;
+phase_one:=false;
+
+@ @<Finish off the string pool file@>=
+begin print_nl(string_ptr-number_chars:1,
+ ' strings written to string pool file.');
+write(pool,'*');
+for ii:=1 to 9 do
+ begin out_buf[ii]:=pool_check_sum mod 10;
+ pool_check_sum:=pool_check_sum div 10;
+ end;
+for ii:=9 downto 1 do write(pool,xchr["0"+out_buf[ii]]);
+write_ln(pool);
+end
+
+@ @<Glob...@>=
+stat @!wo:0..ww-1; {segment of memory for which statistics are being printed}
+tats
+
+@ @<Print statistics about memory usage@>=
+print_nl('Memory usage statistics:');
+print_nl(name_ptr:1, ' names, ', text_ptr:1, ' replacement texts;');
+print_nl(byte_ptr[0]:1);
+for wo:=1 to ww-1 do print('+',byte_ptr[wo]:1);
+if phase_one then
+ for ii:=0 to zz-1 do max_tok_ptr[ii]:=tok_ptr[ii];
+print(' bytes, ', max_tok_ptr[0]:1);
+for ii:=1 to zz-1 do print('+',max_tok_ptr[ii]:1);
+print(' tokens.');
+
+@ Some implementations may wish to pass the |history| value to the
+operating system so that it can be used to govern whether or not other
+programs are started. Here we simply report the history to the user.
+@^system dependencies@>
+
+@<Print the job |history|@>=
+case history of
+spotless: print_nl('(No errors were found.)');
+harmless_message: print_nl('(Did you see the warning message above?)');
+error_message: print_nl('(Pardon me, but I think I spotted something wrong.)');
+fatal_message: print_nl('(That was a fatal error, my friend.)');
+end {there are no other cases}
+
+@* System-dependent changes.
+This module should be replaced, if necessary, by changes to the program
+that are necessary to make \.{TANGLE} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous modules preserve the module numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new modules, can be inserted here; then only the index
+itself will get a new module number.
+@^system dependencies@>
+
+@* Index.
+Here is a cross-reference table for the \.{TANGLE} processor.
+All modules in which an identifier is
+used are listed with that identifier, except that reserved words are
+indexed only when they appear in format definitions, and the appearances
+of identifiers in module names are not indexed. Underlined entries
+correspond to where the identifier was declared. Error messages and
+a few other things like ``ASCII code'' are indexed here too.
diff --git a/Build/source/texk/web2c/omegaware/ovf2ovp.ch b/Build/source/texk/web2c/omegaware/ovf2ovp.ch
new file mode 100644
index 00000000000..4c2c3effb3d
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ovf2ovp.ch
@@ -0,0 +1,610 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original vftovp.ch.
+%
+% vftovp.ch for C compilation with web2c.
+% Written by kb@cs.umb.edu.
+% This file is in the public domain.
+
+@x [0] WEAVE: print changes only.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+%\let\maybe=\iffalse
+%\def\title{VF$\,$\lowercase{to}$\,$VP changes for C}
+@z
+
+@x still [2] Set up for path reading.
+procedure initialize; {this procedure gets things started properly}
+ var @!k:integer; {all-purpose index for initialization}
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ var @!k:integer; {all-purpose index for initialization}
+ begin
+ kpse_set_progname (argv[0]);
+ kpse_init_prog ('VFTOVP', 0, nil, nil);
+ parse_arguments;
+@z
+
+% [4] No name_length.
+% Also, AIX defines `class' in <math.h>, so let's take this opportunity to
+% define that away.
+@x
+@<Constants...@>=
+@y
+@d class == class_var
+@<Constants...@>=
+@z
+
+@x
+@!name_length=50; {a file name shouldn't be longer than this}
+@y
+@z
+
+@x [11] Open the files.
+@ On some systems you may have to do something special to read a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+reset(tfm_file); reset(vf_file);
+@y
+@ We don't have to do anything special to read a packed file of bytes,
+but we do want to use environment variables to find the input files.
+@^system dependencies@>
+
+@<Set init...@>=
+{See comments at |kpse_find_vf| in \.{kpathsea/tex-file.h} for why we
+ don't use it.}
+vf_file := kpse_open_file (vf_name, kpse_ovf_format);
+tfm_file := kpse_open_file (tfm_name, kpse_ofm_format);
+
+if verbose then begin
+ print (banner);
+ print_ln (version_string);
+end;
+@z
+
+@x [21] Open VPL file.
+@!vpl_file:text;
+
+@ @<Set init...@>=
+rewrite(vpl_file);
+@y
+@!vpl_file:text;
+
+@ If an explicit filename isn't given, we write to |stdout|.
+
+@<Set init...@>=
+if optind + 3 > argc then begin
+ vpl_file := stdout;
+end else begin
+ vpl_name := extend_filename (cmdline (optind + 2), 'ovp');
+ rewrite (vpl_file, vpl_name);
+end;
+@z
+
+% [24] `index' is not a good choice of identifier in C.
+@x
+@<Types...@>=
+@!index=0..tfm_size; {address of a byte in |tfm|}
+@y
+@d index == index_type
+
+@<Types...@>=
+@!index=0..tfm_size; {address of a byte in |tfm|}
+@z
+
+% [24] abort() should cause a bad exit code.
+@x
+@d abort(#)==begin print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OFM?');
+ goto final_end;
+ end
+@y
+@d abort(#)==begin print_ln(#);
+ write_ln(stderr, 'Sorry, but I can''t go on; are you sure this is a OFM?');
+ uexit(1);
+ end
+@z
+
+% [31] Ditto for vf_abort.
+@x
+@d vf_abort(#)==begin
+ print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OVF?');
+ goto final_end;
+ end
+@y
+@d vf_abort(#)==begin
+ write_ln(stderr, #);
+ write_ln(stderr, 'Sorry, but I can''t go on; are you sure this is a OVF?');
+ uexit(1);
+ end
+@z
+
+@x [32] Be quiet if not -verbose.
+for k:=0 to vf_ptr-1 do print(xchr[vf[k]]);
+print_ln(' '); reg_count:=0;
+@y
+if verbose then begin
+ for k:=0 to vf_ptr-1 do print(xchr[vf[k]]);
+ print_ln(' ');
+end;
+reg_count:=0;
+@z
+
+@x [35] Be quiet if not -verbose.
+@<Print the name of the local font@>;
+@y
+if verbose then begin
+ @<Print the name of the local font@>;
+end;
+@z
+
+@x [36] Output of real numbers.
+print_ln(' at ',(((vf[k]*256+vf[k+1])*256+vf[k+2])/@'4000000)*real_dsize:2:2,
+ 'pt')
+@y
+print(' at ');
+print_real((((vf[k]*256+vf[k+1])*256+vf[k+2])/@'4000000)*real_dsize, 2, 2);
+print_ln('pt')
+@z
+
+@x [37] No arbitrary max on cur_name.
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+@y
+@!cur_name:^char; {external tfm name}
+@z
+
+@x [39] Open another TFM file.
+reset(tfm_file,cur_name);
+@^system dependencies@>
+if eof(tfm_file) then
+ print_ln('---not loaded, font metric file can''t be opened!')
+@.font metric file can\'t be opened@>
+else begin font_bc:=0; font_ec:=65536; {will cause error if not modified soon}
+@y
+tfm_file := kpse_open_file (cur_name, kpse_ofm_format);
+@^system dependencies@>
+if eof(tfm_file) then
+ print_ln('---not loaded, font metric file can''t be opened!')
+@.font metric file can\'t be opened@>
+else begin font_bc:=0; font_ec:=65536; {will cause error if not modified soon}
+@z
+
+@x [40] Be quiet if not -verbose.
+ print_ln('Check sum in OVF file being replaced by font metric check sum');
+@y
+ if verbose then
+ print_ln('Check sum in OVF file being replaced by font metric check sum');
+@z
+
+@x [42] Remove initialization of now-defunct array.
+@ @<Set init...@>=
+default_directory:=default_directory_name;
+@y
+@ (No initialization to be done. Keep this module to preserve numbering.)
+@z
+
+@x [44] Don't append `.tfm' here, and keep lowercase.
+for k:=1 to name_length do cur_name[k]:=' ';
+if a=0 then begin
+ for k:=1 to default_directory_name_length do
+ cur_name[k]:=default_directory[k];
+ r:=default_directory_name_length;
+ end
+else r:=0;
+for k:=font_start[font_ptr]+14 to vf_ptr-1 do begin
+ incr(r);
+ if r+4>name_length then vf_abort('Font name too long for me!');
+@.Font name too long for me@>
+ if (vf[k]>="a")and(vf[k]<="z") then
+ cur_name[r]:=xchr[vf[k]-@'40]
+ else cur_name[r]:=xchr[vf[k]];
+ end;
+cur_name[r+1]:='.'; cur_name[r+2]:='T'; cur_name[r+3]:='F'; cur_name[r+4]:='M'
+@y
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{TFM} file for the current font. We do not impose an arbitrary limit
+on the filename length.
+@^system dependencies@>
+
+@d name_start == (font_start[font_ptr] + 14)
+@d name_end == vf_ptr
+
+@<Move font name into the |cur_name| string@>=
+r := name_end - name_start;
+cur_name := xmalloc (r + 1);
+{|strncpy| might be faster, but it's probably a good idea to keep the
+ |xchr| translation.}
+for k := name_start to name_end do begin
+ cur_name[k - name_start] := xchr[vf[k]];
+end;
+cur_name[r] := 0; {Append null byte since this is C.}
+@z
+
+@x [49] Change strings to C char pointers, so we can initialize them.
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!xchr:packed array [0..255] of char;
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+@y
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: c_string;
+ {strings for output in the user's external character set}
+@!ASCII_all: packed array[0..256] of char;
+@!xchr:packed array [0..255] of char;
+@!MBL_string,@!RI_string,@!RCE_string: c_string;
+ {handy string constants for |face| codes}
+@z
+
+@x [50] The Pascal strings are indexed starting at 1, so we pad with a blank.
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~?';@/
+HEX:='0123456789ABCDEF';@/
+@y
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:=' @@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:=' `abcdefghijklmnopqrstuvwxyz{|}~?';@/
+HEX:=' 0123456789ABCDEF';@/
+strcpy (ASCII_all, ASCII_04);
+strcat (ASCII_all, '@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_');
+strcat (ASCII_all, '`abcdefghijklmnopqrstuvwxyz{|}~');@/
+@z
+
+@x
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+@y
+MBL_string:=' MBL'; RI_string:=' RI '; RCE_string:=' RCE';
+@z
+
+% [60] How we output the character code depends on |charcode_format|.
+@x
+begin if font_type>vanilla then
+ out_hex_char(c)
+else if (c>="0")and(c<="9") then
+ out(' C ',c-"0":1)
+else if (c>="A")and(c<="Z") then
+ out(' C ',ASCII_10[c-"A"+2])
+else if (c>="a")and(c<="z") then
+ out(' C ',ASCII_14[c-"a"+2])
+else out_hex_char(c);
+end;
+@y
+begin if (font_type > vanilla) or (charcode_format = charcode_hex) then
+ out_hex_char(c)
+else if (charcode_format = charcode_ascii) and (c > " ") and (c <= "~")
+ and (c <> "(") and (c <> ")") then
+ out(' C ', ASCII_all[c - " " + 1])
+{default case, use hex}
+else out_hex_char(c);
+end;
+@z
+
+% [61] Don't output the face code as an integer.
+@x
+ out(MBL_string[1+(b mod 3)]);
+ out(RI_string[1+s]);
+ out(RCE_string[1+(b div 3)]);
+@y
+ put_byte(MBL_string[1+(b mod 3)], vpl_file);
+ put_byte(RI_string[1+s], vpl_file);
+ put_byte(RCE_string[1+(b div 3)], vpl_file);
+@z
+
+@x [62] Force 32-bit constant arithmetic for 16-bit machines.
+f:=((tfm[k+1] mod 16)*@'400+tfm[k+2])*@'400+tfm[k+3];
+@y
+f:=((tfm[k+1] mod 16)*intcast(@'400)+tfm[k+2])*@'400+tfm[k+3];
+@z
+
+% [100] No progress reports unless verbose.
+@x
+ incr(chars_on_line);
+ end;
+ for cprime:=c to (c+no_repeats(c)) do begin
+ print_hex(cprime); {progress report}
+@y
+ if verbose then incr(chars_on_line);
+ end;
+ for cprime:=c to (c+no_repeats(c)) do begin
+ if verbose then print_hex(cprime); {progress report}
+@z
+
+% [112] No nonlocal goto's.
+@x
+ print_ln('Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ goto final_end;
+@y
+ write_ln(stderr, 'Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ uexit(1);
+@z
+
+% still [112] We can't have a function named `f', because of the local
+% variable in do_simple_things. It would be better, but harder, to fix
+% web2c.
+@x
+ r:=f(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+@y
+ r:=lig_f(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+@z
+
+@x
+ out('(INFINITE LIGATURE LOOP MUST BE BROKEN!)'); goto final_end;
+@y
+ out('(INFINITE LIGATURE LOOP MUST BE BROKEN!)'); uexit(1);
+@z
+
+% [116] web2c can't handle these mutually recursive procedures.
+% But let's do a fake definition of f here, so that it gets into web2c's
+% symbol table...
+@x
+@p function f(@!h,@!x,@!y:index):index; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+@y
+@p
+ifdef('notdef')
+function lig_f(@!h,@!x,@!y:index):index; begin end;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+endif('notdef')
+@z
+
+@x
+else eval:=f(h,x,y);
+@y
+else eval:=lig_f(h,x,y);
+@z
+
+@x [117] ... and then really define it now.
+@p function f;
+@y
+@p function lig_f(@!h,@!x,@!y:index):index;
+@z
+
+@x
+f:=lig_z[h];
+@y
+lig_f:=lig_z[h];
+@z
+
+@x [124] Some cc's can't handle 136 case labels.
+ o:=vf[vf_ptr]; incr(vf_ptr);
+ case o of
+ @<Cases of \.{DVI} instructions that can appear in character packets@>@;
+@y
+ o:=vf[vf_ptr]; incr(vf_ptr);
+ if ((o<=set_char_0+127))or
+ ((o>=set1)and(o<=set1+3))or((o>=put1)and(o<=put1+3)) then
+begin if o>=set1 then
+ if o>=put1 then c:=get_bytes(o-put1+1,false)
+ else c:=get_bytes(o-set1+1,false)
+ else c:=o;
+ if f=font_ptr then
+ bad_vf('Character ',c:1,' in undeclared font will be ignored')
+@.Character...will be ignored@>
+ else begin vf[font_start[f+1]-1]:=c; {store |c| in the ``hole'' we left}
+ k:=font_chars[f];@+while vf[k]<>c do incr(k);
+ if k=font_start[f+1]-1 then
+ bad_vf('Character ',c:1,' in font ',f:1,' will be ignored')
+ else begin if o>=put1 then out('(PUSH)');
+ left; out('SETCHAR'); out_char(c);
+ if o>=put1 then out(')(POP');
+ right;
+ end;
+ end;
+ end
+ else case o of
+ @<Cases of \.{DVI} instructions that can appear in character packets@>
+@z
+
+@x [125] `signed' is a reserved word in ANSI C.
+@p function get_bytes(@!k:integer;@!signed:boolean):integer;
+@y
+@d signed == is_signed {|signed| is a reserved word in ANSI C}
+@p function get_bytes(@!k:integer;@!signed:boolean):integer;
+@z
+
+@x [126] No nonlocal goto's.
+ begin print_ln('Stack overflow!'); goto final_end;
+@y
+ begin write_ln(stderr, 'Stack overflow!'); uexit(1);
+@z
+
+@x [129] This code moved outside the case statement
+@ Before we typeset a character we make sure that it exists.
+
+@<Cases...@>=
+sixty_four_cases(set_char_0),sixty_four_cases(set_char_0+64),
+ four_cases(set1),four_cases(put1):begin if o>=set1 then
+ if o>=put1 then c:=get_bytes(o-put1+1,false)
+ else c:=get_bytes(o-set1+1,false)
+ else c:=o;
+ if f=font_ptr then
+ bad_vf('Character ',c:1,' in undeclared font will be ignored')
+@.Character...will be ignored@>
+ else begin vf[font_start[f+1]-1]:=c; {store |c| in the ``hole'' we left}
+ k:=font_chars[f];@+while vf[k]<>c do incr(k);
+ if k=font_start[f+1]-1 then
+ bad_vf('Character ',c:1,' in font ',f:1,' will be ignored')
+ else begin if o>=put1 then out('(PUSH)');
+ left; out('SETCHAR'); out_char(c);
+ if o>=put1 then out(')(POP');
+ right;
+ end;
+ end;
+ end;
+@y
+@ Before we typeset a character we make sure that it exists.
+(These cases moved outside the case statement, section 124.)
+@z
+
+@x [134] No final newline unless verbose.
+print_ln('.');@/
+@y
+if verbose then print_ln('.');@/
+@z
+
+@x [135] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{VFtoVP} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 4; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Initialize the option variables@>;
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+ end else if getopt_return_val = "?" then begin
+ usage ('ovf2ovp');
+
+ end else if argument_is ('help') then begin
+ usage_help (OVF2OVP_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end else if argument_is ('charcode-format') then begin
+ if strcmp (optarg, 'ascii') = 0 then
+ charcode_format := charcode_ascii
+ else if strcmp (optarg, 'hex') = 0 then
+ charcode_format := charcode_hex
+ else
+ write_ln (stderr, 'Bad character code format', optarg, '.');
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.
+ We must have one two three remaining arguments.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc)
+ and (optind + 3 <> argc) then begin
+ write_ln (stderr, 'ovf2ovp: Need one to three file arguments.');
+ usage ('ovf2ovp');
+ end;
+
+ vf_name := cmdline (optind);
+ if optind + 2 <= argc then begin
+ tfm_name := cmdline (optind + 1); {The user specified the TFM name.}
+ end else begin
+ {User did not specify TFM name; default it from the VF name.}
+ tfm_name := basename_change_suffix (vf_name, '.ovf', '.ofm');
+ end;
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Print progress information?
+@.-verbose@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'verbose';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := address_of (verbose);
+long_options[current_option].val := 1;
+incr (current_option);
+
+@ The global variable |verbose| determines whether or not we print
+progress information.
+
+@<Glob...@> =
+@!verbose: c_int_type;
+
+@ It starts off |false|.
+
+@<Initialize the option...@> =
+verbose := false;
+
+@ Here is an option to change how we output character codes.
+@.-charcode-format@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'charcode-format';
+long_options[current_option].has_arg := 1;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ We use an ``enumerated'' type to store the information.
+
+@<Type...@> =
+@!charcode_format_type = charcode_ascii..charcode_default;
+
+@
+@<Const...@> =
+@!charcode_ascii = 0;
+@!charcode_hex = 1;
+@!charcode_default = 2;
+
+@
+@<Global...@> =
+@!charcode_format: charcode_format_type;
+
+@ It starts off as the default, which is hex for OFM2OPL.
+
+@<Initialize the option...@> =
+charcode_format := charcode_default;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Global...@> =
+@!vf_name, @!tfm_name, @!vpl_name:c_string;
+@z
diff --git a/Build/source/texk/web2c/omegaware/ovf2ovp.web b/Build/source/texk/web2c/omegaware/ovf2ovp.web
new file mode 100644
index 00000000000..2e2e374dca5
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ovf2ovp.web
@@ -0,0 +1,3138 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--2000 John Plaice and Yannis Haralambous
+% applies only to the changes to the original vftovp.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 1 was implemented in December 1989.
+% Version 1.1 fixed problems of strict Pascal (April 1990).
+% Version 1.2 fixed various bugs found by Peter Breitenlohner (September 1990).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{OVF2OVP}
+\def\contentspagenumber{101}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont OVF2OVP} processor}
+ \vskip 15pt
+ \centerline{(Version 1.11, February 2000)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ The preparation of this program
+ was supported in part by the National Science
+ Foundation and by the System Development Foundation. `\TeX' is a
+ trademark of the American Mathematical Society.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{VFtoVP} utility program converts a virtual font (``\.{VF}'') file
+and its associated \TeX\ font metric (``\.{TFM}'')
+file into an equivalent virtual-property-list (``\.{VPL}'') file. It also
+makes a thorough check of the given files, using algorithms that are
+essentially the same as those used by
+\.{DVI} device drivers and by \TeX. Thus if \TeX\ or a \.{DVI} driver
+complains that a \.{TFM} or \.{VF}
+file is ``bad,'' this program will pinpoint the source or sources of
+badness. A \.{VPL} file output by this program can be edited with
+a normal text editor, and the result can be converted back to \.{VF} and \.{TFM}
+format using the companion program \.{VPtoVF}.
+
+\indent\.{VFtoVP} is an extended version of the program \.{TFtoPL}, which
+is part of the standard \TeX ware library.
+The idea of a virtual font was inspired by the work of David R. Fuchs
+@^Fuchs, David Raymond@>
+who designed a similar set of conventions in 1984 while developing a
+device driver for ArborText, Inc. He wrote a somewhat similar program
+called \.{AMFtoXPL}.
+
+The |banner| string defined here should be changed whenever \.{VFtoVP}
+gets modified.
+
+@d banner=='This is OVF2OVP, Version 1.11' {printed when the program starts}
+
+@ This program is written entirely in standard \PASCAL, except that
+it occasionally has lower case letters in strings that are output.
+Such letters can be converted to upper case if necessary. The input is read
+from |vf_file| and |tfm_file|; the output is written on |vpl_file|.
+Error messages and
+other remarks are written on the |output| file, which the user may
+choose to assign to the terminal if the system permits it.
+@^system dependencies@>
+
+The term |print| is used instead of |write| when this program writes on
+the |output| file, so that all such output can be easily deflected.
+
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+
+@p program OVF2OVP(@!vf_file,@!tfm_file,@!vpl_file,@!output);
+label @<Labels in the outer block@>@/
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+procedure initialize; {this procedure gets things started properly}
+ var @!k:integer; {all-purpose index for initialization}
+ begin print_ln(banner);@/
+ @<Set initial values@>@/
+ end;
+
+@ If the program has to stop prematurely, it goes to the
+`|final_end|'.
+
+@d final_end=9999 {label for the end of it all}
+
+@<Labels...@>=final_end;
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{VFtoVP}'s capacity.
+
+@<Constants...@>=
+@!tfm_size=2000000; {maximum length of |tfm| data, in bytes}
+@!vf_size=600000; {maximum length of |vf| data, in bytes}
+@!max_fonts=300; {maximum number of local fonts in the |vf| file}
+@!lig_size=800000; {maximum length of |lig_kern| program, in words}
+@!hash_size=130003; {preferably a prime number, a bit larger than the number
+ of character pairs in lig/kern steps}
+@!hash_mult=16007; {another prime}
+@!max_char=65535; {the largest character number in a font}
+@!xmax_char=65536; {|max_char|+1}
+@!xxmax_char=65537;{|max_char|+2}
+@!xmax_label=80001;{must be greater than |max_lig_steps|}
+@!mem_size=40008; {|max_char|*4+8}
+@!name_length=50; {a file name shouldn't be longer than this}
+@!max_stack=50; {maximum depth of \.{DVI} stack in character packets}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d do_nothing == {empty statement}
+@d exit=10 {go here to leave a procedure}
+@d not_found=45 {go here when you've found nothing}
+@d return==goto exit {terminate a procedure call}
+@f return==nil
+
+@<Types...@>=
+@!byte=0..255; {unsigned eight-bit quantity}
+
+@* Virtual fonts. The idea behind \.{VF} files is that a general
+interface mechanism is needed to switch between the myriad font
+layouts provided by different suppliers of typesetting equipment.
+Without such a mechanism, people must go to great lengths writing
+inscrutable macros whenever they want to use typesetting conventions
+based on one font layout in connection with actual fonts that have
+another layout. This puts an extra burden on the typesetting system,
+interfering with the other things it needs to do (like kerning,
+hyphenation, and ligature formation).
+
+These difficulties go away when we have a ``virtual font,''
+i.e., a font that exists in a logical sense but not a physical sense.
+A typesetting system like \TeX\ can do its job without knowing where the
+actual characters come from; a device driver can then do its job by
+letting a \.{VF} file tell what actual characters correspond to the
+characters \TeX\ imagined were present. The actual characters
+can be shifted and/or magnified and/or combined with other characters
+from many different fonts. A virtual font can even make use of characters
+from virtual fonts, including itself.
+
+Virtual fonts also allow convenient character substitutions for proofreading
+purposes, when fonts designed for one output device are unavailable on another.
+
+@ A \.{VF} file is organized as a stream of 8-bit bytes, using conventions
+borrowed from \.{DVI} and \.{PK} files. Thus, a device driver that knows
+about \.{DVI} and \.{PK} format will already
+contain most of the mechanisms necessary to process \.{VF} files.
+We shall assume that \.{DVI} format is understood; the conventions in the
+\.{DVI} documentation (see, for example, {\sl \TeX: The Program}, part 31)
+are adopted here to define \.{VF} format.
+
+A preamble
+appears at the beginning, followed by a sequence of character definitions,
+followed by a postamble. More precisely, the first byte of every \.{VF} file
+must be the first byte of the following ``preamble command'':
+
+\yskip\hang|pre| 247 |i[1]| |k[1]| |x[k]| |cs[4]| |ds[4]|.
+Here |i| is the identification byte of \.{VF}, currently 202. The string
+|x| is merely a comment, usually indicating the source of the \.{VF} file.
+Parameters |cs| and |ds| are respectively the check sum and the design size
+of the virtual font; they should match the first two words in the header of
+the \.{TFM} file, as described below.
+
+\yskip
+After the |pre| command, the preamble continues with font definitions;
+every font needed to specify ``actual'' characters in later
+\\{set\_char} commands is defined here. The font definitions are
+exactly the same in \.{VF} files as they are in \.{DVI} files, except
+that the scaled size |s| is relative and the design size |d| is absolute:
+
+\yskip\hang|fnt_def1| 243 |k[1]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<256|.
+
+\yskip\hang|@!fnt_def2| 244 |k[2]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<65536|.
+
+\yskip\hang|@!fnt_def3| 245 |k[3]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |0<=k<@t$2^{24}$@>|.
+
+\yskip\hang|@!fnt_def4| 246 |k[4]| |c[4]| |s[4]| |d[4]| |a[1]| |l[1]| |n[a+l]|.
+Define font |k|, where |@t$-2^{31}$@><=k<@t$2^{31}$@>|.
+
+\yskip\noindent
+These font numbers |k| are ``local''; they have no relation to font numbers
+defined in the \.{DVI} file that uses this virtual font. The dimension~|s|,
+which represents the scaled size of the local font being defined,
+is a |fix_word| relative to the design size of the virtual font.
+Thus if the local font is to be used at the same size
+as the design size of the virtual font itself, |s| will be the
+integer value $2^{20}$. The value of |s| must be positive and less than
+$2^{24}$ (thus less than 16 when considered as a |fix_word|).
+The dimension~|d| is a |fix_word| in units of printer's points; hence it
+is identical to the design size found in the corresponding \.{TFM} file.
+
+@d id_byte=202
+
+@<Glob...@>=
+@!vf_file:packed file of byte;
+
+@ The preamble is followed by zero or more character packets, where each
+character packet begins with a byte that is $<243$. Character packets have
+two formats, one long and one short:
+
+\yskip\hang|long_char| 242 |pl[4]| |cc[4]| |tfm[4]| |dvi[pl]|. This long form
+specifies a virtual character in the general case.
+
+\yskip\hang|short_char0..short_char241|
+|pl[1]| |cc[1]| |tfm[3]| |dvi[pl]|. This short form specifies a
+virtual character in the common case
+when |0<=pl<242| and |0<=cc<256| and $0\le|tfm|<2^{24}$.
+
+\yskip\noindent
+Here |pl| denotes the packet length following the |tfm| value; |cc| is
+the character code; and |tfm| is the character width copied from the
+\.{TFM} file for this virtual font. There should be at most one character
+packet having any given |cc| code.
+
+The |dvi| bytes are a sequence of complete \.{DVI} commands, properly
+nested with respect to |push| and |pop|. All \.{DVI} operations are
+permitted except |bop|, |eop|, and commands with opcodes |>=243|.
+Font selection commands (|fnt_num0| through |fnt4|) must refer to fonts
+defined in the preamble.
+
+Dimensions that appear in the \.{DVI} instructions are analogous to
+|fix_word| quantities; i.e., they are integer multiples of $2^{-20}$ times
+the design size of the virtual font. For example, if the virtual font
+has design size $10\,$pt, the \.{DVI} command to move down $5\,$pt
+would be a \\{down} instruction with parameter $2^{19}$. The virtual font
+itself might be used at a different size, say $12\,$pt; then that
+\\{down} instruction would move down $6\,$pt instead. Each dimension
+must be less than $2^{24}$ in absolute value.
+
+Device drivers processing \.{VF} files treat the sequences of |dvi| bytes
+as subroutines or macros, implicitly enclosing them with |push| and |pop|.
+Each subroutine begins with |w=x=y=z=0|, and with current font~|f| the
+number of the first-defined in the preamble (undefined if there's no
+such font). After the |dvi| commands have been
+performed, the |h| and~|v| position registers of \.{DVI} format and the
+current font~|f| are restored to their former values;
+then, if the subroutine has been invoked by a \\{set\_char} or \\{set}
+command, |h|~is increased by the \.{TFM} width
+(properly scaled)---just as if a simple character had been typeset.
+
+@d long_char=242 {\.{VF} command for general character packet}
+@d set_char_0=0 {\.{DVI} command to typeset character 0 and move right}
+@d set1=128 {typeset a character and move right}
+@d set_rule=132 {typeset a rule and move right}
+@d put1=133 {typeset a character}
+@d put_rule=137 {typeset a rule}
+@d nop=138 {no operation}
+@d push=141 {save the current positions}
+@d pop=142 {restore previous positions}
+@d right1=143 {move right}
+@d w0=147 {move right by |w|}
+@d w1=148 {move right and set |w|}
+@d x0=152 {move right by |x|}
+@d x1=153 {move right and set |x|}
+@d down1=157 {move down}
+@d y0=161 {move down by |y|}
+@d y1=162 {move down and set |y|}
+@d z0=166 {move down by |z|}
+@d z1=167 {move down and set |z|}
+@d fnt_num_0=171 {set current font to 0}
+@d fnt1=235 {set current font}
+@d xxx1=239 {extension to \.{DVI} primitives}
+@d xxx4=242 {potentially long extension to \.{DVI} primitives}
+@d fnt_def1=243 {define the meaning of a font number}
+@d pre=247 {preamble}
+@d post=248 {postamble beginning}
+@d improper_DVI_for_VF==139,140,243,244,245,246,247,248,249,250,251,252,
+ 253,254,255
+
+@ The character packets are followed by a trivial postamble, consisting of
+one or more bytes all equal to |post| (248). The total number of bytes
+in the file should be a multiple of~4.
+
+@* Font metric data.
+The idea behind \.{TFM} files is that typesetting routines like \TeX\
+need a compact way to store the relevant information about several
+dozen fonts, and computer centers need a compact way to store the
+relevant information about several hundred fonts. \.{TFM} files are
+compact, and most of the information they contain is highly relevant,
+so they provide a solution to the problem.
+
+The information in a \.{TFM} file appears in a sequence of 8-bit bytes.
+Since the number of bytes is always a multiple of 4, we could
+also regard the file as a sequence of 32-bit words; but \TeX\ uses the
+byte interpretation, and so does \.{VFtoVP}. Note that the bytes
+are considered to be unsigned numbers.
+
+@<Glob...@>=
+@!tfm_file:packed file of byte;
+
+@ On some systems you may have to do something special to read a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+reset(tfm_file); reset(vf_file);
+
+@ The first 24 bytes (6 words) of a \.{TFM} file contain twelve 16-bit
+integers that give the lengths of the various subsequent portions
+of the file. These twelve integers are, in order:
+$$\vbox{\halign{\hfil#&$\null=\null$#\hfil\cr
+|@!lf|&length of the entire file, in words;\cr
+|@!lh|&length of the header data, in words;\cr
+|@!bc|&smallest character code in the font;\cr
+|@!ec|&largest character code in the font;\cr
+|@!nw|&number of words in the width table;\cr
+|@!nh|&number of words in the height table;\cr
+|@!nd|&number of words in the depth table;\cr
+|@!ni|&number of words in the italic correction table;\cr
+|@!nl|&number of words in the lig/kern table;\cr
+|@!nk|&number of words in the kern table;\cr
+|@!ne|&number of words in the extensible character table;\cr
+|@!np|&number of font parameter words.\cr}}$$
+They are all nonnegative and less than $2^{15}$. We must have |bc-1<=ec<=255|,
+|ne<=256|, and
+$$\hbox{|lf=6+lh+(ec-bc+1)+nw+nh+nd+ni+nl+nk+ne+np|.}$$
+Note that a font may contain as many as 256 characters (if |bc=0| and |ec=255|),
+and as few as 0 characters (if |bc=ec+1|).
+
+Incidentally, when two or more 8-bit bytes are combined to form an integer of
+16 or more bits, the most significant bytes appear first in the file.
+This is called BigEndian order.
+
+@<Glob...@>=
+@!ofm_level,
+@!nco,@!ncw,@!npc,@!nki,@!nwi,@!nkf,@!nwf,@!nkr,@!nwr,@!nkg,@!nwg,@!nkp,@!nwp,
+@!nkm,@!nwm,@!real_lf,
+@!lf,@!lh,@!bc,@!ec,@!nw,@!nh,@!nd,@!ni,@!nl,@!nk,@!ne,@!np,@!font_dir:integer;
+ {subfile sizes}
+@!ofm_on:boolean;
+
+@ @<Set init...@>=
+ofm_on:=false; ofm_level:=-1; lf:=0; lh:=0;
+nco:=0; ncw:=0; npc:=0; bc:=0; ec:=0; nw:=0; nh:=0; nd:=0; ni:=0;
+nl:=0; nk:=0; ne:=0; np:=0;
+nki:=0; nwi:=0; nkf:=0; nwf:=0;
+nkm:=0; nwm:=0; real_lf:=0;
+nkr:=0; nwr:=0; nkg:=0; nwg:=0;
+nkp:=0; nwp:=0; font_dir:=0;
+
+@ The rest of the \.{TFM} file may be regarded as a sequence of ten data
+arrays having the informal specification
+$$\def\arr$[#1]#2${\&{array} $[#1]$ \&{of} #2}
+\vbox{\halign{\hfil\\{#}&$\,:\,$\arr#\hfil\cr
+header&|[0..lh-1]stuff|\cr
+char\_info&|[bc..ec]char_info_word|\cr
+width&|[0..nw-1]fix_word|\cr
+height&|[0..nh-1]fix_word|\cr
+depth&|[0..nd-1]fix_word|\cr
+italic&|[0..ni-1]fix_word|\cr
+lig\_kern&|[0..nl-1]lig_kern_command|\cr
+kern&|[0..nk-1]fix_word|\cr
+exten&|[0..ne-1]extensible_recipe|\cr
+param&|[1..np]fix_word|\cr}}$$
+The most important data type used here is a |@!fix_word|, which is
+a 32-bit representation of a binary fraction. A |fix_word| is a signed
+quantity, with the two's complement of the entire word used to represent
+negation. Of the 32 bits in a |fix_word|, exactly 12 are to the left of the
+binary point; thus, the largest |fix_word| value is $2048-2^{-20}$, and
+the smallest is $-2048$. We will see below, however, that all but one of
+the |fix_word| values will lie between $-16$ and $+16$.
+
+@ The first data array is a block of header information, which contains
+general facts about the font. The header must contain at least two words,
+and for \.{TFM} files to be used with Xerox printing software it must
+contain at least 18 words, allocated as described below. When different
+kinds of devices need to be interfaced, it may be necessary to add further
+words to the header block.
+
+\yskip\hang|header[0]| is a 32-bit check sum that \TeX\ will copy into the
+\.{DVI} output file whenever it uses the font. Later on when the \.{DVI}
+file is printed, possibly on another computer, the actual font that gets
+used is supposed to have a check sum that agrees with the one in the
+\.{TFM} file used by \TeX. In this way, users will be warned about
+potential incompatibilities. (However, if the check sum is zero in either
+the font file or the \.{TFM} file, no check is made.) The actual relation
+between this check sum and the rest of the \.{TFM} file is not important;
+the check sum is simply an identification number with the property that
+incompatible fonts almost always have distinct check sums.
+@^check sum@>
+
+\yskip\hang|header[1]| is a |fix_word| containing the design size of the
+font, in units of \TeX\ points (7227 \TeX\ points = 254 cm). This number
+must be at least 1.0; it is fairly arbitrary, but usually the design size
+is 10.0 for a ``10 point'' font, i.e., a font that was designed to look
+best at a 10-point size, whatever that really means. When a \TeX\ user
+asks for a font `\.{at} $\delta$ \.{pt}', the effect is to override the
+design size and replace it by $\delta$, and to multiply the $x$ and~$y$
+coordinates of the points in the font image by a factor of $\delta$
+divided by the design size. {\sl All other dimensions in the\/\ \.{TFM}
+file are |fix_word|\kern-1pt\ numbers in design-size units.} Thus, for example,
+the value of |param[6]|, one \.{em} or \.{\\quad}, is often the |fix_word|
+value $2^{20}=1.0$, since many fonts have a design size equal to one em.
+The other dimensions must be less than 16 design-size units in absolute
+value; thus, |header[1]| and |param[1]| are the only |fix_word| entries in
+the whole \.{TFM} file whose first byte might be something besides 0 or
+255. @^design size@>
+
+\yskip\hang|header[2..11]|, if present, contains 40 bytes that identify
+the character coding scheme. The first byte, which must be between 0 and
+39, is the number of subsequent ASCII bytes actually relevant in this
+string, which is intended to specify what character-code-to-symbol
+convention is present in the font. Examples are \.{ASCII} for standard
+ASCII, \.{TeX text} for fonts like \.{cmr10} and \.{cmti9}, \.{TeX math
+extension} for \.{cmex10}, \.{XEROX text} for Xerox fonts, \.{GRAPHIC} for
+special-purpose non-alphabetic fonts, \.{UNSPECIFIED} for the default case
+when there is no information. Parentheses should not appear in this name.
+(Such a string is said to be in {\mc BCPL} format.)
+@^coding scheme@>
+
+\yskip\hang|header[12..16]|, if present, contains 20 bytes that name the
+font family (e.g., \.{CMR} or \.{HELVETICA}), in {\mc BCPL} format.
+This field is also known as the ``font identifier.''
+@^family name@>
+@^font identifier@>
+
+\yskip\hang|header[17]|, if present, contains a first byte called the
+|seven_bit_safe_flag|, then two bytes that are ignored, and a fourth byte
+called the |face|. If the value of the fourth byte is less than 18, it has
+the following interpretation as a ``weight, slope, and expansion'': Add 0
+or 2 or 4 (for medium or bold or light) to 0 or 1 (for roman or italic) to
+0 or 6 or 12 (for regular or condensed or extended). For example, 13 is
+0+1+12, so it represents medium italic extended. A three-letter code
+(e.g., \.{MIE}) can be used for such |face| data.
+
+\yskip\hang|header[18..@twhatever@>]| might also be present; the individual
+words are simply called |header[18]|, |header[19]|, etc., at the moment.
+
+@ Next comes the |char_info| array, which contains one |char_info_word|
+per character. Each |char_info_word| contains six fields packed into
+four bytes as follows.
+
+\yskip\hang first byte: |width_index| (8 bits)\par
+\hang second byte: |height_index| (4 bits) times 16, plus |depth_index|
+ (4~bits)\par
+\hang third byte: |italic_index| (6 bits) times 4, plus |tag|
+ (2~bits)\par
+\hang fourth byte: |remainder| (8 bits)\par
+\yskip\noindent
+The actual width of a character is |width[width_index]|, in design-size
+units; this is a device for compressing information, since many characters
+have the same width. Since it is quite common for many characters
+to have the same height, depth, or italic correction, the \.{TFM} format
+imposes a limit of 16 different heights, 16 different depths, and
+64 different italic corrections.
+
+Incidentally, the relation |width[0]=height[0]=depth[0]=italic[0]=0|
+should always hold, so that an index of zero implies a value of zero.
+The |width_index| should never be zero unless the character does
+not exist in the font, since a character is valid if and only if it lies
+between |bc| and |ec| and has a nonzero |width_index|.
+
+@ The |tag| field in a |char_info_word| has four values that explain how to
+interpret the |remainder| field.
+
+\yskip\hang|tag=0| (|no_tag|) means that |remainder| is unused.\par
+\hang|tag=1| (|lig_tag|) means that this character has a ligature/kerning
+program starting at |lig_kern[remainder]|.\par
+\hang|tag=2| (|list_tag|) means that this character is part of a chain of
+characters of ascending sizes, and not the largest in the chain. The
+|remainder| field gives the character code of the next larger character.\par
+\hang|tag=3| (|ext_tag|) means that this character code represents an
+extensible character, i.e., a character that is built up of smaller pieces
+so that it can be made arbitrarily large. The pieces are specified in
+|exten[remainder]|.\par
+
+@d no_tag=0 {vanilla character}
+@d lig_tag=1 {character has a ligature/kerning program}
+@d list_tag=2 {character has a successor in a charlist}
+@d ext_tag=3 {character is extensible}
+
+@ The |lig_kern| array contains instructions in a simple programming language
+that explains what to do for special letter pairs. Each word is a
+|lig_kern_command| of four bytes.
+
+\yskip\hang first byte: |skip_byte|, indicates that this is the final program
+ step if the byte is 128 or more, otherwise the next step is obtained by
+ skipping this number of intervening steps.\par
+\hang second byte: |next_char|, ``if |next_char| follows the current character,
+ then perform the operation and stop, otherwise continue.''\par
+\hang third byte: |op_byte|, indicates a ligature step if less than~128,
+ a kern step otherwise.\par
+\hang fourth byte: |remainder|.\par
+\yskip\noindent
+In a kern step, an
+additional space equal to |kern[256*(op_byte-128)+remainder]| is inserted
+between the current character and |next_char|. This amount is
+often negative, so that the characters are brought closer together
+by kerning; but it might be positive.
+
+There are eight kinds of ligature steps, having |op_byte| codes $4a+2b+c$ where
+$0\le a\le b+c$ and $0\le b,c\le1$. The character whose code is
+|remainder| is inserted between the current character and |next_char|;
+then the current character is deleted if $b=0$, and |next_char| is
+deleted if $c=0$; then we pass over $a$~characters to reach the next
+current character (which may have a ligature/kerning program of its own).
+
+Notice that if $a=0$ and $b=1$, the current character is unchanged; if
+$a=b$ and $c=1$, the current character is changed but the next character is
+unchanged. \.{VFtoVP} will check to see that infinite loops are avoided.
+
+If the very first instruction of the |lig_kern| array has |skip_byte=255|,
+the |next_char| byte is the so-called right boundary character of this font;
+the value of |next_char| need not lie between |bc| and~|ec|.
+If the very last instruction of the |lig_kern| array has |skip_byte=255|,
+there is a special ligature/kerning program for a left boundary character,
+beginning at location |256*op_byte+remainder|.
+The interpretation is that \TeX\ puts implicit boundary characters
+before and after each consecutive string of characters from the same font.
+These implicit characters do not appear in the output, but they can affect
+ligatures and kerning.
+
+If the very first instruction of a character's |lig_kern| program has
+|skip_byte>128|, the program actually begins in location
+|256*op_byte+remainder|. This feature allows access to large |lig_kern|
+arrays, because the first instruction must otherwise
+appear in a location |<=255|.
+
+Any instruction with |skip_byte>128| in the |lig_kern| array must have
+|256*op_byte+remainder<nl|. If such an instruction is encountered during
+normal program execution, it denotes an unconditional halt; no ligature
+command is performed.
+
+@d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program}
+@d kern_flag=128 {op code for a kern step}
+
+@ Extensible characters are specified by an |extensible_recipe|,
+which consists of four bytes called |top|, |mid|,
+|bot|, and |rep| (in this order). These bytes are the character codes
+of individual pieces used to build up a large symbol.
+If |top|, |mid|, or |bot| are zero,
+they are not present in the built-up result. For example, an extensible
+vertical line is like an extensible bracket, except that the top and
+bottom pieces are missing.
+
+
+@ The final portion of a \.{TFM} file is the |param| array, which is another
+sequence of |fix_word| values.
+
+\yskip\hang|param[1]=@!slant| is the amount of italic slant, which is used
+to help position accents. For example, |slant=.25| means that when you go
+up one unit, you also go .25 units to the right. The |slant| is a pure
+number; it's the only |fix_word| other than the design size itself that is
+not scaled by the design size.
+
+\hang|param[2]=space| is the normal spacing between words in text.
+Note that character |" "| in the font need not have anything to do with
+blank spaces.
+
+\hang|param[3]=space_stretch| is the amount of glue stretching between words.
+
+\hang|param[4]=space_shrink| is the amount of glue shrinking between words.
+
+\hang|param[5]=x_height| is the height of letters for which accents don't
+have to be raised or lowered.
+
+\hang|param[6]=quad| is the size of one em in the font.
+
+\hang|param[7]=extra_space| is the amount added to |param[2]| at the
+ends of sentences.
+
+When the character coding scheme is \.{TeX math symbols}, the font is
+supposed to have 15 additional parameters called |num1|, |num2|, |num3|,
+|denom1|, |denom2|, |sup1|, |sup2|, |sup3|, |sub1|, |sub2|, |supdrop|,
+|subdrop|, |delim1|, |delim2|, and |axis_height|, respectively. When the
+character coding scheme is \.{TeX math extension}, the font is supposed to
+have six additional parameters called |default_rule_thickness| and
+|big_op_spacing1| through |big_op_spacing5|.
+
+@ So that is what \.{TFM} files hold. The next question is, ``What about
+\.{VPL} files?'' A complete answer to that question appears in the
+documentation of the companion program, \.{VPtoVF}, so it will not
+be repeated here. Suffice it to say that a \.{VPL} file is an ordinary
+\PASCAL\ text file, and that the output of \.{VFtoVP} uses only a
+subset of the possible constructions that might appear in a \.{VPL} file.
+Furthermore, hardly anybody really wants to look at the formal
+definition of \.{VPL} format, because it is almost self-explanatory when
+you see an example or two.
+
+@<Glob...@>=
+@!vpl_file:text;
+
+@ @<Set init...@>=
+rewrite(vpl_file);
+
+@* Unpacking the TFM file.
+The first thing \.{VFtoVP} does is read the entire |tfm_file| into an array of
+bytes, |tfm[0..(4*lf-1)]|.
+
+@<Types...@>=
+@!index=0..tfm_size; {address of a byte in |tfm|}
+@!char_type=0..65535;
+@!xchar_type=0..65536;
+@!xxchar_type=0..65537;
+@!xxxchar_type=0..65538;
+
+@
+@<Glob...@>=
+@!tfm:array [-1000..tfm_size] of byte; {the input data all goes here}
+ {the negative addresses avoid range checks for invalid characters}
+@!top_char,@!top_width,@!top_height,@!top_depth,@!top_italic:integer;
+@!start_ptr,@!check_sum,@!design_size,@!scheme,@!family,@!random_word:integer;
+@!header_length,@!char_ptr,@!copies,@!j:integer;
+
+@ The input may, of course, be all screwed up and not a \.{TFM} file
+at all. So we begin cautiously.
+
+@d abort(#)==begin print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OFM?');
+ goto final_end;
+ end
+
+@<Read the whole font metric file@>=
+read(tfm_file,tfm[0]);
+if tfm[0]>127 then abort('The first byte of the input file exceeds 127!');
+@.The first byte...@>
+if eof(tfm_file) then abort('The input file is only one byte long!');
+@.The input...one byte long@>
+read(tfm_file,tfm[1]); lf:=tfm[0]*@'400+tfm[1];
+if lf=0 then begin
+ for i:=2 to 7 do begin
+ if eof(tfm_file)
+ then abort('The input file is too short to designate its length!');
+ read(tfm_file, tfm[i]);
+ end;
+ ofm_on := true; ofm_level := tfm[2]*@"100+tfm[3];
+ if tfm[4]>127 then abort('The fifth byte of the input file exceeds 127!');
+ lf := tfm[4]*@"1000000 + tfm[5]*@"10000 + tfm[6]*@"100 + tfm[7];
+ end
+else begin
+ ofm_on := false;
+ end;
+case ofm_level of
+ -1: begin start_ptr:=2; check_sum:=24; end;
+ 0: begin start_ptr:=8; check_sum:=56; end;
+ 1: begin start_ptr:=8; check_sum:=116; end;
+ end;
+design_size:=check_sum+4;
+scheme:=design_size+4;
+family:=scheme+40;
+random_word:=family+20;
+if lf=0 then
+ abort('The file claims to have length zero, but that''s impossible!');
+@.The file claims...@>
+if 4*lf-1>tfm_size then abort('The file is bigger than I can handle!');
+@.The file is bigger...@>
+for tfm_ptr:=start_ptr to 4*lf-1 do begin
+ if eof(tfm_file) then
+ abort('The file has fewer bytes than it claims!');
+@.The file has fewer bytes...@>
+ read(tfm_file,tfm[tfm_ptr]);
+ end;
+if not eof(tfm_file) then begin
+ print_ln('There''s some extra junk at the end of the OFM file,');
+@.There's some extra junk...@>
+ print_ln('but I''ll proceed as if it weren''t there.');
+ end
+
+@ After the file has been read successfully, we look at the subfile sizes
+to see if they check out.
+
+@d eval_two_bytes(#)==begin if tfm[tfm_ptr]>127 then
+ abort('One of the subfile sizes is negative!');
+@.One of the subfile sizes...@>
+ #:=tfm[tfm_ptr]*@'400+tfm[tfm_ptr+1];
+ tfm_ptr:=tfm_ptr+2;
+ end
+@d eval_four_bytes(#)==begin if tfm[tfm_ptr]>127 then
+ abort('One of the subfile sizes is negative!');
+@.One of the subfile sizes...@>
+ #:=tfm[tfm_ptr]*@"1000000+tfm[tfm_ptr+1]*@"10000+
+ tfm[tfm_ptr+2]*@"100+tfm[tfm_ptr+3];
+ tfm_ptr:=tfm_ptr+4;
+ end
+
+@<Set subfile sizes |lh|, |bc|, \dots, |np|@>=
+begin
+if not ofm_on then begin
+ tfm_ptr:=2;
+ eval_two_bytes(lh);
+ eval_two_bytes(bc);
+ eval_two_bytes(ec);
+ eval_two_bytes(nw);
+ eval_two_bytes(nh);
+ eval_two_bytes(nd);
+ eval_two_bytes(ni);
+ eval_two_bytes(nl);
+ eval_two_bytes(nk);
+ eval_two_bytes(ne);
+ eval_two_bytes(np);
+ ncw:=(ec-bc+1);
+ header_length:=6;
+ top_char:=255;
+ top_width:=255;
+ top_height:=15;
+ top_depth:=15;
+ top_italic:=63;
+ end
+else begin
+ tfm_ptr:=8;
+ eval_four_bytes(lh);
+ eval_four_bytes(bc);
+ eval_four_bytes(ec);
+ eval_four_bytes(nw);
+ eval_four_bytes(nh);
+ eval_four_bytes(nd);
+ eval_four_bytes(ni);
+ eval_four_bytes(nl);
+ eval_four_bytes(nk);
+ eval_four_bytes(ne);
+ eval_four_bytes(np);
+ eval_four_bytes(font_dir);
+ top_char:=65535;
+ top_width:=65535;
+ top_height:=255;
+ top_depth:=255;
+ top_italic:=255;
+ if ofm_level=0 then begin
+ header_length:=14;
+ ncw:=2*(ec-bc+1);
+ end
+ else begin
+ header_length:=29;
+ eval_four_bytes(nco);
+ eval_four_bytes(ncw);
+ eval_four_bytes(npc);
+ eval_four_bytes(nki); {Kinds of font ivalues}
+ eval_four_bytes(nwi); {Words of font ivalues}
+ eval_four_bytes(nkf); {Kinds of font fvalues}
+ eval_four_bytes(nwf); {Words of font fvalues}
+ eval_four_bytes(nkm); {Kinds of font mvalues}
+ eval_four_bytes(nwm); {Words of font mvalues}
+ eval_four_bytes(nkr); {Kinds of font rules}
+ eval_four_bytes(nwr); {Words of font rules}
+ eval_four_bytes(nkg); {Kinds of font glues}
+ eval_four_bytes(nwg); {Words of font glues}
+ eval_four_bytes(nkp); {Kinds of font penalties}
+ eval_four_bytes(nwp); {Words of font penalties}
+ end;
+ end;
+if lf<>(header_length+lh+ncw+nw+nh+nd+ni+2*nl+nk+2*ne+np+
+ nki+nwi+nkf+nwf+nkr+nwr+nkg+nwg+nkp+nwp) then
+ abort('Subfile sizes don''t add up to the stated total!');
+@.Subfile sizes don't add up...@>
+if lh<2 then abort('The header length is only ',lh:1,'!');
+@.The header length...@>
+if (2*nl)>(4*lig_size) then
+ abort('The lig/kern program is longer than I can handle!');
+@.The lig/kern program...@>
+if (bc>ec+1)or(ec>top_char) then abort('The character code range ',
+@.The character code range...@>
+ bc:1,'..',ec:1,'is illegal!');
+if ec>max_char then
+ abort('Character ',ec:1,'is too large. Ask a wizard to enlarge me.');
+if (nw=0)or(nh=0)or(nd=0)or(ni=0) then
+ abort('Incomplete subfiles for character dimensions!');
+@.Incomplete subfiles...@>
+if ne>(top_char+1) then abort('There are ',ne:1,' extensible recipes!');
+@.There are ... recipes@>
+end
+
+@ Once the input data successfully passes these basic checks,
+\.{TFtoPL} believes that it is a \.{TFM} file, and the conversion
+to \.{PL} format will take place. Access to the various subfiles
+is facilitated by computing the following base addresses. For example,
+the |char_info| for character |c| in a \.{TFM} file will start in location
+|4*(char_base+c)| of the |tfm| array.
+
+@<Globals...@>=
+@!ivalues_start,@!fvalues_start,@!mvalues_start,
+@!rules_start,@!glues_start,@!penalties_start:
+integer;
+@!ivalues_base,@!fvalues_base,@!mvalues_base,
+@!rules_base,@!glues_base,@!penalties_base:
+integer;
+@!char_base,@!width_base,@!height_base,@!depth_base,@!italic_base: integer;
+@!lig_kern_base,@!kern_base,@!exten_base,@!param_base:integer;
+ {base addresses for the subfiles}
+@!char_start:array [0..max_char] of integer;
+@!bytes_per_entry:integer;
+
+@ @<Compute the base addresses@>=
+begin
+ivalues_start:=header_length+lh;
+fvalues_start:=ivalues_start+nki;
+mvalues_start:=fvalues_start+nkf;
+rules_start:=mvalues_start+nkm;
+glues_start:=rules_start+nkr;
+penalties_start:=glues_start+nkg;
+ivalues_base:=penalties_start+nkp;
+fvalues_base:=ivalues_base+nwi;
+mvalues_base:=fvalues_base+nwi;
+rules_base:=mvalues_base+nwm;
+glues_base:=rules_base+nwr;
+penalties_base:=glues_base+nwg;
+char_base:=penalties_base+nwp;
+bytes_per_entry:=(12 + 2*npc) div 4 * 4;
+if not ofm_on then begin
+ for i:=bc to ec do begin
+ char_start[i]:=4*char_base+4*(i-bc);
+ end;
+ end
+else if ofm_level=0 then begin
+ for i:=bc to ec do begin
+ char_start[i]:=4*char_base+8*(i-bc);
+ end;
+ end
+else begin
+ char_ptr:=4*char_base;
+ i:=bc;
+ while i<=ec do begin
+ copies:=1+256*tfm[char_ptr+8]+tfm[char_ptr+9];
+ for j:=1 to copies do begin
+ char_start[i]:=char_ptr;
+ i:=i+1;
+ end;
+ char_ptr:=char_ptr + bytes_per_entry;
+ end;
+ if char_ptr<>(4*(char_base+ncw)) then
+ abort('Length of char info table does not correspond to specification');
+ end;
+width_base:=char_base+ncw;
+height_base:=width_base+nw;
+depth_base:=height_base+nh;
+italic_base:=depth_base+nd;
+lig_kern_base:=italic_base+ni;
+kern_base:=lig_kern_base+2*nl;
+exten_base:=kern_base+nk;
+param_base:=exten_base+2*ne-1;
+end
+
+@ Of course we want to define macros that suppress the detail of how the
+font information is actually encoded. Each word will be referred to by
+the |tfm| index of its first byte. For example, if |c| is a character
+code between |bc| and |ec|, then |tfm[char_info(c)]| will be the
+first byte of its |char_info|, i.e., the |width_index|; furthermore
+|width(c)| will point to the |fix_word| for |c|'s width.
+
+@d char_info(#)==char_start[#]
+@d nonexistent(#)==((#<bc)or(#>ec)or(width_index(#)=0))
+@d width(#)==4*(width_base+width_index(#))
+@d height(#)==4*(height_base+height_index(#))
+@d depth(#)==4*(depth_base+depth_index(#))
+@d italic(#)==4*(italic_base+italic_index(#))
+@d kern(#)==4*(kern_base+#) {here \#\ is an index, not a character}
+@d param(#)==4*(param_base+#) {likewise}
+
+@p function width_index(c:char_type):integer;
+begin if not ofm_on then
+ width_index:=tfm[char_info(c)]
+else
+ width_index:=256*tfm[char_info(c)]+tfm[char_info(c)+1];
+end;
+
+function height_index(c:char_type):integer;
+begin if not ofm_on then
+ height_index:=tfm[char_info(c)+1] div 16
+else
+ height_index:=tfm[char_info(c)+2];
+end;
+
+function depth_index(c:char_type):integer;
+begin if not ofm_on then
+ depth_index:=tfm[char_info(c)+1] mod 16
+else
+ depth_index:=tfm[char_info(c)+3];
+end;
+
+function italic_index(c:char_type):integer;
+begin if not ofm_on then
+ italic_index:=tfm[char_info(c)+2] div 4
+else if ofm_level=0 then
+ italic_index:=tfm[char_info(c)+4]*64 + tfm[char_info(c)+5] div 4
+else
+ italic_index:=tfm[char_info(c)+4];
+end;
+
+function tag(c:char_type):integer;
+begin if not ofm_on then
+ tag:=tfm[char_info(c)+2] mod 4
+else
+ tag:=tfm[char_info(c)+5] mod 4;
+end;
+
+procedure set_no_tag(c:char_type);
+begin if not ofm_on then
+ tfm[char_info(c)+2] := (tfm[char_info(c)+2] div 64)*64 + no_tag
+else
+ tfm[char_info(c)+5] := (tfm[char_info(c)+5] div 64)*64 + no_tag;
+end;
+
+function ctag(c:char_type):boolean;
+begin if not (ofm_level=1) then
+ ctag:=false
+else
+ ctag:=tfm[char_info(c)+5] div 4 mod 2;
+end;
+
+procedure set_no_ctag(c:char_type);
+begin if not (ofm_level=1) then
+ tfm[char_info(c)+5] :=
+ tfm[char_info(c)+5] div 8 * 8 + tfm[char_info(c)+5] mod 4;
+end;
+
+function no_repeats(c:char_type):integer;
+begin if ofm_level<=0 then
+ no_repeats:=0
+else
+ no_repeats:=256*tfm[char_info(c)+8]+tfm[char_info(c)+9];
+end;
+
+function char_param(c:char_type; i:integer):integer;
+begin
+ char_param:=256*tfm[char_info(c)+2*i+10]+tfm[char_info(c)+2*i+11];
+end;
+
+function rremainder(c:char_type):integer;
+begin if not ofm_on then
+ rremainder:=tfm[char_info(c)+3]
+else
+ rremainder:=256*tfm[char_info(c)+6]+tfm[char_info(c)+7];
+end;
+
+function lig_step(c:char_type):integer;
+begin if not ofm_on then
+ lig_step:=4*(lig_kern_base+c)
+else
+ lig_step:=4*(lig_kern_base+2*c);
+end;
+
+function exten(c:char_type):integer;
+begin if not ofm_on then
+ exten:=4*(exten_base+rremainder(c))
+else
+ exten:=4*(exten_base+2*rremainder(c));
+end;
+
+function l_skip_byte(c:integer):integer;
+begin if not ofm_on then
+ l_skip_byte:=tfm[c]
+else
+ l_skip_byte:=256*tfm[c]+tfm[c+1];
+end;
+
+procedure set_l_skip_byte(c:integer; newc:integer);
+begin if not ofm_on then
+ tfm[c]:=newc
+else begin
+ tfm[c]:=newc div 256;
+ tfm[c+1]:=newc mod 256
+ end
+end;
+
+function l_next_char(c:integer):integer;
+begin if not ofm_on then
+ l_next_char:=tfm[c+1]
+else
+ l_next_char:=256*tfm[c+2]+tfm[c+3];
+end;
+
+procedure set_l_next_char(c:integer; newc:char_type);
+begin if not ofm_on then
+ tfm[c+1]:=newc
+else begin
+ tfm[c+2]:=newc div 256;
+ tfm[c+3]:=newc mod 256
+ end
+end;
+
+function l_op_byte(c:integer):integer;
+begin if not ofm_on then
+ l_op_byte:=tfm[c+2]
+else
+ l_op_byte:=256*tfm[c+4]+tfm[c+5];
+end;
+
+procedure set_l_op_byte(c:integer; newc:integer);
+begin if not ofm_on then
+ tfm[c+2]:=newc
+else begin
+ tfm[c+2]:=newc div 256;
+ tfm[c+3]:=newc mod 256
+ end
+end;
+
+function l_remainder(c:integer):integer;
+begin if not ofm_on then
+ l_remainder:=tfm[c+3]
+else
+ l_remainder:=256*tfm[c+6]+tfm[c+7];
+end;
+
+procedure set_l_remainder(c:integer; newc:char_type);
+begin if not ofm_on then
+ tfm[c+3]:=newc
+else begin
+ tfm[c+6]:=newc div 256;
+ tfm[c+7]:=newc mod 256
+ end
+end;
+
+@ One of the things we would like to do is take cognizance of fonts whose
+character coding scheme is \.{TeX math symbols} or \.{TeX math extension};
+we will set the |font_type| variable to one of the three choices
+|vanilla|, |mathsy|, or |mathex|.
+
+@d vanilla=0 {not a special scheme}
+@d mathsy=1 {\.{TeX math symbols} scheme}
+@d mathex=2 {\.{TeX math extension} scheme}
+
+@<Glob...@>=
+@!font_type:vanilla..mathex; {is this font special?}
+
+@* Unpacking the VF file.
+Once the \.{TFM} file has been brought into memory, \.{VFtoVP} completes
+the input phase by reading the \.{VF} information into another array of bytes.
+In this case we don't store all the data; we check the redundant bytes
+for consistency with their \.{TFM} counterparts, and we partially decode
+the packets.
+
+@<Glob...@>=
+@!vf:array[0..vf_size] of byte; {the \.{VF} input data goes here}
+@!font_number:array[0..max_fonts] of integer; {local font numbers}
+@!font_start,@!font_chars:array[0..max_fonts] of 0..vf_size; {font info}
+@!font_ptr:0..max_fonts; {number of local fonts}
+@!packet_start,@!packet_end:array[char_type] of 0..vf_size;
+ {character packet boundaries}
+@!packet_found:boolean; {at least one packet has appeared}
+@!temp_byte:byte;@+@!reg_count:integer; {registers for simple calculations}
+@!real_dsize:real; {the design size, converted to floating point}
+@!pl:integer; {packet length}
+@!vf_ptr:0..vf_size; {first unused location in |vf|}
+@!vf_count:integer; {number of bytes read from |vf_file|}
+
+@ Again we cautiously verify that we've been given decent data.
+
+@d read_vf(#)==read(vf_file,#)
+@d vf_abort(#)==begin
+ print_ln(#);
+ print_ln('Sorry, but I can''t go on; are you sure this is a OVF?');
+ goto final_end;
+ end
+
+@<Read the whole \.{VF} file@>=
+read_vf(temp_byte);
+if temp_byte<>pre then vf_abort('The first byte isn''t `pre''!');
+@.The first byte...@>
+@<Read the preamble command@>;
+@<Read and store the font definitions and character packets@>;
+@<Read and verify the postamble@>
+
+@ @d vf_store(#)==@t@>@;@/
+ if vf_ptr+#>=vf_size then vf_abort('The file is bigger than I can handle!');
+@.The file is bigger...@>
+ for k:=vf_ptr to vf_ptr+#-1 do
+ begin if eof(vf_file) then vf_abort('The file ended prematurely!');
+@.The file ended prematurely@>
+ read_vf(vf[k]);
+ end;
+ vf_count:=vf_count+#; vf_ptr:=vf_ptr+#
+
+@<Read the preamble command@>=
+if eof(vf_file) then vf_abort('The input file is only one byte long!');
+@.The input...one byte long@>
+read_vf(temp_byte);
+if temp_byte<>id_byte then vf_abort('Wrong OVF version number in second byte!');
+@.Wrong OVF version...@>
+if eof(vf_file) then vf_abort('The input file is only two bytes long!');
+read_vf(temp_byte); {read the length of introductory comment}
+vf_count:=11; vf_ptr:=0; vf_store(temp_byte);
+for k:=0 to vf_ptr-1 do print(xchr[vf[k]]);
+print_ln(' '); reg_count:=0;
+for k:=0 to 7 do
+ begin if eof(vf_file) then vf_abort('The file ended prematurely!');
+@.The file ended prematurely@>
+ read_vf(temp_byte);
+ if temp_byte=tfm[check_sum+k] then incr(reg_count);
+ end;
+real_dsize:=(((tfm[design_size]*256+tfm[design_size+1])*256+tfm[design_size+2])
+ *256+tfm[design_size+3])/@'4000000;
+if reg_count<>8 then
+ begin print_ln('Check sum and/or design size mismatch.');
+@.Check sum...mismatch@>
+ print_ln('Data from OFM file will be assumed correct.');
+ end
+
+@ @<Read and store the font definitions and character packets@>=
+for k:=0 to 65535 do packet_start[k]:=vf_size;
+font_ptr:=0; packet_found:=false; font_start[0]:=vf_ptr;
+repeat if eof(vf_file) then
+ begin print_ln('File ended without a postamble!'); temp_byte:=post;
+@.File ended without a postamble@>
+ end
+else begin read_vf(temp_byte); incr(vf_count);
+ if temp_byte<>post then
+ if temp_byte>long_char then @<Read and store a font definition@>
+ else @<Read and store a character packet@>;
+ end;
+until temp_byte=post
+
+@ @<Read and verify the postamble@>=
+while (temp_byte=post)and not eof(vf_file) do
+ begin read_vf(temp_byte); incr(vf_count);
+ end;
+if not eof(vf_file) then
+ begin print_ln('There''s some extra junk at the end of the OVF file.');
+@.There's some extra junk...@>
+ print_ln('I''ll proceed as if it weren''t there.');
+ end;
+if vf_count mod 4 <> 0 then
+ print_ln('VF data not a multiple of 4 bytes')
+@.VF data not a multiple of 4 bytes@>
+
+@ @<Read and store a font definition@>=
+begin if packet_found or(temp_byte>=pre) then
+ vf_abort('Illegal byte ',temp_byte:1,' at beginning of character packet!');
+@.Illegal byte...@>
+font_number[font_ptr]:=vf_read(temp_byte-fnt_def1+1);
+if font_ptr=max_fonts then vf_abort('I can''t handle that many fonts!');
+@.I can't handle that many fonts@>
+vf_store(14); {|c[4]| |s[4]| |d[4]| |a[1]| |l[1]|}
+if vf[vf_ptr-10]>0 then {|s| is negative or exceeds $2^{24}-1$}
+ vf_abort('Mapped font size is too big!');
+@.Mapped font size...big@>
+a:=vf[vf_ptr-2]; l:=vf[vf_ptr-1]; vf_store(a+l); {|n[a+l]|}
+@<Print the name of the local font@>;
+@<Read the local font's \.{TFM} file and record the characters it contains@>;
+incr(font_ptr); font_start[font_ptr]:=vf_ptr;
+end
+
+@ The font area may need to be separated from the font name on some systems.
+Here we simply reproduce the font area and font name (with no space
+or punctuation between them).
+@^system dependencies@>
+
+@<Print the name...@>=
+print('MAPFONT ',font_ptr:1,': ');
+for k:=font_start[font_ptr]+14 to vf_ptr-1 do print(xchr[vf[k]]);
+k:=font_start[font_ptr]+5;
+print_ln(' at ',(((vf[k]*256+vf[k+1])*256+vf[k+2])/@'4000000)*real_dsize:2:2,
+ 'pt')
+
+@ Now we must read in another \.{TFM} file. But this time we needn't be so
+careful, because we merely want to discover which characters are present.
+The next few sections of the program are copied pretty much verbatim from
+\.{DVItype}, so that system-dependent modifications can be copied from existing
+software.
+
+It turns out to be convenient to read four bytes at a time, when we are
+inputting from the local \.{TFM} files. The input goes into global variables
+|b0|, |b1|, |b2|, and |b3|, with |b0| getting the first byte and |b3|
+the fourth.
+
+@<Glob...@>=
+@!a:integer; {length of the area/directory spec}
+@!l:integer; {length of the font name proper}
+@!cur_name:packed array[1..name_length] of char; {external name,
+ with no lower case letters}
+@!b0,@!b1,@!b2,@!b3: byte; {four bytes input at once}
+@!font_lh:integer; {header length of current local font}
+@!font_bc,@!font_ec:integer; {character range of current local font}
+@!font_ofm_level,@!font_extra_words:integer;
+@!font_kprime,@!font_j:integer;
+
+@ The |read_tfm_word| procedure sets |b0| through |b3| to the next
+four bytes in the current \.{TFM} file.
+@^system dependencies@>
+
+@d read_tfm(#)==if eof(tfm_file) then #:=0@+else read(tfm_file,#)
+
+@p procedure read_tfm_word;
+begin read_tfm(b0); read_tfm(b1);
+read_tfm(b2); read_tfm(b3);
+end;
+
+@ We use the |vf| array to store a list of all valid characters in the
+local font, beginning at location |font_chars[f]|.
+
+@<Read the local font's \.{TFM} file...@>=
+font_chars[font_ptr]:=vf_ptr;
+@<Move font name into the |cur_name| string@>;
+reset(tfm_file,cur_name);
+@^system dependencies@>
+if eof(tfm_file) then
+ print_ln('---not loaded, font metric file can''t be opened!')
+@.font metric file can\'t be opened@>
+else begin font_bc:=0; font_ec:=65536; {will cause error if not modified soon}
+ @<Read past the header@>;
+ if font_bc<=font_ec then
+ if font_ec>65535 then print_ln('---not loaded, bad font metric file!')
+@.bad font metric file@>
+ else @<Read |char_info| entries@>;
+ if eof(tfm_file) then
+ print_ln('---trouble is brewing, font metric file ended too soon!');
+@.trouble is brewing...@>
+ end;
+incr(vf_ptr) {leave space for character search later}
+
+@ @<Read past the header@>=
+read_tfm_word;
+if (b0*256+b1)<>0 then begin {TFM file}
+ font_ofm_level:=-1;
+ font_lh:=b2*256+b3;
+ read_tfm_word; font_bc:=b0*256+b1; font_ec:=b2*256+b3;
+ if font_ec<font_bc then font_bc:=font_ec+1;
+ read_tfm_word;
+ for k:=1 to 3+font_lh do begin
+ read_tfm_word;
+ if k=4 then @<Check the check sum@>;
+ if k=5 then @<Check the design size@>;
+ end;
+ end
+else begin
+ font_ofm_level:=b2*256+b3;
+ read_tfm_word; font_lh:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_bc:=((b0*256+b1)*256+b2)*256+b3;
+ read_tfm_word; font_ec:=((b0*256+b1)*256+b2)*256+b3;
+ if font_ec<font_bc then font_bc:=font_ec+1;
+ read_tfm_word;
+ for k:=1 to 8 do begin
+ read_tfm_word;
+ end;
+ if font_ofm_level=1 then begin
+ read_tfm_word; read_tfm_word; read_tfm_word;
+ font_extra_words:=(((b0*256+b1)*256+b2)*256+b3) div 2;
+ for k:=1 to 5 do begin
+ read_tfm_word;
+ end;
+ end;
+ for k:=1 to lh do begin
+ read_tfm_word;
+ if k=1 then @<Check the check sum@>;
+ if k=2 then @<Check the design size@>;
+ end;
+ end
+
+@ @<Read |char_info| entries@>=
+case font_ofm_level of
+ -1: begin
+ for k:=font_bc to font_ec do begin
+ read_tfm_word;
+ if b0>0 then begin {character |k| exists in the font}
+ vf[vf_ptr]:=k; incr(vf_ptr);
+ if vf_ptr=vf_size then vf_abort('I''m out of OVF memory!');
+ end;
+ end;
+ end;
+ 0: begin
+ for k:=font_bc to font_ec do
+ begin read_tfm_word;
+ if (b0*256+b1)>0 then {character |k| exists in the font}
+ begin vf[vf_ptr]:=k; incr(vf_ptr);
+ if vf_ptr=vf_size then vf_abort('I''m out of OVF memory!');
+ end;
+ read_tfm_word;
+ end;
+ end;
+ 1: begin
+ k:=font_bc;
+ while k<font_ec do begin
+ read_tfm_word;
+ if (b0*256+b1)>0 then begin {character |k| exists in the font}
+ vf[vf_ptr]:=k; incr(vf_ptr);
+ if vf_ptr=vf_size then vf_abort('I''m out of OVF memory!');
+ end;
+ read_tfm_word; read_tfm_word;
+ font_kprime:=k+(b0*256+b1);
+ for font_j:=k+1 to font_kprime do begin
+ vf[vf_ptr]:=font_j; incr(vf_ptr);
+ if vf_ptr=vf_size then vf_abort('I''m out of OVF memory!');
+ end;
+ k:=font_kprime;
+ for font_j:=1 to font_extra_words do
+ read_tfm_word;
+ end
+ end;
+end;
+
+@ @<Check the check sum@>=
+if b0+b1+b2+b3>0 then
+ if(b0<>vf[font_start[font_ptr]])or@|
+ (b1<>vf[font_start[font_ptr]+1])or@|
+ (b2<>vf[font_start[font_ptr]+2])or@|
+ (b3<>vf[font_start[font_ptr]+3]) then begin
+ print_ln('Check sum in OVF file being replaced by font metric check sum');
+@.Check sum...replaced...@>
+ vf[font_start[font_ptr]]:=b0;
+ vf[font_start[font_ptr]+1]:=b1;
+ vf[font_start[font_ptr]+2]:=b2;
+ vf[font_start[font_ptr]+3]:=b3;
+ end
+
+@ @<Check the design size@>=
+if(b0<>vf[font_start[font_ptr]+8])or@|
+ (b1<>vf[font_start[font_ptr]+9])or@|
+ (b2<>vf[font_start[font_ptr]+10])or@|
+ (b3<>vf[font_start[font_ptr]+11]) then
+ begin print_ln('Design size in OVF file being replaced by font metric design size');
+@.Design size...replaced...@>
+ vf[font_start[font_ptr]+8]:=b0;
+ vf[font_start[font_ptr]+9]:=b1;
+ vf[font_start[font_ptr]+10]:=b2;
+ vf[font_start[font_ptr]+11]:=b3;
+ end
+
+@ If no font directory has been specified, \.{DVI}-reading software
+is supposed to use the default font directory, which is a
+system-dependent place where the standard fonts are kept.
+The string variable |default_directory| contains the name of this area.
+@^system dependencies@>
+
+@d default_directory_name=='TeXfonts:' {change this to the correct name}
+@d default_directory_name_length=9 {change this to the correct length}
+
+@<Glob...@>=
+@!default_directory:packed array[1..default_directory_name_length] of char;
+
+@ @<Set init...@>=
+default_directory:=default_directory_name;
+
+@ The string |cur_name| is supposed to be set to the external name of the
+\.{TFM} file for the current font. This usually means that we need to
+prepend the name of the default directory, and
+to append the suffix `\.{.TFM}'. Furthermore, we change lower case letters
+to upper case, since |cur_name| is a \PASCAL\ string.
+@^system dependencies@>
+
+@<Move font name into the |cur_name| string@>=
+for k:=1 to name_length do cur_name[k]:=' ';
+if a=0 then begin
+ for k:=1 to default_directory_name_length do
+ cur_name[k]:=default_directory[k];
+ r:=default_directory_name_length;
+ end
+else r:=0;
+for k:=font_start[font_ptr]+14 to vf_ptr-1 do begin
+ incr(r);
+ if r+4>name_length then vf_abort('Font name too long for me!');
+@.Font name too long for me@>
+ if (vf[k]>="a")and(vf[k]<="z") then
+ cur_name[r]:=xchr[vf[k]-@'40]
+ else cur_name[r]:=xchr[vf[k]];
+ end;
+cur_name[r+1]:='.'; cur_name[r+2]:='T'; cur_name[r+3]:='F'; cur_name[r+4]:='M'
+
+
+@ It's convenient to have a subroutine
+that reads a |k|-byte number from |vf_file|.
+
+@d get_vf(#)==if eof(vf_file) then #:=0 @+else read_vf(#)
+
+@p function vf_read(@!k:integer):integer; {actually |1<=k<=4|}
+var @!b:byte; {input byte}
+@!a:integer; {accumulator}
+begin vf_count:=vf_count+k; get_vf(b); a:=b;
+if k=4 then if b>=128 then a:=a-256; {4-byte numbers are signed}
+while k>1 do begin
+ get_vf(b);
+ a:=256*a+b; decr(k);
+ end;
+vf_read:=a;
+end;
+
+@ The \.{VF} format supports arbitrary 4-byte character codes,
+but \.{VPL} format presently does not. But \.{OVP} does.
+
+@<Read and store a character packet@>=
+begin if temp_byte=long_char then
+ begin pl:=vf_read(4); c:=vf_read(4); reg_count:=vf_read(4);
+ {|pl[4]| |cc[4]| |tfm[4]|}
+ end
+else begin pl:=temp_byte; c:=vf_read(1); reg_count:=vf_read(3);
+ {|pl[1]| |cc[1]| |tfm[3]|}
+ end;
+if nonexistent(c) then vf_abort('Character ',c:1,' does not exist!');
+@.Character c does not exist@>
+if packet_start[c]<vf_size then
+ print_ln('Discarding earlier packet for character ',c:1);
+@.Discarding earlier packet...@>
+if reg_count<>tfm_width(c) then
+ print_ln('Incorrect OFM width for character ',c:1,' in OVF file');
+@.Incorrect OFM width...@>
+if pl<0 then vf_abort('Negative packet length!');
+@.Negative packet length@>
+packet_start[c]:=vf_ptr; vf_store(pl); packet_end[c]:=vf_ptr-1;
+packet_found:=true;
+end
+
+@ The preceding code requires a simple subroutine that evaluates \.{TFM} data.
+
+@p function tfm_width(@!c:integer):integer;
+var @!a:integer; {accumulator}
+@!k:index; {index into |tfm|}
+begin k:=width(c); {we assume that character |c| exists}
+a:=tfm[k];
+if a>=128 then a:=a-256;
+tfm_width:=((256*a+tfm[k+1])*256+tfm[k+2])*256+tfm[k+3];
+end;
+
+@* Basic output subroutines.
+Let us now define some procedures that will reduce the rest of \.{VFtoVP}'s
+work to a triviality.
+
+First of all, it is convenient to have an abbreviation for output to the
+\.{VPL} file:
+
+@d out(#)==write(vpl_file,#)
+
+@ In order to stick to standard \PASCAL, we use an |xchr| array to do
+appropriate conversion of ASCII codes. Three other little strings are
+used to produce |face| codes like \.{MIE}.
+
+@<Glob...@>=
+@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char;
+ {strings for output in the user's external character set}
+@!xchr:packed array [0..255] of char;
+@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char;
+ {handy string constants for |face| codes}
+
+@ @<Set init...@>=
+ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/
+ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/
+ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~?';@/
+HEX:='0123456789ABCDEF';@/
+for k:=0 to 255 do xchr[k]:='?';
+for k:=0 to @'37 do begin
+ xchr[k+@'40]:=ASCII_04[k+1];
+ xchr[k+@'100]:=ASCII_10[k+1];
+ xchr[k+@'140]:=ASCII_14[k+1];
+ end;
+MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE';
+
+@ The array |dig| will hold a sequence of digits to be output.
+
+@<Glob...@>=
+@!dig:array[0..11] of integer;
+
+@ Here, in fact, are two procedures that output
+|dig[j-1]|$\,\ldots\,$|dig[0]|, given $j>0$.
+
+@p procedure out_digs(j:integer); {outputs |j| digits}
+begin repeat decr(j); out(HEX[1+dig[j]]);
+ until j=0;
+end;
+@#
+procedure print_digs(j:integer); {prints |j| digits}
+begin repeat decr(j); print(HEX[1+dig[j]]);
+ until j=0;
+end;
+
+@ The |print_number| procedure indicates how |print_digs| can be used.
+This procedure can print in octal, decimal or hex notation.
+
+@d print_hex(#)==print_number(#,16)
+@d print_octal(#)==print_number(#,8)
+@d print_decimal(#)==print_number(#,10)
+
+@p procedure print_number(c:integer; form:integer); {prints value of |c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0;
+ end;
+if form=8 then
+ print('''') {an apostrophe indicates the octal notation}
+else if form=16 then
+ print('"') { a double apostrophe indicates the hexadecimal notation}
+else if form<>10 then begin
+ print_ln('Internal error: print_number (form)');
+ form:=16;
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+print_digs(j);
+end;
+
+@ A \.{VPL} file has nested parentheses, and we want to format the output
+so that its structure is clear. The |level| variable keeps track of the
+depth of nesting.
+
+@<Glob...@>=
+@!level:0..5;
+
+@ @<Set init...@>=
+level:=0;
+
+@ Three simple procedures suffice to produce the desired structure in the
+output.
+
+@p procedure out_ln; {finishes one line, indents the next}
+var l:0..5;
+begin write_ln(vpl_file);
+for l:=1 to level do out(' ');
+end;
+@#
+procedure left; {outputs a left parenthesis}
+begin incr(level); out('(');
+end;
+@#
+procedure right; {outputs a right parenthesis and finishes a line}
+begin decr(level); out(')'); out_ln;
+end;
+
+@ The value associated with a property can be output in a variety of
+ways. For example, we might want to output a {\mc BCPL} string that
+begins in |tfm[k]|:
+
+@p procedure out_BCPL(@!k:index); {outputs a string, preceded by a blank space}
+var l:0..39; {the number of bytes remaining}
+begin out(' '); l:=tfm[k];
+while l>0 do begin
+ incr(k); decr(l); out(xchr[tfm[k]]);
+ end;
+end;
+
+@ The property value might also be a sequence of |l| bytes, beginning
+in |tfm[k]|, that we would like to output in hex notation.
+The following procedure assumes that |l<=4|, but larger values of |l|
+could be handled easily by enlarging the |dig| array and increasing
+the upper bounds on |b| and |j|.
+
+@d out_octal_number(#)==out_number(#,8)
+@d out_decimal_number(#)==out_number(#,10)
+@d out_hex_number(#)==out_number(#,16)
+@d out_dec(#)==out_decimal_number(#)
+@d out_hex_char(#)==out_hex_number(#)
+
+@p procedure out_number(c:integer; form:integer); {outputs value of |c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0;
+ end;
+if form=8 then
+ out(' O ')
+else if form=10 then
+ out(' D ')
+else if form=16 then
+ out(' H ')
+else begin
+ print_ln('Internal error: print_number (form)');
+ form:=16;
+ out(' H ')
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+out_digs(j);
+end;
+@#
+procedure out_hex(@!k,@!l:index);
+ {outputs |l| bytes in hex}
+var a:0..@"7FFFFFFF; {accumulator for bits not yet output}
+@!b:0..32; {the number of significant bits in |a|}
+@!j:0..11; {the number of digits of output}
+begin
+out(' H ');
+a:=0; b:=0; j:=0;
+while l>0 do @<Reduce \(1)|l| by one, preserving the invariants@>;
+while (a>0)or(j=0) do begin
+ dig[j]:=a mod 16; a:=a div 16; incr(j);
+ end;
+out_digs(j);
+end;
+
+@ @<Reduce \(1)|l|...@>=
+begin decr(l);
+if tfm[k+l]<>0 then begin
+ while b>2 do begin
+ dig[j]:=a mod 16; a:=a div 16; b:=b-4; incr(j);
+ end;
+ case b of
+ 0: a:=tfm[k+l];
+ 1:a:=a+2*tfm[k+l];
+ 2:a:=a+4*tfm[k+l];
+ 3:a:=a+8*tfm[k+l];
+ end;
+ end;
+b:=b+8;
+end
+
+@ The property value may be a character, which is output in hex
+unless it is a letter or a digit. This procedure is the only place
+where a lowercase letter will be output to the \.{PL} file.
+@^system dependencies@>
+
+@p procedure out_char(@!c:integer); {outputs a character}
+begin if font_type>vanilla then
+ out_hex_char(c)
+else if (c>="0")and(c<="9") then
+ out(' C ',c-"0":1)
+else if (c>="A")and(c<="Z") then
+ out(' C ',ASCII_10[c-"A"+2])
+else if (c>="a")and(c<="z") then
+ out(' C ',ASCII_14[c-"a"+2])
+else out_hex_char(c);
+end;
+
+@ The property value might be a ``face'' byte, which is output in the
+curious code mentioned earlier, provided that it is less than 18.
+
+@p procedure out_face(@!k:index); {outputs a |face|}
+var s:0..1; {the slope}
+@!b:0..8; {the weight and expansion}
+begin if tfm[k]>=18 then out_hex(k,1)
+else begin
+ out(' F '); {specify face-code format}
+ s:=tfm[k] mod 2; b:=tfm[k] div 2;
+ out(MBL_string[1+(b mod 3)]);
+ out(RI_string[1+s]);
+ out(RCE_string[1+(b div 3)]);
+ end;
+end;
+
+@ And finally, the value might be a |fix_word|, which is output in
+decimal notation with just enough decimal places for \.{VPtoVF}
+to recover every bit of the given |fix_word|.
+
+All of the numbers involved in the intermediate calculations of
+this procedure will be nonnegative and less than $10\cdot2^{24}$.
+
+@p procedure out_fix(@!k:index); {outputs a |fix_word|}
+var a:0..@'7777; {accumulator for the integer part}
+@!f:integer; {accumulator for the fraction part}
+@!j:0..12; {index into |dig|}
+@!delta:integer; {amount if allowable inaccuracy}
+begin out(' R '); {specify real format}
+a:=(tfm[k]*16)+(tfm[k+1] div 16);
+f:=((tfm[k+1] mod 16)*@'400+tfm[k+2])*@'400+tfm[k+3];
+if a>@'3777 then @<Reduce \(2)negative to positive@>;
+@<Output the integer part, |a|, in decimal notation@>;
+@<Output the fraction part, $|f|/2^{20}$, in decimal notation@>;
+end;
+
+@ The following code outputs at least one digit even if |a=0|.
+
+@<Output the integer...@>=
+begin j:=0;
+repeat dig[j]:=a mod 10; a:=a div 10; incr(j);
+until a=0;
+out_digs(j);
+end
+
+@ And the following code outputs at least one digit to the right
+of the decimal point.
+
+@<Output the fraction...@>=
+begin out('.'); f:=10*f+5; delta:=10;
+repeat if delta>@'4000000 then f:=f+@'2000000-(delta div 2);
+out(f div @'4000000:1); f:=10*(f mod @'4000000); delta:=delta*10;
+until f<=delta;
+end;
+
+@ @<Reduce \(2)negative to positive@>=
+begin out('-'); a:=@'10000-a;
+if f>0 then begin
+ f:=@'4000000-f; decr(a);
+ end;
+end
+
+@* Outputting the TFM info.
+\TeX\ checks the information of a \.{TFM} file for validity as the
+file is being read in, so that no further checks will be needed when
+typesetting is going on. And when it finds something wrong, it justs
+calls the file ``bad,'' without identifying the nature of the problem,
+since \.{TFM} files are supposed to be good almost all of the time.
+
+Of course, a bad file shows up every now and again, and that's where
+\.{VFtoVP} comes in. This program wants to catch at least as many errors as
+\TeX\ does, and to give informative error messages besides.
+All of the errors are corrected, so that the \.{VPL} output will
+be correct (unless, of course, the \.{TFM} file was so loused up
+that no attempt is being made to fathom it).
+
+@ Just before each character is processed, its code is printed in hex
+notation. Up to eight such codes appear on a line; so we have a variable
+to keep track of how many are currently there. We also keep track of
+whether or not any errors have had to be corrected.
+
+@<Glob...@>=
+@!chars_on_line:0..8; {the number of characters printed on the current line}
+@!perfect:boolean; {was the file free of errors?}
+
+@ @<Set init...@>=
+chars_on_line:=0;@/
+perfect:=true; {innocent until proved guilty}
+
+@ Error messages are given with the help of the |bad| and |range_error|
+and |bad_char| macros:
+
+@d bad(#)==begin perfect:=false; if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print_ln('Bad OFM file: ',#);
+ end
+@.Bad OFM file@>
+@d range_error(#)==begin perfect:=false; print_ln(' ');
+ print(#,' index for character ');
+ print_hex(c); print_ln(' is too large;');
+ print_ln('so I reset it to zero.');
+ end
+@d bad_char_tail(#)==print_hex(#); print_ln('.');
+ end
+@d bad_char(#)==begin perfect:=false; if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print('Bad OFM file: ',#,' nonexistent character ');
+ bad_char_tail
+@d correct_bad_char_tail(#)==#(k,0)
+ end
+@d correct_bad_char_middle(#)==print_hex(#(k)); print_ln('.');
+ correct_bad_char_tail
+@d correct_bad_char(#)== begin perfect:=false;
+ if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print('Bad OFM file: ',#,' nonexistent character ');
+ correct_bad_char_middle
+
+@<Glob...@>=
+@!i:integer; {an index to words of a subfile}
+@!c:xchar_type; {a random character}
+@!d:0..3; {byte number in a word}
+@!k:index; {a random index}
+@!r:0..65535; {a random two-byte value}
+@!count:0..127; {for when we need to enumerate a small set}
+
+@ There are a lot of simple things to do, and they have to be done one
+at a time, so we might as well get down to business. The first things
+that \.{VFtoVP} will put into the \.{VPL} file appear in the header part.
+
+@<Do the header@>=
+begin
+case ofm_level of
+ 0: begin out('(OFMLEVEL H 0)'); out_ln; end;
+ 1: begin out('(OFMLEVEL H 1)'); out_ln; end;
+ end;
+if ofm_on then begin
+ left;
+ if font_dir<=7 then out('FONTDIR')
+ else out('NFONTDIR');
+ case font_dir mod 8 of
+ 0: out(' TL');
+ 1: out(' LT');
+ 2: out(' TR');
+ 3: out(' LB');
+ 4: out(' BL');
+ 5: out(' RT');
+ 6: out(' BR');
+ 7: out(' RB');
+ end;
+ right
+ end;
+font_type:=vanilla;
+if lh>=12 then begin
+ @<Set the true |font_type|@>;
+ if lh>=17 then begin
+ @<Output the family name@>;
+ if lh>=18 then @<Output the rest of the header@>;
+ end;
+ @<Output the character coding scheme@>;
+ end;
+@<Output the design size@>;
+@<Output the check sum@>;
+@<Output the |seven_bit_safe_flag|@>;
+end
+
+@ @<Output the check sum@>=
+left; out('CHECKSUM'); out_hex(check_sum,4);
+right
+
+@ Incorrect design sizes are changed to 10 points.
+
+@d bad_design(#)==begin bad('Design size ',#,'!');
+@.Design size wrong@>
+ print_ln('I''ve set it to 10 points.');
+ out(' D 10');
+ end
+
+@ @<Output the design size@>=
+left; out('DESIGNSIZE');
+if tfm[design_size]>127 then bad_design('negative')
+else if (tfm[design_size]=0)and(tfm[design_size+1]<16) then
+ bad_design('too small')
+else out_fix(design_size);
+right;
+out('(COMMENT DESIGNSIZE IS IN POINTS)'); out_ln;
+out('(COMMENT OTHER SIZES ARE MULTIPLES OF DESIGNSIZE)'); out_ln
+@.DESIGNSIZE IS IN POINTS@>
+
+@ Since we have to check two different {\mc BCPL} strings for validity,
+we might as well write a subroutine to make the check.
+
+@p procedure check_BCPL(@!k,@!l:index); {checks a string of length |<l|}
+var j:index; {runs through the string}
+@!c:integer; {character being checked}
+begin if tfm[k]>=l then begin
+ bad('String is too long; I''ve shortened it drastically.');
+@.String is too long...@>
+ tfm[k]:=1;
+ end;
+for j:=k+1 to k+tfm[k] do begin
+ c:=tfm[j];
+ if (c="(")or(c=")") then
+ begin bad('Parenthesis in string has been changed to slash.');
+@.Parenthesis...changed to slash@>
+ tfm[j]:="/";
+ end
+ else if (c<" ")or(c>"~") then begin
+ bad('Nonstandard ASCII code has been blotted out.');
+@.Nonstandard ASCII code...@>
+ tfm[j]:="?";
+ end
+ else if (c>="a")and(c<="z") then tfm[j]:=c+"A"-"a"; {upper-casify letters}
+ end;
+end;
+
+@ The |font_type| starts out |vanilla|; possibly we need to reset it.
+
+@<Set the true |font_type|@>=
+begin check_BCPL(scheme,40);
+if (tfm[scheme]>=11)and@|(tfm[scheme+1]="T")and@|
+ (tfm[scheme+2]="E")and@|(tfm[scheme+3]="X")and@|
+ (tfm[scheme+4]=" ")and@|(tfm[scheme+5]="M")and@|
+ (tfm[scheme+6]="A")and@|(tfm[scheme+7]="T")and@|
+ (tfm[scheme+8]="H")and@|(tfm[scheme+9]=" ") then begin
+ if (tfm[scheme+10]="S")and(tfm[scheme+11]="Y") then font_type:=mathsy
+ else if (tfm[scheme+10]="E")and(tfm[scheme+11]="X") then font_type:=mathex;
+ end;
+end
+
+@ @<Output the character coding scheme@>=
+left; out('CODINGSCHEME');
+out_BCPL(scheme);
+right
+
+@ @<Output the family name@>=
+left; out('FAMILY');
+check_BCPL(family,20);
+out_BCPL(family);
+right
+
+@ @<Output the rest of the header@>=
+begin left; out('FACE'); out_face(random_word+3); right;
+for i:=18 to lh-1 do begin
+ left; out('HEADER D ',i:1);
+ out_hex(check_sum+4*i,@,4); right;
+ end;
+end
+
+@ This program does not check to see if the |seven_bit_safe_flag| has the
+correct setting, i.e., if it really reflects the seven-bit-safety of
+the \.{TFM} file; the stated value is merely put into the \.{VPL} file.
+The \.{VPtoVF} program will store a correct value and give a warning
+message if a file falsely claims to be safe.
+
+@<Output the |seven_bit_safe_flag|@>=
+if (lh>17) and (tfm[random_word]>127) then begin
+ left; out('SEVENBITSAFEFLAG FALSE'); right;
+ end
+
+@ The next thing to take care of is the list of parameters.
+
+@<Do the parameters@>=
+if np>0 then begin
+ left; out('FONTDIMEN'); out_ln;
+ for i:=1 to np do @<Check and output the $i$th parameter@>;
+ right;
+ end;
+@<Check to see if |np| is complete for this font type@>;
+
+@ @<Check to see if |np|...@>=
+if (font_type=mathsy)and(np<>22) then
+ print_ln('Unusual number of fontdimen parameters for a math symbols font (',
+@.Unusual number of fontdimen...@>
+ np:1,' not 22).')
+else if (font_type=mathex)and(np<>13) then
+ print_ln('Unusual number of fontdimen parameters for an extension font (',
+ np:1,' not 13).')
+
+@ All |fix_word| values except the design size and the first parameter
+will be checked to make sure that they are less than 16.0 in magnitude,
+using the |check_fix| macro:
+
+@d check_fix_tail(#)==bad(#,' ',i:1,' is too big;');
+ print_ln('I have set it to zero.');
+ end
+@d check_fix(#)==if (tfm[#]>0)and(tfm[#]<255) then
+ begin tfm[#]:=0; tfm[(#)+1]:=0; tfm[(#)+2]:=0; tfm[(#)+3]:=0;
+ check_fix_tail
+
+@<Check and output the $i$th parameter@>=
+begin left;
+if i=1 then out('SLANT') {this parameter is not checked}
+else begin check_fix(param(i))('Parameter');@/
+@.Parameter n is too big@>
+ @<Output the name of parameter $i$@>;
+ end;
+out_fix(param(i)); right;
+end
+
+@ @<Output the name...@>=
+if i<=7 then case i of
+ 2:out('SPACE');@+3:out('STRETCH');@+4:out('SHRINK');
+ 5:out('XHEIGHT');@+6:out('QUAD');@+7:out('EXTRASPACE')@+end
+else if (i<=22)and(font_type=mathsy) then case i of
+ 8:out('NUM1');@+9:out('NUM2');@+10:out('NUM3');
+ 11:out('DENOM1');@+12:out('DENOM2');
+ 13:out('SUP1');@+14:out('SUP2');@+15:out('SUP3');
+ 16:out('SUB1');@+17:out('SUB2');
+ 18:out('SUPDROP');@+19:out('SUBDROP');
+ 20:out('DELIM1');@+21:out('DELIM2');
+ 22:out('AXISHEIGHT')@+end
+else if (i<=13)and(font_type=mathex) then
+ if i=8 then out('DEFAULTRULETHICKNESS')
+ else out('BIGOPSPACING',i-8:1)
+else out('PARAMETER D ',i:1)
+
+@ @<Glob...@>=
+@!start_counter,@!base_counter,@!number_entries:integer;
+@!value:integer;
+
+@ @<Do the ivalue parameters@>=
+if nki>0 then begin
+ start_counter:=ivalues_start*4;
+ base_counter:=ivalues_base*4;
+ for i:=0 to nki-1 do @<Check and output the $i$th ivalue table@>;
+ end;
+
+@ @<Check and output the $i$th ivalue table@>=
+begin
+left; out('FONTIVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('IVALUE'); out_hex_number(j); out_ln;
+ value:=256*tfm[base_counter+2]+tfm[base_counter+3];
+ left; out('IVALUEVAL'); out_hex_number(value); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;;
+end;
+
+@ @<Do the fvalue parameters@>=
+if nkf>0 then begin
+ start_counter:=fvalues_start*4;
+ base_counter:=fvalues_base*4;
+ for i:=0 to nkf-1 do @<Check and output the $i$th fvalue table@>;
+ end;
+
+@ @<Check and output the $i$th fvalue table@>=
+begin
+left; out('FONTFVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('FVALUE'); out_hex_number(j); out_ln;
+ left; out('FVALUEVAL'); out_fix(base_counter); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the mvalue parameters@>=
+if nkm>0 then begin
+ start_counter:=mvalues_start*4;
+ base_counter:=mvalues_base*4;
+ for i:=0 to nkm-1 do @<Check and output the $i$th mvalue table@>;
+ end;
+
+@ @<Check and output the $i$th mvalue table@>=
+begin
+left; out('FONTMVALUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('MVALUE'); out_hex_number(j); out_ln;
+ left; out('MVALUEVAL'); out_fix(base_counter); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the rule parameters@>=
+if nkr>0 then begin
+ start_counter:=rules_start*4;
+ base_counter:=rules_base*4;
+ for i:=0 to nkr-1 do @<Check and output the $i$th rule table@>;
+ end;
+
+@ @<Check and output the $i$th rule table@>=
+begin
+left; out('FONTRULE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('RULE'); out_hex_number(j); out_ln;
+ left; out('RULEWD'); out_fix(base_counter); right;
+ left; out('RULEHT'); out_fix(base_counter+4); right;
+ left; out('RULEDP'); out_fix(base_counter+8); right;
+ right;
+ base_counter:=base_counter+12;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the glue parameters@>=
+if nkg>0 then begin
+ start_counter:=glues_start*4;
+ base_counter:=glues_base*4;
+ for i:=0 to nkg-1 do @<Check and output the $i$th glue table@>;
+ end;
+
+@ @<Glob...@>=
+@!glue_subtype,@!glue_argument_kind,@!glue_stretch_order,
+@!glue_shrink_order,@!glue_argument:integer;
+
+@ @<Check and output the $i$th glue table@>=
+begin
+left; out('FONTGLUE'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('GLUE'); out_hex_number(j); out_ln;
+ glue_subtype:=tfm[base_counter] div 16;
+ glue_argument_kind:=tfm[base_counter] mod 16;
+ glue_stretch_order:=tfm[base_counter+1] div 16;
+ glue_shrink_order:=tfm[base_counter+1] mod 16;
+ glue_argument:=tfm[base_counter+2]*256+tfm[base_counter+3];
+ left;
+ out('GLUETYPE');
+ case glue_subtype of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ end;
+ right;
+ case glue_argument_kind of
+ 1: begin
+ left; out('GLUERULE'); out_hex_number(glue_argument); right;
+ end;
+ 2: begin
+ left; out('GLUECHAR'); out_hex_number(glue_argument); right;
+ end;
+ end;
+ left;
+ out('GLUESTRETCHORDER');
+ case glue_stretch_order of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ 4: out(' H 4');
+ end;
+ right;
+ left;
+ out('GLUESHRINKORDER');
+ case glue_shrink_order of
+ 0: out(' H 0');
+ 1: out(' H 1');
+ 2: out(' H 2');
+ 3: out(' H 3');
+ 4: out(' H 4');
+ end;
+ right;
+ left; out('GLUEWD'); out_fix(base_counter+4); right;
+ left; out('GLUESTRETCH'); out_fix(base_counter+8); right;
+ left; out('GLUESHRINK'); out_fix(base_counter+12); right;
+ right;
+ base_counter:=base_counter+16;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ @<Do the penalty parameters@>=
+if nkp>0 then begin
+ start_counter:=penalties_start*4;
+ base_counter:=penalties_base*4;
+ for i:=0 to nkp-1 do @<Check and output the $i$th penalty table@>;
+ end;
+
+@ @<Check and output the $i$th penalty table@>=
+begin
+left; out('FONTPENALTY'); out_hex_number(i); out_ln;
+number_entries:=256*tfm[start_counter+2]+tfm[start_counter+3];
+for j:=0 to number_entries-1 do begin
+ left; out('PENALTY'); out_hex_number(j); out_ln;
+ value:=256*tfm[base_counter+2]+tfm[base_counter+3];
+ left; out('PENALTYVAL'); out_hex_number(value); right;
+ right;
+ base_counter:=base_counter+4;
+ end;
+right;
+start_counter:=start_counter+4;
+end;
+
+@ We need to check the range of all the remaining |fix_word| values,
+and to make sure that |width[0]=0|, etc.
+
+@d nonzero_fix(#)==(tfm[#]>0)or(tfm[#+1]>0)or(tfm[#+2]>0)or(tfm[#+3]>0)
+
+@<Check the |fix_word| entries@>=
+if nonzero_fix(4*width_base) then bad('width[0] should be zero.');
+@.should be zero@>
+if nonzero_fix(4*height_base) then bad('height[0] should be zero.');
+if nonzero_fix(4*depth_base) then bad('depth[0] should be zero.');
+if nonzero_fix(4*italic_base) then bad('italic[0] should be zero.');
+for i:=0 to nw-1 do check_fix(4*(width_base+i))('Width');
+@.Width n is too big@>
+for i:=0 to nh-1 do check_fix(4*(height_base+i))('Height');
+@.Height n is too big@>
+for i:=0 to nd-1 do check_fix(4*(depth_base+i))('Depth');
+@.Depth n is too big@>
+for i:=0 to ni-1 do check_fix(4*(italic_base+i))('Italic correction');
+@.Italic correction n is too big@>
+if nk>0 then for i:=0 to nk-1 do check_fix(kern(i))('Kern');
+@.Kern n is too big@>
+
+@ The ligature/kerning program comes next. Before we can put it out in
+\.{PL} format, we need to make a table of ``labels'' that will be inserted
+into the program. For each character |c| whose |tag| is |lig_tag| and
+whose starting address is |r|, we will store the pair |(c,r)| in the
+|label_table| array. If there's a boundary-char program starting at~|r|,
+we also store the pair |(256,r)|.
+This array is sorted by its second components, using the
+simple method of straight insertion.
+
+@<Glob...@>=
+@!label_table:array[xxxchar_type] of record
+@!cc:xchar_type;@!rr:0..lig_size;ischar:boolean;end;
+@!label_ptr:xxchar_type; {the largest entry in |label_table|}
+@!sort_ptr:xxchar_type; {index into |label_table|}
+@!boundary_char:xchar_type; {boundary character, or |xmax_char| if none}
+@!bchar_label:0..xmax_label; {beginning of boundary character program}
+
+@ @<Set init...@>=
+boundary_char:=xmax_char; bchar_label:=xmax_label;@/
+label_ptr:=0; label_table[0].rr:=0; {a sentinel appears at the bottom}
+
+@ We'll also identify and remove inaccessible program steps, using the
+|activity| array.
+
+@d unreachable=0 {a program step not known to be reachable}
+@d pass_through=1 {a program step passed through on initialization}
+@d accessible=2 {a program step that can be relevant}
+
+@<Glob...@>=
+@!activity:array[0..lig_size] of unreachable..accessible;
+@!ai,@!acti:0..lig_size; {indices into |activity|}
+
+@ @<Do the ligatures and kerns@>=
+if nl>0 then begin
+ for ai:=0 to (nl-1) do activity[ai]:=unreachable;
+ @<Check for a boundary char@>;
+ end;
+@<Build the label table@>;
+if nl>0 then begin
+ left; out('LIGTABLE'); out_ln;@/
+ @<Compute the |activity| array@>;
+ @<Output and correct the ligature/kern program@>;
+ right;
+ @<Check for ligature cycles@>;
+ end
+
+@ We build the label table even when |nl=0|, because this catches errors
+that would not otherwise be detected.
+
+@<Build...@>=
+for c:=bc to ec do
+if (tag(c)=lig_tag) or (ctag(c)) then begin
+ r:=rremainder(c);
+ if (l_skip_byte(lig_step(r)) div 256)=0 then begin
+ if r<nl then begin
+ if l_skip_byte(lig_step(r))>stop_flag then begin
+ r:=256*l_op_byte(lig_step(r))+l_remainder(lig_step(r));
+ if r<nl then if activity[rremainder(c)]=unreachable then
+ activity[rremainder(c)]:=pass_through;
+ end;
+ end;
+ end;
+ if r>=nl then begin
+ perfect:=false; print_ln(' ');
+ print('Ligature/kern starting index for character '); print_hex(c);
+ print_ln(' is too large;'); print_ln('so I removed it.'); set_no_tag(c);
+ set_no_ctag(c);
+@.Ligature/kern starting index...@>
+ end
+ else @<Insert |(c,r)| into |label_table|@>;
+ end;
+label_table[label_ptr+1].rr:=lig_size; {put ``infinite'' sentinel at the end}
+
+@ @<Insert |(c,r)|...@>=
+begin sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|}
+while label_table[sort_ptr].rr>r do begin
+ label_table[sort_ptr+1]:=label_table[sort_ptr];
+ decr(sort_ptr); {move the hole}
+ end;
+label_table[sort_ptr+1].ischar:=not ctag(c);
+if ctag(c) then
+ label_table[sort_ptr+1].cc:=char_param(c,0)
+else
+ label_table[sort_ptr+1].cc:=c;
+label_table[sort_ptr+1].rr:=r; {fill the hole}
+incr(label_ptr); activity[r]:=accessible;
+end
+
+@ @<Check for a bound...@>=
+if l_skip_byte(lig_step(0))=255 then begin
+ left; out('BOUNDARYCHAR');
+ boundary_char:=l_next_char(lig_step(0)); out_char(boundary_char); right;
+ activity[0]:=pass_through;
+ end;
+if l_skip_byte(lig_step(nl-1))=255 then begin
+ r:=256*l_op_byte(lig_step(nl-1))+l_remainder(lig_step(nl-1));
+ if r>=nl then begin
+ perfect:=false; print_ln(' ');
+ print('Ligature/kern starting index for boundarychar is too large;');
+ print_ln('so I removed it.');
+@.Ligature/kern starting index...@>
+ end
+ else begin
+ label_ptr:=1; label_table[1].cc:=xmax_char;
+ label_table[1].rr:=r;
+ bchar_label:=r; activity[r]:=accessible;
+ end;
+ activity[nl-1]:=pass_through;
+ end
+
+@ @<Compute the |activity| array@>=
+for ai:=0 to (nl-1) do
+if (l_skip_byte(lig_step(ai)) div 256)=1 then
+ activity[ai]:=accessible
+else if activity[ai]=accessible then begin
+ r:=l_skip_byte(lig_step(ai));
+ if r<stop_flag then begin
+ r:=r+ai+1;
+ if r>=nl then begin
+ bad('Ligature/kern step ',ai:1,' skips too far;');
+@.Lig...skips too far@>
+ print_ln('I made it stop.'); set_l_skip_byte(lig_step(ai),stop_flag);
+ end
+ else activity[r]:=accessible;
+ end;
+ end
+
+@ We ignore |pass_through| items, which don't need to be mentioned in
+the \.{PL} file.
+
+@<Output and correct the ligature...@>=
+sort_ptr:=1; {point to the next label that will be needed}
+for acti:=0 to nl-1 do if activity[acti]<>pass_through then begin
+ i:=acti; @<Take care of commenting out unreachable steps@>;
+ @<Output any labels for step $i$@>;
+ @<Output step $i$ of the ligature/kern program@>;
+ end;
+if level=2 then right {the final step was unreachable}
+
+@ @<Globals...@>=
+@!output_clabels:array[0..256] of boolean;
+@!clabel_runner:integer;
+@!cprime:integer;
+
+@ @<Set init...@>=
+for clabel_runner:=0 to 256 do
+ output_clabels[clabel_runner]:=false;
+
+@ @<Output any labels...@>=
+while i=label_table[sort_ptr].rr do begin
+ if not label_table[sort_ptr].ischar then begin
+ if not output_clabels[label_table[sort_ptr].cc] then begin
+ output_clabels[label_table[sort_ptr].cc]:=true;
+ left;
+ out('CLABEL');
+ out_char(label_table[sort_ptr].cc);
+ right;
+ end
+ end
+ else begin
+ left;
+ out('LABEL');
+ if label_table[sort_ptr].cc=xmax_char then out(' BOUNDARYCHAR')
+ else out_char(label_table[sort_ptr].cc);
+ right;
+ end;
+ incr(sort_ptr);
+ end
+
+@ @<Take care of commenting out...@>=
+if activity[i]=unreachable then begin
+ if level=1 then begin
+ left; out('COMMENT THIS PART OF THE PROGRAM IS NEVER USED!'); out_ln;
+ end
+ end
+else if level=2 then right
+
+@ @<Output step $i$...@>=
+begin k:=lig_step(i);
+if (l_skip_byte(k) div 256)=1 then begin
+ case l_op_byte(k) of
+ 17: begin
+ left; out('CPEN');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k));
+ right;
+ end;
+ 18: begin
+ left; out('CGLUE');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k));
+ right;
+ end;
+ 19: begin
+ left; out('CPENGLUE');
+ out_hex_number(l_next_char(k));
+ out_hex_number(l_remainder(k) div 256);
+ out_hex_number(l_remainder(k) mod 256);
+ right;
+ end;
+ 20: begin
+ left; out('CKRN');
+ out_hex_number(l_next_char(k));
+ r:=l_remainder(k);
+ if r>=nk then begin
+ bad('Kern index too large.');
+@.Kern index too large@>
+ out(' R 0.0');
+ end
+ else out_fix(kern(r));
+ right;
+ end;
+ end;
+ end
+else if l_skip_byte(k)>stop_flag then begin
+ if (256*l_op_byte(k)+l_remainder(k))>=nl then
+ bad('Ligature unconditional stop command address is too big.');
+@.Ligature unconditional stop...@>
+ end
+else if l_op_byte(k)>=kern_flag then @<Output a kern step@>
+else @<Output a ligature step@>;
+if (l_skip_byte(k) mod 256)>0 then
+ if level=1 then @<Output either \.{SKIP} or \.{STOP}@>;
+end
+
+@ The \.{SKIP} command is a bit tricky, because we will be omitting all
+inaccessible commands.
+
+@<Output either...@>=
+begin if (l_skip_byte(k) mod 256)>=stop_flag then out('(STOP)')
+else begin
+ count:=0;
+ for ai:=(i+1) to (i+(l_skip_byte(k) mod 256)) do
+ if activity[ai]=accessible then incr(count);
+ out('(SKIP D ',count:1,')'); {possibly $count=0$, so who cares}
+ end;
+out_ln;
+end
+
+@ @<Output a kern step@>=
+begin if nonexistent(l_next_char(k)) then
+ if l_next_char(k)<>boundary_char then
+ correct_bad_char('Kern step for')(l_next_char)(set_l_next_char);
+@.Kern step for nonexistent...@>
+left; out('KRN'); out_char(l_next_char(k));
+r:=256*(l_op_byte(k)-kern_flag)+l_remainder(k);
+if r>=nk then begin
+ bad('Kern index too large.');
+@.Kern index too large@>
+ out(' R 0.0');
+ end
+else out_fix(kern(r));
+right;
+end
+
+@ @<Output a ligature step@>=
+begin if nonexistent(l_next_char(k)) then
+ if l_next_char(k)<>boundary_char then
+ correct_bad_char('Ligature step for')(l_next_char)(set_l_next_char);
+@.Ligature step for nonexistent...@>
+if nonexistent(l_remainder(k)) then
+correct_bad_char('Ligature step produces the')(l_remainder)(set_l_remainder);
+@.Ligature step produces...@>
+left; r:=l_op_byte(k);
+if (r=4)or((r>7)and(r<>11)) then begin
+ print_ln('Ligature step with nonstandard code changed to LIG');
+ r:=0; set_l_op_byte(k,0);
+ end;
+if r mod 4>1 then out('/');
+out('LIG');
+if odd(r) then out('/');
+while r>3 do begin
+ out('>'); r:=r-4;
+ end;
+out_char(l_next_char(k)); out_char(l_remainder(k)); right;
+end
+
+@ The last thing on \.{VFtoVP}'s agenda is to go through the
+list of |char_info| and spew out the information about each individual
+character.
+
+@<Do the characters@>=
+sort_ptr:=0; {this will suppress `\.{STOP}' lines in ligature comments}
+c:=bc;
+while (c<=ec) do begin
+ if width_index(c)>0 then begin
+ if chars_on_line=8 then begin
+ print_ln(' '); chars_on_line:=1;
+ end
+ else begin
+ if chars_on_line>0 then print(' ');
+ incr(chars_on_line);
+ end;
+ for cprime:=c to (c+no_repeats(c)) do begin
+ print_hex(cprime); {progress report}
+ left; out('CHARACTER'); out_char(cprime); out_ln;
+ @<Output the character's width@>;
+ if height_index(c)>0 then @<Output the character's height@>;
+ if depth_index(c)>0 then @<Output the character's depth@>;
+ if italic_index(c)>0 then @<Output the italic correction@>;
+ case tag(c) of
+ no_tag: do_nothing;
+ lig_tag: @<Output the applicable part of the ligature/kern
+ program as a comment@>;
+ list_tag: @<Output the character link unless there is a problem@>;
+ ext_tag: @<Output an extensible character recipe@>;
+ end; {there are no other cases}
+ for i:=0 to npc-1 do begin
+ if char_param(c,i)<>0 then begin
+ left;
+ if i<nki then begin
+ out('CHARIVALUE'); out_hex_number(i);
+ end
+ else if i<(nki+nkf) then begin
+ out('CHARFVALUE'); out_hex_number(i-nki);
+ end
+ else if i<(nki+nkf+nkr) then begin
+ out('CHARRULE'); out_hex_number(i-nki-nkf);
+ end
+ else if i<(nki+nkf+nkr+nkg) then begin
+ out('CHARGLUE'); out_hex_number(i-nki-nkf-nkr);
+ end
+ else if i<(nki+nkf+nkr+nkg+nkp) then begin
+ out('CHARPENALTY'); out_hex_number(i-nki-nkf-nkr-nkg);
+ end;
+ out_hex_number(char_param(c,i));
+ right;
+ end;
+ end;
+ if not do_map(cprime) then goto final_end;
+ right;
+ end;
+ end;
+ c:=c+1+no_repeats(c);
+ end
+
+@ @<Output the character's width@>=
+if width_index(c)>=nw then range_error('Width')
+@.Width index for char...@>
+else begin left; out('CHARWD'); out_fix(width(c)); right;
+ end
+
+@ @<Output the character's height@>=
+if height_index(c)>=nh then range_error('Height')
+@.Height index for char...@>
+else begin left; out('CHARHT'); out_fix(height(c)); right;
+ end
+
+@ @<Output the character's depth@>=
+if depth_index(c)>=nd then range_error('Depth')
+@.Depth index for char@>
+else begin left; out('CHARDP'); out_fix(depth(c)); right;
+ end
+
+@ @<Output the italic correction@>=
+if italic_index(c)>=ni then range_error('Italic correction')
+@.Italic correction index for char...@>
+else begin left; out('CHARIC'); out_fix(italic(c)); right;
+ end
+
+@ @<Output the applicable part of the ligature...@>=
+begin left; out('COMMENT'); out_ln;@/
+i:=rremainder(c); r:=lig_step(i);
+if (l_skip_byte(r) mod 256)>stop_flag
+then i:=256*l_op_byte(r)+l_remainder(r);
+repeat @<Output step...@>;
+if (l_skip_byte(k) mod 256)>=stop_flag then i:=nl
+else i:=i+1+(l_skip_byte(k) mod 256);
+until i>=nl;
+right;
+end
+
+@ We want to make sure that there is no cycle of characters linked together
+by |list_tag| entries, since such a cycle would get \TeX\ into an endless
+loop. If such a cycle exists, the routine here detects it when processing
+the largest character code in the cycle.
+
+@<Output the character link unless there is a problem@>=
+begin r:=rremainder(c);
+if nonexistent(r) then begin
+ bad_char('Character list link to')(r); set_no_tag(c);
+@.Character list link...@>
+ end
+else begin
+ while (r<c)and(tag(r)=list_tag) do r:=rremainder(r);
+ if r=c then begin
+ bad('Cycle in a character list!');
+@.Cycle in a character list@>
+ print('Character '); print_hex(c);
+ print_ln(' now ends the list.');
+ set_no_tag(c);
+ end
+ else begin
+ left; out('NEXTLARGER'); out_char(rremainder(c));
+ right;
+ end;
+ end;
+end
+
+@ @<Output an extensible character recipe@>=
+if rremainder(c)>=ne then begin
+ range_error('Extensible'); set_no_tag(c);
+@.Extensible index for char@>
+ end
+else begin
+ left; out('VARCHAR'); out_ln;
+ @<Output the extensible pieces that exist@>;
+ right;
+ end
+
+@ @<Glob...@>=
+@!exten_char:integer;
+
+@ @<Output the extensible pieces that...@>=
+for d:=0 to 3 do begin
+ if not ofm_on then begin
+ k:=exten(c)+d;
+ exten_char:=tfm[k];
+ end
+ else begin
+ k:=exten(c)+2*d;
+ exten_char:=256*tfm[k]+tfm[k+1];
+ end;
+ if (d=3)or(exten_char>0) then begin
+ left;
+ case d of
+ 0:out('TOP');@+1:out('MID');@+2:out('BOT');@+3:out('REP')@+end;
+ if nonexistent(exten_char) then out_char(c)
+ else out_char(exten_char);
+ right;
+ end
+ end
+
+@ Some of the extensible recipes may not actually be used, but \TeX\ will
+complain about them anyway if they refer to nonexistent characters.
+Therefore \.{VFtoVP} must check them too.
+
+@<Check the extensible recipes@>=
+if ne>0 then
+ for c:=0 to ne-1 do
+ for d:=0 to 3 do begin
+ if not ofm_on then begin
+ k:=4*(exten_base+c)+d;
+ exten_char:=tfm[k];
+ end
+ else begin
+ k:=4*(exten_base+c)+2*d;
+ exten_char:=256*tfm[k]+tfm[k+1];
+ end;
+ if (exten_char>0)or(d=3) then begin
+ if nonexistent(exten_char) then begin
+ bad_char('Extensible recipe involves the')(exten_char);
+@.Extensible recipe involves...@>
+ if d<3 then begin
+ if not ofm_on then begin
+ tfm[k]:=0;
+ end
+ else begin
+ tfm[k]:=0;
+ tfm[k+1]:=0;
+ end;
+ end;
+ end;
+ end;
+ end
+
+@* Checking for ligature loops.
+We have programmed almost everything but the most interesting calculation of
+all, which has been saved for last as a special treat. \TeX's extended
+ligature mechanism allows unwary users to specify sequences of ligature
+replacements that never terminate. For example, the pair of commands
+$$\.{(/LIG $x$ $y$) (/LIG $y$ $x$)}$$
+alternately replaces character $x$ by character $y$ and vice versa. A similar
+loop occurs if \.{(LIG/ $z$ $y$)} occurs in the program for $x$ and
+ \.{(LIG/ $z$ $x$)} occurs in the program for $y$.
+
+More complicated loops are also possible. For example, suppose the ligature
+programs for $x$ and $y$ are
+$$\vcenter{\halign{#\hfil\cr
+\.{(LABEL $x$)(/LIG/ $z$ $w$)(/LIG/> $w$ $y$)} \dots,\cr
+\.{(LABEL $y$)(LIG $w$ $x$)} \dots;\cr}}$$
+then the adjacent characters $xz$ change to $xwz$, $xywz$, $xxz$, $xxwz$,
+\dots, ad infinitum.
+
+@ To detect such loops, \.{TFtoPL} attempts to evaluate the function
+$f(x,y)$ for all character pairs $x$ and~$y$, where $f$ is defined as
+follows: If the current character is $x$ and the next character is
+$y$, we say the ``cursor'' is between $x$ and $y$; when the cursor
+first moves past $y$, the character immediately to its left is
+$f(x,y)$. This function is defined if and only if no infinite loop is
+generated when the cursor is between $x$ and~$y$.
+
+The function $f(x,y)$ can be defined recursively. It turns out that all pairs
+$(x,y)$ belong to one of five classes. The simplest class has $f(x,y)=y$;
+this happens if there's no ligature between $x$ and $y$, or in the cases
+\.{LIG/>} and \.{/LIG/>>}. Another simple class arises when there's a
+\.{LIG} or \.{/LIG>} between $x$ and~$y$, generating the character~$z$;
+then $f(x,y)=z$. Otherwise we always have $f(x,y)$ equal to
+either $f(x,z)$ or $f(z,y)$ or $f(f(x,z),y)$, where $z$ is the inserted
+ligature character.
+
+The first two of these classes can be merged; we can also consider
+$(x,y)$ to belong to the simple class when $f(x,y)$ has been evaluated.
+For technical reasons we allow $x$ to be 256 (for the boundary character
+at the left) or 257 (in cases when an error has been detected).
+
+For each pair $(x,y)$ having a ligature program step, we store
+$(x,y)$ in a hash table from which the values $z$ and $class$ can be read.
+
+@d simple=0 {$f(x,y)=z$}
+@d left_z=1 {$f(x,y)=f(z,y)$}
+@d right_z=2 {$f(x,y)=f(x,z)$}
+@d both_z=3 {$f(x,y)=f(f(x,z),y)$}
+@d pending=4 {$f(x,y)$ is being evaluated}
+
+@<Glob...@>=
+@!hash:array[0..hash_size] of integer;
+@!class:array[0..hash_size] of simple..pending;
+@!lig_z:array[0..hash_size] of xxchar_type;
+@!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|}
+@!hash_list:array[0..hash_size] of 0..hash_size;
+ {list of those nonzero entries}
+@!h,@!hh:0..hash_size; {indices into the hash table}
+@!x_lig_cycle,@!y_lig_cycle:xchar_type; {problematic ligature pair}
+
+@ @<Check for ligature cycles@>=
+hash_ptr:=0; y_lig_cycle:=xmax_char;
+for hh:=0 to hash_size do hash[hh]:=0; {clear the hash table}
+for c:=bc to ec do if tag(c)=lig_tag then begin
+ i:=rremainder(c);
+ if (l_skip_byte(lig_step(i)) mod 256)>stop_flag then
+ i:=256*l_op_byte(lig_step(i))+l_remainder(lig_step(i));
+ @<Enter data for character $c$ starting at location |i| in the hash table@>;
+ end;
+if bchar_label<nl then begin
+ c:=xmax_char; i:=bchar_label;
+ @<Enter data for character $c$ starting at location |i| in the hash table@>;
+ end;
+if hash_ptr=hash_size then begin
+ print_ln('Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ goto final_end;
+ end;
+for hh:=1 to hash_ptr do begin
+ r:=hash_list[hh];
+ if class[r]>simple then {make sure $f$ is defined}
+ r:=f(r,(hash[r]-1)div xmax_char,(hash[r]-1)mod xmax_char);
+ end;
+if y_lig_cycle<xmax_char then begin
+ print('Infinite ligature loop starting with ');
+@.Infinite ligature loop...@>
+ if x_lig_cycle=xmax_char
+ then print('boundary')@+else print_hex(x_lig_cycle);
+ print(' and '); print_hex(y_lig_cycle); print_ln('!');
+ out('(INFINITE LIGATURE LOOP MUST BE BROKEN!)'); goto final_end;
+ end
+
+@ @<Enter data for character $c$...@>=
+repeat hash_input; k:=l_skip_byte(lig_step(i));
+if k>=stop_flag then i:=nl
+else i:=i+1+k;
+until i>=nl
+
+@ We use an ``ordered hash table'' with linear probing, because such a table
+is efficient when the lookup of a random key tends to be unsuccessful.
+
+@p procedure hash_input; {enter data for character |c| and command |i|}
+label 30; {go here for a quick exit}
+var @!cc:simple..both_z; {class of data being entered}
+@!zz:char_type; {function value or ligature character being entered}
+@!y:char_type; {the character after the cursor}
+@!key:integer; {value to be stored in |hash|}
+@!t:integer; {temporary register for swapping}
+begin if hash_ptr=hash_size then goto 30;
+@<Compute the command parameters |y|, |cc|, and |zz|@>;
+key:=xmax_char*c+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size;
+while hash[h]>0 do begin
+ if hash[h]<=key then begin
+ if hash[h]=key then goto 30; {unused ligature command}
+ t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion}
+ t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap}
+ t:=lig_z[h]; lig_z[h]:=zz; zz:=t;
+ end;
+ if h>0 then decr(h)@+else h:=hash_size;
+ end;
+hash[h]:=key; class[h]:=cc; lig_z[h]:=zz;
+incr(hash_ptr); hash_list[hash_ptr]:=h;
+30:end;
+
+@ We must store kern commands as well as ligature commands, because
+the former might make the latter inapplicable.
+
+@<Compute the command param...@>=
+k:=lig_step(i); y:=l_next_char(k); t:=l_op_byte(k);
+cc:=simple; zz:=l_remainder(k);
+if t>=kern_flag then zz:=y
+else begin case t of
+ 0,6:do_nothing; {\.{LIG},\.{/LIG>}}
+ 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}}
+ 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}}
+ 2:cc:=right_z; {\.{/LIG}}
+ 3:cc:=both_z; {\.{/LIG/}}
+ end; {there are no other cases}
+ end
+
+@ Evaluation of $f(x,y)$ is handled by two mutually recursive procedures.
+Kind of a neat algorithm, generalizing a depth-first search.
+
+@p function f(@!h,@!x,@!y:index):index; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+function eval(@!x,@!y:index):index; {compute $f(x,y)$ with hashtable lookup}
+var @!key:integer; {value sought in hash table}
+begin key:=xmax_char*x+y+1; h:=(hash_mult*key) mod hash_size;
+while hash[h]>key do
+ if h>0 then decr(h)@+else h:=hash_size;
+if hash[h]<key then eval:=y {not in ordered hash table}
+else eval:=f(h,x,y);
+end;
+
+@ Pascal's beastly convention for |forward| declarations prevents us from
+saying |function f(h,x,y:index):index| here.
+
+@p function f;
+begin case class[h] of
+simple: do_nothing;
+left_z: begin class[h]:=pending; lig_z[h]:=eval(lig_z[h],y); class[h]:=simple;
+ end;
+right_z: begin class[h]:=pending; lig_z[h]:=eval(x,lig_z[h]); class[h]:=simple;
+ end;
+both_z: begin class[h]:=pending; lig_z[h]:=eval(eval(x,lig_z[h]),y);
+ class[h]:=simple;
+ end;
+pending: begin x_lig_cycle:=x; y_lig_cycle:=y;
+ lig_z[h]:=xxmax_char; class[h]:=simple;
+ end; {the value |xxmax_char| will break all cycles,
+ since it's not in |hash|}
+end; {there are no other cases}
+f:=lig_z[h];
+end;
+
+@* Outputting the VF info.
+The routines we've used for output from the |tfm| array have counterparts
+for output from |vf|. One difference is that the string outputs from |vf|
+need to be checked for balanced parentheses. The |string_balance| routine
+tests the string of length~|l| that starts at location~|k|.
+
+@p function string_balance(@!k,@!l:integer):boolean;
+label not_found,exit;
+var @!j,@!bal:integer;
+begin if l>0 then if vf[k]=" " then goto not_found;
+ {a leading blank is considered unbalanced}
+bal:=0;
+for j:=k to k+l-1 do begin
+ if (vf[j]<" ")or(vf[j]>=127) then goto not_found;
+ if vf[j]="(" then incr(bal)
+ else if vf[j]=")" then
+ if bal=0 then goto not_found else decr(bal);
+ end;
+if bal>0 then goto not_found;
+string_balance:=true; return;
+not_found:string_balance:=false;
+exit:end;
+
+@ @d bad_vf(#)==begin perfect:=false; if chars_on_line>0 then print_ln(' ');
+ chars_on_line:=0; print_ln('Bad OVF file: ',#);
+ end
+@.Bad OVF file@>
+
+@<Do the virtual font title@>=
+if string_balance(0,font_start[0]) then begin
+ left; out('VTITLE ');
+ for k:=0 to font_start[0]-1 do out(xchr[vf[k]]);
+ right;
+ end
+else bad_vf('Title is not a balanced ASCII string')
+@.Title is not balanced@>
+
+@ We can re-use some code by moving |fix_word| data to |tfm|, using the
+fact that the design size has already been output.
+
+@p procedure out_as_fix(@!x:integer);
+var @!k:1..3;
+begin if abs(x)>=@'100000000 then
+ bad_vf('Oversize dimension has been reset to zero.');
+@.Oversize dimension...@>
+if x>=0 then tfm[design_size]:=0
+else begin
+ tfm[design_size]:=255; x:=x+@'100000000;
+ end;
+for k:=3 downto 1 do begin
+ tfm[design_size+k]:=x mod 256; x:=x div 256;
+ end;
+out_fix(design_size);
+end;
+
+@ @<Do the local fonts@>=
+for f:=0 to font_ptr-1 do begin
+ left; out('MAPFONT D ',f:1); out_ln;
+ @<Output the font area and name@>;
+ for k:=0 to 11 do tfm[k]:=vf[font_start[f]+k];
+ if tfm[0]+tfm[1]+tfm[2]+tfm[3]>0 then begin
+ left; out('FONTCHECKSUM'); out_hex(0,4); right;
+ end;
+ left; out('FONTAT'); out_fix(4); right;
+ left; out('FONTDSIZE'); out_fix(8); right; right;
+ end
+
+@ @<Output the font area and name@>=
+a:=vf[font_start[f]+12]; l:=vf[font_start[f]+13];
+if a>0 then
+ if not string_balance(font_start[f]+14,a) then
+ bad_vf('Improper font area will be ignored')
+@.Improper font area@>
+ else begin
+ left; out('FONTAREA ');
+ for k:=font_start[f]+14 to font_start[f]+a+13 do out(xchr[vf[k]]);
+ right;
+ end;
+if (l=0)or not string_balance(font_start[f]+14+a,l) then
+ bad_vf('Improper font name will be ignored')
+@.Improper font name@>
+else begin
+ left; out('FONTNAME ');
+ for k:=font_start[f]+14+a to font_start[f]+a+l+13 do out(xchr[vf[k]]);
+ right;
+ end
+
+@ Now we get to the interesting part of \.{VF} output, where \.{DVI}
+commands are translated into symbolic form. The \.{VPL} language is a subset
+of \.{DVI}, so we sometimes need to output semantic equivalents of
+the commands instead of producing a literal translation. This causes a
+small but tolerable loss of efficiency. We need to simulate the stack
+used by \.{DVI}-reading software.
+
+@<Glob...@>=
+@!top:0..max_stack; {\.{DVI} stack pointer}
+@!wstack,@!xstack,@!ystack,@!zstack:array[0..max_stack] of integer;
+ {stacked values of \.{DVI} registers |w|, |x|, |y|, |z|}
+@!vf_limit:0..vf_size; {the current packet ends here}
+@!o:byte; {the current opcode}
+
+@ @<Do the packet for character |c|@>=
+if packet_start[c]=vf_size then
+ bad_vf('Missing packet for character ',c:1)
+@.Missing packet@>
+else begin
+ left; out('MAP'); out_ln;
+ top:=0; wstack[0]:=0; xstack[0]:=0; ystack[0]:=0; zstack[0]:=0;
+ vf_ptr:=packet_start[c]; vf_limit:=packet_end[c]+1; f:=0;
+ while vf_ptr<vf_limit do begin
+ o:=vf[vf_ptr]; incr(vf_ptr);
+ case o of
+ @<Cases of \.{DVI} instructions that can appear in character packets@>@;
+ improper_DVI_for_VF: bad_vf('Illegal DVI code ',o:1,' will be ignored');
+ end; {there are no other cases}
+ end;
+ if top>0 then begin
+ bad_vf('More pushes than pops!');
+@.More pushes than pops@>
+ repeat out('(POP)'); decr(top);@+until top=0;
+ end;
+ right;
+ end
+
+@ A procedure called |get_bytes| helps fetch the parameters of \.{DVI} commands.
+
+@p function get_bytes(@!k:integer;@!signed:boolean):integer;
+var @!a:integer; {accumulator}
+begin if vf_ptr+k>vf_limit then begin
+ bad_vf('Packet ended prematurely'); k:=vf_limit-vf_ptr;
+ end;
+a:=vf[vf_ptr];
+if (k=4) or signed then
+ if a>=128 then a:=a-256;
+incr(vf_ptr);
+while k>1 do begin
+ a:=a*256+vf[vf_ptr]; incr(vf_ptr); decr(k);
+ end;
+get_bytes:=a;
+end;
+
+@ Let's look at the simplest cases first, in order to get some experience.
+
+@d four_cases(#)==#,#+1,#+2,#+3
+@d eight_cases(#)==four_cases(#),four_cases(#+4)
+@d sixteen_cases(#)==eight_cases(#),eight_cases(#+8)
+@d thirty_two_cases(#)==sixteen_cases(#),sixteen_cases(#+16)
+@d sixty_four_cases(#)==thirty_two_cases(#),thirty_two_cases(#+32)
+
+@<Cases...@>=
+nop:do_nothing;
+push:begin if top=max_stack then
+ begin print_ln('Stack overflow!'); goto final_end;
+@.Stack overflow@>
+ end;
+ incr(top); wstack[top]:=wstack[top-1]; xstack[top]:=xstack[top-1];
+ ystack[top]:=ystack[top-1]; zstack[top]:=zstack[top-1]; out('(PUSH)');
+ out_ln;
+ end;
+pop:if top=0 then bad_vf('More pops than pushes!')
+@.More pops than pushes@>
+ else begin decr(top); out('(POP)'); out_ln;
+ end;
+set_rule,put_rule:begin if o=put_rule then out('(PUSH)');
+ left; out('SETRULE'); out_as_fix(get_bytes(4,true));
+ out_as_fix(get_bytes(4,true));
+ if o=put_rule then out(')(POP');
+ right;
+ end;
+
+@ Horizontal and vertical motions become \.{RIGHT} and \.{DOWN} in \.{VPL}
+lingo.
+
+@<Cases...@>=
+four_cases(right1):begin out('(MOVERIGHT');
+ out_as_fix(get_bytes(o-right1+1,true));
+ out(')'); out_ln;@+end;
+w0,four_cases(w1):begin if o<>w0 then wstack[top]:=get_bytes(o-w1+1,true);
+ out('(MOVERIGHT'); out_as_fix(wstack[top]); out(')'); out_ln;@+end;
+x0,four_cases(x1):begin if o<>x0 then xstack[top]:=get_bytes(o-x1+1,true);
+ out('(MOVERIGHT'); out_as_fix(xstack[top]); out(')'); out_ln;@+end;
+four_cases(down1):begin out('(MOVEDOWN'); out_as_fix(get_bytes(o-down1+1,true));
+ out(')'); out_ln;@+end;
+y0,four_cases(y1):begin if o<>y0 then ystack[top]:=get_bytes(o-y1+1,true);
+ out('(MOVEDOWN'); out_as_fix(ystack[top]); out(')'); out_ln;@+end;
+z0,four_cases(z1):begin if o<>z0 then zstack[top]:=get_bytes(o-z1+1,true);
+ out('(MOVEDOWN'); out_as_fix(zstack[top]); out(')'); out_ln;@+end;
+
+@ Variable |f| always refers to the current font. If |f=font_ptr|, it's
+a font that hasn't been defined (so its characters will be ignored).
+
+@<Cases...@>=
+sixty_four_cases(fnt_num_0),four_cases(fnt1):begin f:=0;
+ if o>=fnt1 then font_number[font_ptr]:=get_bytes(o-fnt1+1,false)
+ else font_number[font_ptr]:=o-fnt_num_0;
+ while font_number[f]<>font_number[font_ptr] do incr(f);
+ if f=font_ptr then bad_vf('Undeclared font selected')
+@.Undeclared font selected@>
+ else begin out('(SELECTFONT D ',f:1,')'); out_ln;
+ end;
+ end;
+
+@ Before we typeset a character we make sure that it exists.
+
+@<Cases...@>=
+sixty_four_cases(set_char_0),sixty_four_cases(set_char_0+64),
+ four_cases(set1),four_cases(put1):begin if o>=set1 then
+ if o>=put1 then c:=get_bytes(o-put1+1,false)
+ else c:=get_bytes(o-set1+1,false)
+ else c:=o;
+ if f=font_ptr then
+ bad_vf('Character ',c:1,' in undeclared font will be ignored')
+@.Character...will be ignored@>
+ else begin vf[font_start[f+1]-1]:=c; {store |c| in the ``hole'' we left}
+ k:=font_chars[f];@+while vf[k]<>c do incr(k);
+ if k=font_start[f+1]-1 then
+ bad_vf('Character ',c:1,' in font ',f:1,' will be ignored')
+ else begin if o>=put1 then out('(PUSH)');
+ left; out('SETCHAR'); out_char(c);
+ if o>=put1 then out(')(POP');
+ right;
+ end;
+ end;
+ end;
+
+@ The ``special'' commands are the only ones remaining to be dealt with.
+We use a hexadecimal
+output in the general case, if a simple string would be inadequate.
+
+@d vf_out_hex(#)==begin a:=#;
+ if a<10 then out(a:1)
+ else out(xchr[a-10+"A"]);
+ end
+
+@<Cases...@>=
+four_cases(xxx1):begin k:=get_bytes(o-xxx1+1,false);
+ if k<0 then bad_vf('String of negative length!')
+ else begin left;
+ if k+vf_ptr>vf_limit then
+ begin bad_vf('Special command truncated to packet length');
+ k:=vf_limit-vf_ptr;
+ end;
+ if (k>64)or not string_balance(vf_ptr,k) then
+ begin out('SPECIALHEX ');
+ while k>0 do
+ begin if k mod 32=0 then out_ln
+ else if k mod 4=0 then out(' ');
+ vf_out_hex(vf[vf_ptr] div 16); vf_out_hex(vf[vf_ptr] mod 16);
+ incr(vf_ptr); decr(k);
+ end;
+ end
+ else begin out('SPECIAL ');
+ while k>0 do
+ begin out(xchr[vf[vf_ptr]]); incr(vf_ptr); decr(k);
+ end;
+ end;
+ right;
+ end;
+ end;
+
+@* The main program.
+The routines sketched out so far need to be packaged into separate procedures,
+on some systems, since some \PASCAL\ compilers place a strict limit on the
+size of a routine. The packaging is done here in an attempt to avoid some
+system-dependent changes.
+
+First come the |vf_input| and |organize| procedures, which read the input data
+and get ready for subsequent events. If something goes wrong, the routines
+return |false|.
+
+@p function vf_input:boolean;
+label final_end, exit;
+var vf_ptr:0..vf_size; {an index into |vf|}
+@!k:integer; {all-purpose index}
+@!c:integer; {character code}
+begin @<Read the whole \.{VF} file@>;
+vf_input:=true; return;
+final_end: vf_input:=false;
+exit: end;
+@#
+function organize:boolean;
+label final_end, exit;
+var tfm_ptr:index; {an index into |tfm|}
+begin @<Read the whole font metric file@>;
+@<Set subfile sizes |lh|, |bc|, \dots, |np|@>;
+@<Compute the base addresses@>;
+organize:=vf_input; return;
+final_end: organize:=false;
+exit: end;
+
+@ Next we do the simple things.
+
+@p procedure do_simple_things;
+var i:0..@'77777; {an index to words of a subfile}
+@!f:0..vf_size; {local font number}
+@!k:integer; {all-purpose index}
+begin @<Do the virtual font title@>;
+@<Do the header@>;
+@<Do the parameters@>;
+@<Do the ivalue parameters@>;@/
+@<Do the fvalue parameters@>;@/
+@<Do the rule parameters@>;@/
+@<Do the glue parameters@>;@/
+@<Do the penalty parameters@>;@/
+@<Do the local fonts@>;
+@<Check the |fix_word| entries@>;
+end;
+
+@ And then there's a routine for individual characters.
+
+@p function do_map(@!c:integer):boolean;
+label final_end,exit;
+var @!k:integer;
+@!f:0..vf_size; {current font number}
+begin @<Do the packet for character |c|@>;
+do_map:=true; return;
+final_end: do_map:=false;
+exit:end;
+@#
+function do_characters:boolean;
+label final_end, exit;
+var @!c:integer; {character being done}
+@!k:index; {a random index}
+@!ai:0..lig_size; {index into |activity|}
+begin @<Do the characters@>;@/
+do_characters:=true; return;
+final_end: do_characters:=false;
+exit:end;
+
+@ Here is where \.{VFtoVP} begins and ends.
+@p begin initialize;@/
+if not organize then goto final_end;
+do_simple_things;@/
+@<Do the ligatures and kerns@>;
+@<Check the extensible recipes@>;
+if not do_characters then goto final_end;
+print_ln('.');@/
+if level<>0 then print_ln('This program isn''t working!');
+@.This program isn't working@>
+if not perfect then begin
+ out('(COMMENT THE OFM AND/OR OVF FILE WAS BAD, ');
+ out('SO THE DATA HAS BEEN CHANGED!)');
+ end;
+@.THE OFM AND/OR OVF FILE WAS BAD...@>
+final_end:end.
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{VFtoVP} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.
diff --git a/Build/source/texk/web2c/omegaware/ovp2ovf.ch b/Build/source/texk/web2c/omegaware/ovp2ovf.ch
new file mode 100644
index 00000000000..c105f60ceb0
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ovp2ovf.ch
@@ -0,0 +1,320 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--1998 John Plaice and Yannis Haralambous
+% applies only to the changes to the original vptovf.ch.
+%
+% vptovf.ch for C compilation with web2c.
+
+@x [0] WEAVE: print changes only.
+\pageno=\contentspagenumber \advance\pageno by 1
+@y
+\pageno=\contentspagenumber \advance\pageno by 1
+%\let\maybe=\iffalse
+%\def\title{OVP2OVF changes for C}
+@z
+
+@x [2] Print the banner later.
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+@y
+@<Define |parse_arguments|@>
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin
+ kpse_set_progname (argv[0]);
+ parse_arguments;
+@z
+
+@x [3] Increase constants.
+@!buf_size=60; {length of lines displayed in error messages}
+@y
+@!buf_size=3000; {max input line length, output error line length}
+@z
+%@x
+%@!vf_size=10000; {maximum length of |vf| data, in bytes}
+%@!max_stack=100; {maximum depth of simulated \.{DVI} stack}
+%@!max_param_words=30; {the maximum number of \.{fontdimen} parameters allowed}
+%@!max_lig_steps=5000;
+% {maximum length of ligature program, must be at most $32767-257=32510$}
+%@!max_kerns=500; {the maximum number of distinct kern values}
+%@!hash_size=5003; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@y
+%@!vf_size=50000; {maximum length of |vf| data, in bytes}
+%@!max_stack=100; {maximum depth of simulated \.{DVI} stack}
+%@!max_param_words=30; {the maximum number of \.{fontdimen} parameters allowed}
+%@!max_lig_steps=10000;
+% {maximum length of ligature program, must be at most $32767-257=32510$}
+%@!max_kerns=10000; {the maximum number of distinct kern values}
+%@!hash_size=10007; {preferably a prime number, a bit larger than the number
+% of character pairs in lig/kern steps}
+%@z
+
+@x [6] Open VPL file.
+reset(vpl_file);
+@y
+reset (vpl_file, vpl_name);
+if verbose then begin
+ print (banner);
+ print_ln (banner);
+end;
+@z
+
+@x [22] Open output files.
+@ On some systems you may have to do something special to write a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(vf_file); rewrite(tfm_file);
+@y
+@ On some systems you may have to do something special to write a
+packed file of bytes.
+@^system dependencies@>
+
+@<Set init...@>=
+rewritebin (vf_file, vf_name);
+rewritebin (tfm_file, tfm_name);
+@z
+
+% [89] `index' is not a good choice for an identifier on Unix systems.
+% Neither is `class', on AIX.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+|k|th element of its list.
+@y
+|k|th element of its list.
+
+@d index == index_var
+@d class == class_var
+@z
+
+@x [118] No output unless verbose.
+@<Print |c| in hex notation@>;
+@y
+if verbose then @<Print |c| in hex notation@>;
+@z
+
+@x
+@!HEX: packed array [1..32] of char;
+@y
+@!HEX: c_string;
+@z
+
+@x
+HEX:='0123456789ABCDEF';@/
+@y
+HEX:=' 0123456789ABCDEF';@/
+@z
+
+@x [144] Output of real numbers.
+@ @d round_message(#)==if delta>0 then print_ln('I had to round some ',
+@.I had to round...@>
+ #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.')
+@y
+@ @d round_message(#)==if delta>0 then begin print('I had to round some ',
+@.I had to round...@>
+ #,'s by '); print_real((((delta+1) div 2)/@'4000000),1,7);
+ print_ln(' units.'); end
+@z
+
+@x [152] Fix up the mutually recursive procedures a la pltotf.
+@p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+@y
+@p
+ifdef('notdef')
+function f(@!h,@!x,@!y:indx):indx; begin end;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+endif('notdef')
+@z
+
+@x [153] Finish fixing up f.
+@p function f;
+@y
+@p function f(@!h,@!x,@!y:indx):indx;
+@z
+
+@x [156] Change TFM-byte output to fix ranges.
+@d out(#)==write(tfm_file,#)
+@y
+@d out(#)==putbyte(#,tfm_file)
+@z
+
+@x [165] Fix output of reals.
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if abs(x/design_units)>=16.0 then begin
+ print_ln('The relative dimension ',x/@'4000000:1:3,
+ ' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then print(' =',design_units/@'200000:1:3,
+ ' designunits');
+@y
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if fabs(x/design_units)>=16.0 then begin
+ print('The relative dimension ');
+ print_real(x/@'4000000,1,3);
+ print_ln(' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then begin print(' =');
+ print_real(design_units/@'200000,1,3);
+ print(' designunits');
+ end;
+@z
+
+% [141] char_remainder[c] is unsigned, and label_table[sort_ptr].rr
+% might be -1, and if -1 is coerced to being unsigned, it will be bigger
+% than anything else.
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+@x
+ while label_table[sort_ptr].rr>char_remainder[c] do begin
+@y
+ while label_table[sort_ptr].rr>intcast(char_remainder[c]) do begin
+@z
+
+@x [175] Change VF-byte output to fix ranges.
+@d vout(#)==write(vf_file,#)
+@y
+@d vout(#)==putbyte(#,vf_file)
+@z
+
+@x [181] Be quiet unless verbose.
+read_input; print_ln('.');@/
+@y
+read_input;
+if verbose then print_ln('.');
+@z
+
+@x [182] System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{VPtoVF} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+@y
+Parse a Unix-style command line.
+
+@d argument_is (#) == (strcmp (long_options[option_index].name, #) = 0)
+
+@<Define |parse_arguments|@> =
+procedure parse_arguments;
+const n_options = 3; {Pascal won't count array lengths for us.}
+var @!long_options: array[0..n_options] of getopt_struct;
+ @!getopt_return_val: integer;
+ @!option_index: c_int_type;
+ @!current_option: 0..n_options;
+begin
+ @<Initialize the option variables@>;
+ @<Define the option table@>;
+ repeat
+ getopt_return_val := getopt_long_only (argc, argv, '', long_options,
+ address_of (option_index));
+ if getopt_return_val = -1 then begin
+ {End of arguments; we exit the loop below.} ;
+
+ end else if getopt_return_val = "?" then begin
+ usage ('ovp2ovf'); {|getopt| has already given an error message.}
+
+ end else if argument_is ('help') then begin
+ usage_help (OVP2OVF_HELP, nil);
+
+ end else if argument_is ('version') then begin
+ print_version_and_exit
+ (banner, nil, 'J. Plaice, Y. Haralambous, D.E. Knuth');
+
+ end; {Else it was a flag; |getopt| has already done the assignment.}
+ until getopt_return_val = -1;
+
+ {Now |optind| is the index of first non-option on the command line.
+ We must have one to three remaining arguments.}
+ if (optind + 1 <> argc) and (optind + 2 <> argc)
+ and (optind + 3 <> argc) then begin
+ write_ln (stderr, 'ovp2ovf: Need one to three file arguments.');
+ usage ('ovp2ovf');
+ end;
+
+ vpl_name := extend_filename (cmdline (optind), 'ovp');
+
+ if optind + 2 <= argc then begin
+ {Specified one or both of the output files.}
+ vf_name := extend_filename (cmdline (optind + 1), 'ovf');
+ if optind + 3 <= argc then begin {Both.}
+ tfm_name := extend_filename (cmdline (optind + 2), 'ofm');
+ end else begin {Just one.}
+ tfm_name := extend_filename (cmdline (optind + 1), 'ofm');
+ end;
+ end else begin {Neither.}
+ vf_name := basename_change_suffix (vpl_name, '.ovp', '.ovf');
+ tfm_name := basename_change_suffix (vpl_name, '.ovp', '.ofm');
+ end;
+end;
+
+@ Here are the options we allow. The first is one of the standard GNU options.
+@.-help@>
+
+@<Define the option...@> =
+current_option := 0;
+long_options[current_option].name := 'help';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Another of the standard options.
+@.-version@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'version';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+incr (current_option);
+
+@ Print progress information?
+@.-verbose@>
+
+@<Define the option...@> =
+long_options[current_option].name := 'verbose';
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := address_of (verbose);
+long_options[current_option].val := 1;
+incr (current_option);
+
+@ The global variable |verbose| determines whether or not we print
+progress information.
+
+@<Glob...@> =
+@!verbose: c_int_type;
+
+@ It starts off |false|.
+
+@<Initialize the option...@> =
+verbose := false;
+
+@ An element with all zeros always ends the list.
+
+@<Define the option...@> =
+long_options[current_option].name := 0;
+long_options[current_option].has_arg := 0;
+long_options[current_option].flag := 0;
+long_options[current_option].val := 0;
+
+@ Global filenames.
+
+@<Global...@> =
+@!vpl_name, @!tfm_name, @!vf_name:c_string;
+@z
diff --git a/Build/source/texk/web2c/omegaware/ovp2ovf.web b/Build/source/texk/web2c/omegaware/ovp2ovf.web
new file mode 100644
index 00000000000..0b6a6a329a7
--- /dev/null
+++ b/Build/source/texk/web2c/omegaware/ovp2ovf.web
@@ -0,0 +1,5071 @@
+%
+% This file is part of the Omega project, which
+% is based in the web2c distribution of TeX.
+%
+% Copyright (c) 1994--2000 John Plaice and Yannis Haralambous
+% applies only to the changes to the original vptovf.web.
+%
+% This program by D. E. Knuth is not copyrighted and can be used freely.
+% Version 1 was implemented in December 1989.
+% Version 1.1 fixed some for-loop indices for stricter Pascal (April 1990).
+% Version 1.2 fixed `nonexistent char 0' bug, and a bit more (September 1990).
+% Version 1.3 has more robust `out_scaled' (March 1991).
+% Version 1.4 (March 1995) initialized lk_step_ended (Armin K\"ollner).
+
+% Here is TeX material that gets inserted after \input webmac
+\def\hang{\hangindent 3em\indent\ignorespaces}
+\font\ninerm=cmr9
+\let\mc=\ninerm % medium caps for names like SAIL
+\def\PASCAL{Pascal}
+\font\logo=logo10 % for the METAFONT logo
+\def\MF{{\logo METAFONT}}
+
+\def\(#1){} % this is used to make section names sort themselves better
+\def\9#1{} % this is used for sort keys in the index
+
+\def\title{OVP2OVF}
+\def\contentspagenumber{201}
+\def\topofcontents{\null
+ \def\titlepage{F} % include headline on the contents page
+ \def\rheader{\mainfont\hfil \contentspagenumber}
+ \vfill
+ \centerline{\titlefont The {\ttitlefont OVP2OVF} processor}
+ \vskip 15pt
+ \centerline{(Version 1.11, February 2000)}
+ \vfill}
+\def\botofcontents{\vfill
+ \centerline{\hsize 5in\baselineskip9pt
+ \vbox{\ninerm\noindent
+ The preparation of this program
+ was supported in part by the National Science
+ Foundation and by the System Development Foundation. `\TeX' is a
+ trademark of the American Mathematical Society.}}}
+\pageno=\contentspagenumber \advance\pageno by 1
+
+@* Introduction.
+The \.{OVP2OVF} utility program converts virtual-property-list (``\.{VPL}''
+and ``\.{OVP}'') files into an equivalent pair of files called a virtual
+font (``\.{OVF}'') file and an $\Omega$ font metric (``\.{OFM}'') file.
+It also makes a thorough check of the given \.{VPL} or \.{OVP} file,
+so that the \.{OVF} file should be acceptable to device drivers and
+the \.{OFM} file should be acceptable to $\Omega$.
+
+In the following documentation, all unchanged references to
+the \.{VPtoVF} program and to \.{VPL}, \.{VF} and \.{TFM} files also apply to
+the \.{OVP2OVF} program and to \.{OVP}, \.{OVF} and \.{OFM} files.
+
+\indent\.{VPtoVF} is an extended version of the program \.{PLtoTF}, which
+is part of the standard \TeX ware library.
+\.{OVP2OVF} is an extended version of \.{VPtoVF} that allows
+much larger fonts.
+The idea of a virtual font was inspired by the work of David R. Fuchs
+@^Fuchs, David Raymond@>
+who designed a similar set of conventions in 1984 while developing a
+device driver for ArborText, Inc. He wrote a somewhat similar program
+called \.{PLFONT}.
+
+The |banner| string defined here should be changed whenever \.{OVP2OVF}
+gets modified.
+
+@d banner=='This is OVP2OVF, Version 1.11'
+{printed when the program starts}
+
+@ This program is written entirely in standard \PASCAL, except that
+it has to do some slightly system-dependent character code conversion
+on input. Furthermore, lower case letters are used in error messages;
+they could be converted to upper case if necessary. The input is read
+from |vpl_file|, and the output is written on |vf_file| and |tfm_file|;
+error messages and
+other remarks are written on the |output| file, which the user may
+choose to assign to the terminal if the system permits it.
+@^system dependencies@>
+
+The term |print| is used instead of |write| when this program writes on
+the |output| file, so that all such output can be easily deflected.
+
+@d print(#)==write(#)
+@d print_ln(#)==write_ln(#)
+
+@p program OVP2OVF(@!vpl_file,@!vf_file,@!tfm_file,@!output);
+const @<Constants in the outer block@>@/
+type @<Types in the outer block@>@/
+var @<Globals in the outer block@>@/
+procedure initialize; {this procedure gets things started properly}
+ var @<Local variables for initialization@>@/
+ begin print_ln(banner);@/
+ @<Set initial values@>@/
+ end;
+
+@ The following parameters can be changed at compile time to extend or
+reduce \.{VPtoVF}'s capacity.
+
+@<Constants...@>=
+@!ofm_type=0; {16-bit OFM; sufficient for most purposes}
+@!max_char=65535; {the largest character number in a font}
+@!xmax_char=65536; {|max_char|+1}
+@!xxmax_char=65537;{|max_char|+2}
+@!mem_size=262148; {|max_char|*4+8}
+@!max_font=1000; {the largest font number}
+@!xmax_font=1001; {|max_font|+1}
+@!xxmax_font=1002; {|max_font|+2}
+@!max_width=65535; {the largest character width number}
+@!max_height=255; {the largest character height number}
+@!max_depth=255; {the largest character depth number}
+@!max_italic=255; {the largest character italic correction number}
+@!buf_size=60; {length of lines displayed in error messages}
+@!max_header_bytes=100; {four times the maximum number of words allowed in
+ the \.{TFM} file header block, must be 1024 or less}
+@!vf_size=200000; {maximum length of |vf| data, in bytes}
+@!max_stack=100; {maximum depth of simulated \.{DVI} stack}
+@!max_param_words=100; {the maximum number of \.{fontdimen} parameters allowed}
+@!max_lig_steps=800000; {maximum length of ligature program}
+@!xmax_label=800001; {must be greater than |max_lig_steps|}
+@!hash_size=130003; {preferably a prime number,
+ a bit larger than |max_lig_steps|, the number
+ of character pairs in lig/kern steps}
+@!hash_mult=16007; {another prime}
+@!max_kerns=100000; {the maximum number of distinct kern values}
+
+@ Here are some macros for common programming idioms.
+
+@d incr(#) == #:=#+1 {increase a variable by unity}
+@d decr(#) == #:=#-1 {decrease a variable by unity}
+@d do_nothing == {empty statement}
+
+@* Property list description of font metric data.
+The idea behind \.{VPL} files is that precise details about fonts, i.e., the
+facts that are needed by typesetting routines like \TeX, sometimes have to
+be supplied by hand. The nested property-list format provides a reasonably
+convenient way to do this.
+
+A good deal of computation is necessary to parse and process a
+\.{VPL} file, so it would be inappropriate for \TeX\ itself to do this
+every time it loads a font. \TeX\ deals only with the compact descriptions
+of font metric data that appear in \.{TFM} files. Such data is so compact,
+however, it is almost impossible for anybody but a computer to read it.
+
+Device drivers also need a compact way to describe mappings from \TeX's idea
+of a font to the actual characters a device can produce. They can do this
+conveniently when given a packed sequence of bytes called a \.{VF} file.
+
+The purpose of \.{VPtoVF} is to convert from a human-oriented file of text
+to computer-oriented files of binary numbers. There's a companion program,
+\.{VFtoVP}, which goes the other way.
+
+@<Glob...@>=
+@!vpl_file:text;
+
+@ @<Set init...@>=
+reset(vpl_file);
+
+@ A \.{VPL} file is like a \.{PL} file with a few extra features, so we
+can begin to define it by reviewing the definition of \.{PL} files. The
+material in the next few sections is copied from the program \.{PLtoTF}.
+An \.{OVP} file is simply a \.{VPL} file that does not restrict fonts
+to 256 characters.
+
+A \.{PL} file is a list of entries of the form
+$$\.{(PROPERTYNAME VALUE)}$$
+where the property name is one of a finite set of names understood by
+this program, and the value may itself in turn be a property list.
+The idea is best understood by looking at an example, so let's consider
+a fragment of the \.{PL} file for a hypothetical font.
+$$\vbox{\halign{\.{#}\hfil\cr
+(FAMILY NOVA)\cr
+(FACE F MIE)\cr
+(CODINGSCHEME ASCII)\cr
+(DESIGNSIZE D 10)\cr
+(DESIGNUNITS D 18)\cr
+(COMMENT A COMMENT IS IGNORED)\cr
+(COMMENT (EXCEPT THIS ONE ISN'T))\cr
+(COMMENT (ACTUALLY IT IS, EVEN THOUGH\cr
+\qquad\qquad IT SAYS IT ISN'T))\cr
+(FONTDIMEN\cr
+\qquad (SLANT R -.25)\cr
+\qquad (SPACE D 6)\cr
+\qquad (SHRINK D 2)\cr
+\qquad (STRETCH D 3)\cr
+\qquad (XHEIGHT R 10.55)\cr
+\qquad (QUAD D 18)\cr
+\qquad )\cr
+(LIGTABLE\cr
+\qquad (LABEL C f)\cr
+\qquad (LIG C f O 200)\cr
+\qquad (SKIP D 1)\cr
+\qquad (LABEL O 200)\cr
+\qquad (LIG C i O 201)\cr
+\qquad (KRN O 51 R 1.5)\cr
+\qquad (/LIG C ? C f)\cr
+\qquad (STOP)\cr
+\qquad )\cr
+(CHARACTER C f\cr
+\qquad (CHARWD D 6)\cr
+\qquad (CHARHT R 13.5)\cr
+\qquad (CHARIC R 1.5)\cr
+\qquad )\cr}}$$
+This example says that the font whose metric information is being described
+belongs to the hypothetical
+\.{NOVA} family; its face code is medium italic extended;
+and the characters appear in ASCII code positions. The design size is 10 points,
+and all other sizes in this \.{PL} file are given in units such that 18 units
+equals the design size. The font is slanted with a slope of $-.25$ (hence the
+letters actually slant backward---perhaps that is why the family name is
+\.{NOVA}). The normal space between words is 6 units (i.e., one third of
+the 18-unit design size), with glue that shrinks by 2 units or stretches by 3.
+The letters for which accents don't need to be raised or lowered are 10.55
+units high, and one em equals 18 units.
+
+The example ligature table is a bit trickier. It specifies that the
+letter \.f followed by another \.f is changed to code @'200, while
+code @'200 followed by \.i is changed to @'201; presumably codes @'200
+and @'201 represent the ligatures `ff' and `ffi'. Moreover, in both cases
+\.f and @'200, if the following character is the code @'51 (which is a
+right parenthesis), an additional 1.5 units of space should be inserted
+before the @'51. (The `\.{SKIP}~\.D~\.1' skips over one \.{LIG} or
+\.{KRN} command, which in this case is the second \.{LIG}; in this way
+two different ligature/kern programs can come together.)
+Finally, if either \.f or @'200 is followed by a question mark,
+the question mark is replaced by \.f and the ligature program is
+started over. (Thus, the character pair `\.{f?}' would actually become
+the ligature `ff', and `\.{ff?}' or `\.{f?f}' would become `fff'. To
+avoid this restart procedure, the \.{/LIG} command could be replaced
+by \.{/LIG>}; then `\.{f?} would become `f\kern0ptf' and `\.{f?f}'
+would become `f\kern0ptff'.)
+
+Character \.f itself is 6 units wide and 13.5 units tall, in this example.
+Its depth is zero (since \.{CHARDP} is not given), and its italic correction
+is 1.5 units.
+
+@ The example above illustrates most of the features found in \.{PL} files.
+Note that some property names, like \.{FAMILY} or \.{COMMENT}, take a
+string as their value; this string continues until the first unmatched
+right parenthesis. But most property names, like \.{DESIGNSIZE} and \.{SLANT}
+and \.{LABEL}, take a number as their value. This number can be expressed in
+a variety of ways, indicated by a prefixed code; \.D stands for decimal,
+\.H for hexadecimal, \.O for octal, \.R for real, \.C for character, and
+\.F for ``face.'' Other property names, like \.{LIG}, take two numbers as
+their value. And still other names, like \.{FONTDIMEN} and \.{LIGTABLE} and
+\.{CHARACTER}, have more complicated values that involve property lists.
+
+A property name is supposed to be used only in an appropriate property
+list. For example, \.{CHARWD} shouldn't occur on the outer level or
+within \.{FONTDIMEN}.
+
+The individual property-and-value pairs in a property list can appear in
+any order. For instance, `\.{SHRINK}' precedes `\.{STRETCH}' in the above
+example, although the \.{TFM} file always puts the stretch parameter first.
+One could even give the information about characters like `\.f' before
+specifying the number of units in the design size, or before specifying the
+ligature and kerning table. However, the \.{LIGTABLE} itself is an exception
+to this rule; the individual elements of the \.{LIGTABLE} property list
+can be reordered only to a certain extent without changing the meaning
+of that table.
+
+If property-and-value pairs are omitted, a default value is used. For example,
+we have already noted that the default for \.{CHARDP} is zero. The default
+for {\sl every\/} numeric value is, in fact, zero, unless otherwise stated
+below.
+
+If the same property name is used more than once, \.{VPtoVF} will not notice
+the discrepancy; it simply uses the final value given. Once again, however, the
+\.{LIGTABLE} is an exception to this rule; \.{VPtoVF} will complain if there
+is more than one label for some character. And of course many of the
+entries in the \.{LIGTABLE} property list have the same property name.
+
+@ A \.{VPL} file also includes information about how to create each character,
+by typesetting characters from other fonts and/or by drawing lines, etc.
+Such information is the value of the `\.{MAP}' property, which can be
+illustrated as follows:
+$$\vbox{\halign{\.{#}\hfil\cr
+(MAPFONT D 0 (FONTNAME Times-Roman))\cr
+(MAPFONT D 1 (FONTNAME Symbol))\cr
+(MAPFONT D 2 (FONTNAME cmr10)(FONTAT D 20))\cr
+(CHARACTER O 0 (MAP (SELECTFONT D 1)(SETCHAR C G)))\cr
+(CHARACTER O 76 (MAP (SETCHAR O 277)))\cr
+(CHARACTER D 197 (MAP\cr
+\qquad(PUSH)(SETCHAR C A)(POP)\cr
+\qquad(MOVEUP R 0.937)(MOVERIGHT R 1.5)(SETCHAR O 312)))\cr
+(CHARACTER O 200 (MAP (MOVEDOWN R 2.1)(SETRULE R 1 R 8)))\cr
+(CHARACTER O 201 (MAP\cr
+\qquad (SPECIAL ps: /SaveGray currentgray def .5 setgray)\cr
+\qquad (SELECTFONT D 2)(SETCHAR C A)\cr
+\qquad (SPECIAL ps: SaveGray setgray)))\cr
+}}$$
+(These specifications appear in addition to the conventional \.{PL}
+information. The \.{MAP} attribute can be mixed in with other attributes
+like \.{CHARWD} or it can be given separately.)
+
+In this example, the virtual font is composed of characters that can be
+fabricated from three actual fonts, `\.{Times-Roman}',
+`\.{Symbol}', and `\.{cmr10} \.{at} \.{20\\u}' (where \.{\\u}
+is the unit size in this \.{VPL} file). Character |@'0| is typeset as
+a `G' from the symbol font. Character |@'76| is typeset as character |@'277|
+from the ordinary Times font. (If no other font is selected, font
+number~0 is the default. If no \.{MAP} attribute is given, the default map
+is a character of the same number in the default font.)
+
+Character 197 (decimal) is more interesting: First an A is typeset (in the
+default font Times), and this is enclosed by \.{PUSH} and \.{POP} so that
+the original position is restored. Then the accent character |@'312| is
+typeset, after moving up .937 units and right 1.5 units.
+
+To typeset character |@'200| in this virtual font, we move down 2.1 units,
+then typeset a rule that is 1 unit high and 8 units wide.
+
+Finally, to typeset character |@'201|, we do something that requires a
+special ability to interpret PostScript commands; this example
+sets the PostScript ``color'' to 50\char`\%\ gray and typesets an `A'
+from \.{cmr10} in that color.
+
+In general, the \.{MAP} attribute of a virtual character can be any sequence
+of typesetting commands that might appear in a page of a \.{DVI} file.
+A single character might map into an entire page.
+
+@ But instead of relying on a hypothetical example, let's consider a complete
+grammar for \.{VPL} files, beginning with the (unchanged) grammatical rules
+for \.{PL} files. At the outer level, the following property names
+are valid in any \.{PL} file:
+
+\yskip\hang\.{CHECKSUM} (four-byte value). The value, which should be a
+nonnegative integer less than $2^{32}$, is used to identify a particular
+version of a font; it should match the check sum value stored with the font
+itself. An explicit check sum of zero is used to bypass
+check sum testing. If no checksum is specified in the \.{VPL} file,
+\.{VPtoVF} will compute the checksum that \MF\ would compute from the
+same data.
+
+\yskip\hang\.{DESIGNSIZE} (numeric value, default is 10). The value, which
+should be a real number in the range |1.0<=x<2048|, represents the default
+amount by which all quantities will be scaled if the font is not loaded
+with an `\.{at}' specification. For example, if one says
+`\.{\\font\\A=cmr10 at 15pt}' in \TeX\ language, the design size in the \.{TFM}
+file is ignored and effectively replaced by 15 points; but if one simply
+says `\.{\\font\\A=cmr10}' the stated design size is used. This quantity is
+always in units of printer's points.
+
+\yskip\hang\.{DESIGNUNITS} (numeric value, default is 1). The value
+should be a positive real number; it says how many units equals the design
+size (or the eventual `\.{at}' size, if the font is being scaled). For
+example, suppose you have a font that has been digitized with 600 pixels per
+em, and the design size is one em; then you could say `\.{(DESIGNUNITS R 600)}'
+if you wanted to give all of your measurements in units of pixels.
+
+\yskip\hang\.{CODINGSCHEME} (string value, default is `\.{UNSPECIFIED}').
+The string should not contain parentheses, and its length must be less than 40.
+It identifies the correspondence between the numeric codes and font characters.
+(\TeX\ ignores this information, but other software programs make use of it.)
+
+\yskip\hang\.{FAMILY} (string value, default is `\.{UNSPECIFIED}').
+The string should not contain parentheses, and its length must be less than 20.
+It identifies the name of the family to which this font belongs, e.g.,
+`\.{HELVETICA}'. (\TeX\ ignores this information; but it is needed, for
+example, when converting \.{DVI} files to \.{PRESS} files for Xerox
+equipment.)
+
+\yskip\hang\.{FACE} (one-byte value). This number, which must lie between
+0 and 255 inclusive, is a subsidiary ident\-ifi\-ca\-tion of the font within its
+family. For example, bold italic condensed fonts might have the same family name
+as light roman extended fonts, differing only in their face byte. (\TeX\
+ignores this information; but it is needed, for example, when converting
+\.{DVI} files to \.{PRESS} files for Xerox equipment.)
+
+\yskip\hang\.{SEVENBITSAFEFLAG} (string value, default is `\.{FALSE}'). The
+value should start with either `\.T' (true) or `\.F' (false). If true, character
+codes less than 128 cannot lead to codes of 128 or more via ligatures or
+charlists or extensible characters. (\TeX82 ignores this flag, but older
+versions of \TeX\ would only accept \.{TFM} files that were seven-bit safe.)
+\.{VPtoVF} computes the correct value of this flag and gives an error message
+only if a claimed ``true'' value is incorrect.
+
+\yskip\hang\.{HEADER} (a one-byte value followed by a four-byte value).
+The one-byte value should be between 18 and a maximum limit that can be
+raised or lowered depending on the compile-time setting of |max_header_bytes|.
+The four-byte value goes into the header word whose index is the one-byte
+value; for example, to set |header[18]:=1|, one may write
+`\.{(HEADER D 18 O 1)}'. This notation is used for header information that
+is presently unnamed. (\TeX\ ignores it.)
+
+\yskip\hang\.{FONTDIMEN} (property list value). See below for the names
+allowed in this property list.
+
+\yskip\hang\.{LIGTABLE} (property list value). See below for the rules
+about this special kind of property list.
+
+\yskip\hang\.{BOUNDARYCHAR} (integer value). If this character appears in
+a \.{LIGTABLE} command, it matches ``end of word'' as well as itself.
+If no boundary character is given and no \.{LABEL} \.{BOUNDARYCHAR} occurs
+within \.{LIGTABLE}, word boundaries will not affect ligatures or kerning.
+
+\yskip\hang\.{CHARACTER}. The value is an integer followed by
+a property list. The integer represents the number of a character that is
+present in the font; the property list of a character is defined below.
+The default is an empty property list.
+
+@ Numeric property list values can be given in various forms identified by
+a prefixed letter.
+
+\yskip\hang\.C denotes an ASCII character, which should be a standard visible
+character that is not a parenthesis. The numeric value will therefore be
+between @'41 and @'176 but not @'50 or @'51.
+
+\yskip\hang\.D denotes an unsigned decimal integer, which must be
+less than $2^{32}$, i.e., at most `\.{D 4294967295}'.
+
+\yskip\hang\.F denotes a three-letter Xerox face code; the admissible codes
+are \.{MRR}, \.{MIR}, \.{BRR}, \.{BIR}, \.{LRR}, \.{LIR}, \.{MRC}, \.{MIC},
+\.{BRC}, \.{BIC}, \.{LRC}, \.{LIC}, \.{MRE}, \.{MIE}, \.{BRE}, \.{BIE},
+\.{LRE}, and \.{LIE}, denoting the integers 0 to 17, respectively.
+
+\yskip\hang\.O denotes an unsigned octal integer, which must be less than
+$2^{32}$, i.e., at most `\.{O 37777777777}'.
+
+\yskip\hang\.H denotes an unsigned hexadecimal integer, which must be less than
+$2^{32}$, i.e., at most `\.{H FFFFFFFF}'.
+
+\yskip\hang\.R denotes a real number in decimal notation, optionally preceded
+by a `\.+' or `\.-' sign, and optionally including a decimal point. The
+absolute value must be less than 2048.
+
+@ The property names allowed in a \.{FONTDIMEN} property list correspond to
+various \TeX\ parameters, each of which has a (real) numeric value. All
+of the parameters except \.{SLANT} are in design units. The admissible
+names are \.{SLANT}, \.{SPACE}, \.{STRETCH}, \.{SHRINK}, \.{XHEIGHT},
+\.{QUAD}, \.{EXTRASPACE}, \.{NUM1}, \.{NUM2}, \.{NUM3}, \.{DENOM1},
+\.{DENOM2}, \.{SUP1}, \.{SUP2}, \.{SUP3}, \.{SUB1}, \.{SUB2}, \.{SUPDROP},
+\.{SUBDROP}, \.{DELIM1}, \.{DELIM2}, and \.{AXISHEIGHT}, for parameters
+1~to~22. The alternate names \.{DEFAULTRULETHICKNESS},
+\.{BIGOPSPACING1}, \.{BIGOPSPACING2}, \.{BIGOPSPACING3},
+\.{BIGOPSPACING4}, and \.{BIGOPSPACING5}, may also be used for parameters
+8 to 13.
+
+The notation `\.{PARAMETER} $n$' provides another way to specify the
+$n$th parameter; for example, `\.{(PARAMETER} \.{D 1 R -.25)}' is another way
+to specify that the \.{SLANT} is $-0.25$. The value of $n$ must be positive
+and less than |max_param_words|.
+
+@ The elements of a \.{CHARACTER} property list can be of six different types.
+
+\yskip\hang\.{CHARWD} (real value) denotes the character's width in
+design units.
+
+\yskip\hang\.{CHARHT} (real value) denotes the character's height in
+design units.
+
+\yskip\hang\.{CHARDP} (real value) denotes the character's depth in
+design units.
+
+\yskip\hang\.{CHARIC} (real value) denotes the character's italic correction in
+design units.
+
+\yskip\hang\.{NEXTLARGER} (integer value), specifies the character that
+follows the present one in a ``charlist.'' The value must be the number of a
+character in the font, and there must be no infinite cycles of supposedly
+larger and larger characters.
+
+\yskip\hang\.{VARCHAR} (property list value), specifies an extensible character.
+This option and \.{NEXTLARGER} are mutually exclusive; i.e., they cannot
+both be used within the same \.{CHARACTER} list.
+
+\yskip\noindent
+The elements of a \.{VARCHAR} property list are either \.{TOP}, \.{MID},
+\.{BOT} or \.{REP}; the values are integers, which must be zero or the number
+of a character in the font. A zero value for \.{TOP}, \.{MID}, or \.{BOT} means
+that the corresponding piece of the extensible character is absent. A nonzero
+value, or a \.{REP} value of zero, denotes the character code used to make
+up the top, middle, bottom, or replicated piece of an extensible character.
+
+@ A \.{LIGTABLE} property list contains elements of four kinds, specifying a
+program in a simple command language that \TeX\ uses for ligatures and kerns.
+If several \.{LIGTABLE} lists appear, they are effectively concatenated into
+a single list.
+
+\yskip\hang\.{LABEL} (integer value) means that the program for the
+stated character value starts here. The integer must be the number of a
+character in the font; its \.{CHARACTER} property list must not have a
+\.{NEXTLARGER} or \.{VARCHAR} field. At least one \.{LIG} or \.{KRN} step
+must follow.
+
+\yskip\hang\.{LABEL} \.{BOUNDARYCHAR} means that the program for
+beginning-of-word ligatures starts here.
+
+\yskip\hang\.{LIG} (two integer values). The instruction `\.{(LIG} $c$ $r$\.)'
+means, ``If the next character is $c$, then insert character~$r$ and
+possibly delete the current character and/or~$c$;
+otherwise go on to the next instruction.''
+Characters $r$ and $c$ must be present in the font. \.{LIG} may be immediately
+preceded or followed by a slash, and then immediately followed by \.>
+characters not exceeding the number of slashes. Thus there are eight
+possible forms:
+$$\hbox to .8\hsize{\.{LIG}\hfil\.{/LIG}\hfil\.{/LIG>}\hfil
+\.{LIG/}\hfil\.{LIG/>}\hfil\.{/LIG/}\hfil\.{/LIG/>}\hfil\.{/LIG/>>}}$$
+The slashes specify retention of the left or right original character; the
+\.> signs specify passing over the result without further ligature processing.
+
+\yskip\hang\.{KRN} (an integer value and a real value). The instruction
+`\.{(KRN} $c$ $r$\.)' means, ``If the next character is $c$, then insert
+a blank space of width $r$ between the current character character and $c$;
+otherwise go on to the next intruction.'' The value of $r$, which is in
+units of the design size, is often negative. Character code $c$ must exist
+in the font.
+
+\yskip\hang\.{STOP} (no value). This instruction ends a ligature/kern program.
+It must follow either a \.{LIG} or \.{KRN} instruction, not a \.{LABEL}
+or \.{STOP} or \.{SKIP}.
+
+\yskip\hang\.{SKIP} (value in the range |0..127|). This instruction specifies
+continuation of a ligature/kern program after the specified number of \.{LIG}
+or \.{KRN} has been skipped over. The number of subsequent \.{LIG} and \.{KRN}
+instructions must therefore exceed this specified amount.
+
+@ In addition to all these possibilities, the property name \.{COMMENT} is
+allowed in any property list. Such comments are ignored.
+
+@ So that is what \.{PL} files hold. In a \.{VPL} file additional
+properties are recognized; two of these are valid on the outermost level:
+
+\yskip\hang\.{VTITLE} (string value, default is empty). The value will be
+reproduced at the beginning of the \.{VF} file (and printed on the terminal
+by \.{VFtoVP} when it examines that file).
+
+\yskip\hang\.{MAPFONT}. The value is a nonnegative integer followed by
+a property list. The integer represents an identifying number for fonts
+used in \.{MAP} attributes. The property list, which identifies the font and
+relative size, is defined below.
+
+\yskip\noindent
+And one additional ``virtual property'' is valid within a \.{CHARACTER}:
+
+\yskip\hang\.{MAP}. The value is a property list consisting of typesetting
+commands. Default is the single command \.{SETCHAR}~$c$, where $c$ is
+the current character number.
+
+@ The elements of a \.{MAPFONT} property list can be of the following types.
+
+\yskip\hang\.{FONTNAME} (string value, default is \.{NULL}).
+This is the font's identifying name.
+
+\yskip\hang\.{FONTAREA} (string value, default is empty). If the font appears
+in a nonstandard directory, according to local conventions, the directory
+name is given here. (This is system dependent, just as in \.{DVI} files.)
+
+\yskip\hang\.{FONTCHECKSUM} (four-byte value, default is zero). This value,
+which should be a nonnegative integer less than $2^{32}$, can be used to
+check that the font being referred to matches the intended font. If nonzero,
+it should equal the \.{CHECKSUM} parameter in that font.
+
+\yskip\hang\.{FONTAT} (numeric value, default is the \.{DESIGNUNITS} of the
+present virtual font). This value is relative to the design units of
+the present virtual font, hence it will be scaled when the virtual
+font is magnified or reduced. It represents the value that will
+effectively replace the design size of the font being referred to,
+so that all characters will be scaled appropriately.
+
+\yskip\hang\.{FONTDSIZE} (numeric value, default is 10). This value is
+absolute, in units of printer's points. It should equal the \.{DESIGNSIZE}
+parameter in the font being referred to.
+
+\yskip\noindent
+If any of the
+string values contain parentheses, the parentheses must be balanced. Leading
+blanks are removed from the strings, but trailing blanks are not.
+
+@ Finally, the elements of a \.{MAP} property list are an ordered sequence
+of typesetting commands chosen from among the following:
+
+\yskip\hang\.{SELECTFONT} (four-byte integer value). The value must be the
+number of a previously defined \.{MAPFONT}. This font (or more precisely, the
+final font that is mapped to that code number, if two \.{MAPFONT} properties
+happen to specify the same code) will be used in subsequent \.{SETCHAR}
+instructions until overridden by another \.{SELECTFONT}. The first-specified
+\.{MAPFONT} is implicitly selected before the first \.{SELECTFONT} in every
+character's map.
+
+\yskip\hang\.{SETCHAR} (integer value). There must be a character of
+this number in the currently selected font. (\.{VPtoVF} doesn't check that
+the character is valid, but \.{VFtoVP} does.) That character is typeset at the
+current position, and the typesetter moves right by the \.{CHARWD} in
+that character's \.{TFM} file.
+
+\yskip\hang\.{SETRULE} (two real values). The first value specifies height,
+the second specifies width, in design units. If both height and width are
+positive, a rule is typeset at the current position. Then the typesetter
+moves right, by the specified width.
+
+\yskip\hang\.{MOVERIGHT}, \.{MOVELEFT}, \.{MOVEUP}, \.{MOVEDOWN} (real
+value). The typesetter moves its current position
+by the number of design units specified.
+
+\yskip\hang\.{PUSH} The current typesetter position is remembered, to
+be restored on a subsequent \.{POP}.
+
+\yskip\hang\.{POP} The current typesetter position is reset to where it
+was on the most recent unmatched \.{PUSH}. The \.{PUSH} and \.{POP}
+commands in any \.{MAP} must be properly nested like balanced parentheses.
+
+\yskip\hang\.{SPECIAL} (string value). The subsequent characters, starting
+with the first nonblank and ending just before the first `\.)' that has no
+matching `\.(', are interpreted according to local conventions with the
+same system-dependent meaning as a `special' (\\{xxx}) command
+in a \.{DVI} file.
+
+\yskip\hang\.{SPECIALHEX} (hexadecimal string value). The subsequent
+nonblank characters before the next `\.)' must consist entirely of
+hexadecimal digits, and they must contain an even number of such digits.
+Each pair of hex digits specifies a byte, and this string of bytes is
+treated just as the value of a \.{SPECIAL}. (This convention permits
+arbitrary byte strings to be represented in an ordinary text file.)
+
+@ Virtual font mapping is a recursive process, like macro expansion.
+Thus, a \.{MAPFONT} might
+specify another virtual font, whose characters are themselves mapped to
+other fonts. As an example of this possibility, consider the
+following curious file called \.{recurse.vpl}, which defines a
+virtual font that is self-contained and self-referential:
+$$\vbox{\halign{\.{#}\cr
+(VTITLE Example of recursion)\cr
+(MAPFONT D 0 (FONTNAME recurse)(FONTAT D 2))\cr
+(CHARACTER C A (CHARWD D 1)(CHARHT D 1)(MAP (SETRULE D 1 D 1)))\cr
+(CHARACTER C B (CHARWD D 2)(CHARHT D 2)(MAP (SETCHAR C A)))\cr
+(CHARACTER C C (CHARWD D 4)(CHARHT D 4)(MAP (SETCHAR C B)))\cr
+}}$$
+The design size is 10 points (the default), hence the character \.A
+in font \.{recurse} is a $10\times10$ point black square. Character \.B
+is typeset as character \.A in \.{recurse} {scaled} {2000}, hence it
+is a $20\times20$ point black square. And character \.C is typeset as
+character \.{B} in \.{recurse} {scaled} {2000}, hence its size is
+$40\times40$.
+
+Users are responsible for making sure that infinite recursion doesn't happen.
+
+@ So that is what \.{VPL} files hold. From these rules,
+you can guess (correctly) that \.{VPtoVF} operates in four main stages.
+First it assigns the default values to all properties; then it scans
+through the \.{VPL} file, changing property values as new ones are seen; then
+it checks the information and corrects any problems; and finally it outputs
+the \.{VF} and \.{TFM} files.
+
+@ The next question is, ``What are \.{VF} and
+\.{TFM} files?'' A complete answer to that question appears in the
+documentation of the companion programs, \.{VFtoVP} and
+\.{TFtoPL}, so the details will not
+be repeated here. Suffice it to say that a \.{VF} or
+\.{TFM} file stores all of the
+relevant font information in a sequence of 8-bit bytes. The number of
+bytes is always a multiple of 4, so we could regard the files
+as sequences of 32-bit words; but \TeX\ uses the byte interpretation,
+and so does \.{VPtoVF}. Note that the bytes are considered to be unsigned
+numbers.
+
+@<Glob...@>=
+@!vf_file:packed file of 0..255;
+@!tfm_file:packed file of 0..255;
+
+@ On some systems you may have to do something special to write a
+packed file of bytes. For example, the following code didn't work
+when it was first tried at Stanford, because packed files have to be
+opened with a special switch setting on the \PASCAL\ that was used.
+@^system dependencies@>
+
+@<Set init...@>=
+rewrite(vf_file); rewrite(tfm_file);
+
+@* Basic input routines.
+For the purposes of this program, a |byte| is an unsigned 16-bit quantity,
+and an |ASCII_code| is an integer between @'40 and @'177. Such ASCII codes
+correspond to one-character constants like \.{"A"} in \.{WEB} language.
+
+@<Types...@>=
+@!byte=0..65535; {unsigned 16-bit quantity}
+@!ASCII_code=@'40..@'177; {standard ASCII code numbers}
+
+@ One of the things \.{VPtoVF} has to do is convert characters of strings
+to ASCII form, since that is the code used for the family name and the
+coding scheme in a \.{TFM} file. An array |xord| is used to do the
+conversion from |char|; the method below should work with little or no change
+on most \PASCAL\ systems.
+@^system dependencies@>
+
+@d first_ord=0 {ordinal number of the smallest element of |char|}
+@d last_ord=127 {ordinal number of the largest element of |char|}
+
+@<Global...@>=
+@!xord:array[char] of ASCII_code; {conversion table}
+
+@ @<Local variables for init...@>=
+@!k:integer; {all-purpose initialization index}
+
+@ Characters that should not appear in \.{VPL} files (except in comments)
+are mapped into @'177.
+
+@d invalid_code=@'177 {code deserving an error message}
+
+@<Set init...@>=
+for k:=first_ord to last_ord do xord[chr(k)]:=invalid_code;
+xord[' ']:=" "; xord['!']:="!"; xord['"']:=""""; xord['#']:="#";
+xord['$']:="$"; xord['%']:="%"; xord['&']:="&"; xord['''']:="'";
+xord['(']:="("; xord[')']:=")"; xord['*']:="*"; xord['+']:="+"; xord[',']:=",";
+xord['-']:="-"; xord['.']:="."; xord['/']:="/"; xord['0']:="0"; xord['1']:="1";
+xord['2']:="2"; xord['3']:="3"; xord['4']:="4"; xord['5']:="5"; xord['6']:="6";
+xord['7']:="7"; xord['8']:="8"; xord['9']:="9"; xord[':']:=":"; xord[';']:=";";
+xord['<']:="<"; xord['=']:="="; xord['>']:=">"; xord['?']:="?";
+xord['@@']:="@@"; xord['A']:="A"; xord['B']:="B"; xord['C']:="C";
+xord['D']:="D"; xord['E']:="E"; xord['F']:="F"; xord['G']:="G"; xord['H']:="H";
+xord['I']:="I"; xord['J']:="J"; xord['K']:="K"; xord['L']:="L"; xord['M']:="M";
+xord['N']:="N"; xord['O']:="O"; xord['P']:="P"; xord['Q']:="Q"; xord['R']:="R";
+xord['S']:="S"; xord['T']:="T"; xord['U']:="U"; xord['V']:="V"; xord['W']:="W";
+xord['X']:="X"; xord['Y']:="Y"; xord['Z']:="Z"; xord['[']:="["; xord['\']:="\";
+xord[']']:="]"; xord['^']:="^"; xord['_']:="_"; xord['`']:="`"; xord['a']:="a";
+xord['b']:="b"; xord['c']:="c"; xord['d']:="d"; xord['e']:="e"; xord['f']:="f";
+xord['g']:="g"; xord['h']:="h"; xord['i']:="i"; xord['j']:="j"; xord['k']:="k";
+xord['l']:="l"; xord['m']:="m"; xord['n']:="n"; xord['o']:="o"; xord['p']:="p";
+xord['q']:="q"; xord['r']:="r"; xord['s']:="s"; xord['t']:="t"; xord['u']:="u";
+xord['v']:="v"; xord['w']:="w"; xord['x']:="x"; xord['y']:="y"; xord['z']:="z";
+xord['{']:="{"; xord['|']:="|"; xord['}']:="}"; xord['~']:="~";
+
+@ In order to help catch errors of badly nested parentheses, \.{VPtoVF}
+assumes that the user will begin each line with a number of blank spaces equal
+to some constant times the number of open parentheses at the beginning of
+that line. However, the program doesn't know in advance what the constant
+is, nor does it want to print an error message on every line for a user
+who has followed no consistent pattern of indentation.
+
+Therefore the following strategy is adopted: If the user has been consistent
+with indentation for ten or more lines, an indentation error will be
+reported. The constant of indentation is reset on every line that should
+have nonzero indentation.
+
+@<Glob...@>=
+@!line:integer; {the number of the current line}
+@!good_indent:integer; {the number of lines since the last bad indentation}
+@!indent: integer; {the number of spaces per open parenthesis, zero if unknown}
+@!level: integer; {the current number of open parentheses}
+
+@ @<Set init...@>=
+line:=0; good_indent:=0; indent:=0; level:=0;
+
+@ The input need not really be broken into lines of any maximum length, and
+we could read it character by character without any buffering. But we shall
+place it into a small buffer so that offending lines can be displayed in error
+messages.
+
+@<Glob...@>=
+@!left_ln,@!right_ln:boolean; {are the left and right ends of the buffer
+ at end-of-line marks?}
+@!limit:0..buf_size; {position of the last character present in the buffer}
+@!loc:0..buf_size; {position of the last character read in the buffer}
+@!buffer:array[1..buf_size] of char;
+@!input_has_ended:boolean; {there is no more input to read}
+
+@ @<Set init...@>=
+limit:=0; loc:=0; left_ln:=true; right_ln:=true; input_has_ended:=false;
+
+@ Just before each \.{CHARACTER} property list is evaluated, the character
+code is printed in octal notation. Up to eight such codes appear on a line;
+so we have a variable to keep track of how many are currently there.
+
+@<Glob...@>=
+@!chars_on_line:0..8; {the number of characters printed on the current line}
+
+@ @<Set init...@>=
+chars_on_line:=0;
+
+@ The following routine prints an error message and an indication of
+where the error was detected. The error message should not include any
+final punctuation, since this procedure supplies its own.
+
+@d err_print(#)==begin if chars_on_line>0 then print_ln(' ');
+ print(#); show_error_context;
+ end
+
+@p procedure show_error_context; {prints the current scanner location}
+var k:0..buf_size; {an index into |buffer|}
+begin print_ln(' (line ',line:1,').');
+if not left_ln then print('...');
+for k:=1 to loc do print(buffer[k]); {print the characters already scanned}
+print_ln(' ');
+if not left_ln then print(' ');
+for k:=1 to loc do print(' '); {space out the second line}
+for k:=loc+1 to limit do print(buffer[k]); {print the characters yet unseen}
+if right_ln then print_ln(' ')@+else print_ln('...');
+chars_on_line:=0;
+end;
+
+@ Here is a procedure that does the right thing when we are done
+reading the present contents of the buffer. It keeps |buffer[buf_size]|
+empty, in order to avoid range errors on certain \PASCAL\ compilers.
+
+An infinite sequence of right parentheses is placed at the end of the
+file, so that the program is sure to get out of whatever level of nesting
+it is in.
+
+On some systems it is desirable to modify this code so that tab marks
+in the buffer are replaced by blank spaces. (Simply setting
+|xord[chr(@'11)]:=" "| would not work; for example, two-line
+error messages would not come out properly aligned.)
+@^system dependencies@>
+
+@p procedure fill_buffer;
+begin left_ln:=right_ln; limit:=0; loc:=0;
+if left_ln then begin
+ if line>0 then read_ln(vpl_file);
+ incr(line);
+ end;
+if eof(vpl_file) then begin
+ limit:=1; buffer[1]:=')'; right_ln:=false; input_has_ended:=true;
+ end
+else begin
+ while (limit<buf_size-1)and(not eoln(vpl_file)) do begin
+ incr(limit); read(vpl_file,buffer[limit]);
+ end;
+ buffer[limit+1]:=' '; right_ln:=eoln(vpl_file);
+ if left_ln then @<Set |loc| to the number of leading blanks in
+ the buffer, and check the indentation@>;
+ end;
+end;
+
+@ The interesting part about |fill_buffer| is the part that learns what
+indentation conventions the user is following, if any.
+
+@d bad_indent(#)==begin if good_indent>=10 then err_print(#);
+ good_indent:=0; indent:=0;
+ end
+
+@<Set |loc|...@>=
+begin while (loc<limit)and(buffer[loc+1]=' ') do incr(loc);
+if loc<limit then begin
+ if level=0 then
+ if loc=0 then incr(good_indent)
+ else bad_indent('Warning: Indented line occurred at level zero')
+@.Warning: Indented line...@>
+ else if indent=0 then
+ if loc mod level=0 then begin
+ indent:=loc div level; good_indent:=1;
+ end
+ else good_indent:=0
+ else if indent*level=loc then incr(good_indent)
+ else bad_indent('Warning: Inconsistent indentation; ',
+@.Warning: Inconsistent indentation...@>
+ 'you are at parenthesis level ',level:1);
+ end;
+end
+
+@* Basic scanning routines.
+The global variable |cur_char| holds the ASCII code corresponding to the
+character most recently read from the input buffer, or to a character that
+has been substituted for the real one.
+
+@<Global...@>=
+@!cur_char:ASCII_code; {we have just read this}
+
+@ Here is a procedure that sets |cur_char| to an ASCII code for the
+next character of input, if that character is a letter or digit or slash
+or \.>. Otherwise
+it sets |cur_char:=" "|, and the input system will be poised to reread the
+character that was rejected, whether or not it was a space.
+Lower case letters are converted to upper case.
+
+@p procedure get_keyword_char;
+begin while (loc=limit)and(not right_ln) do fill_buffer;
+if loc=limit then cur_char:=" " {end-of-line counts as a delimiter}
+else begin
+ cur_char:=xord[buffer[loc+1]];
+ if cur_char>="a" then cur_char:=cur_char-@'40;
+ if ((cur_char>="0")and(cur_char<="9")) then incr(loc)
+ else if ((cur_char>="A")and(cur_char<="Z")) then incr(loc)
+ else if cur_char="/" then incr(loc)
+ else if cur_char=">" then incr(loc)
+ else cur_char:=" ";
+ end;
+end;
+
+@ The following procedure sets |cur_char| to the next character code,
+and converts lower case to upper case. If the character is a left or
+right parenthesis, it will not be ``digested''; the character will
+be read again and again, until the calling routine does something
+like `|incr(loc)|' to get past it. Such special treatment of parentheses
+insures that the structural information they contain won't be lost in
+the midst of other error recovery operations.
+
+@d backup==begin if (cur_char>")")or(cur_char<"(") then decr(loc);
+ end {undoes the effect of |get_next|}
+
+@p procedure get_next; {sets |cur_char| to next, balks at parentheses}
+begin while loc=limit do fill_buffer;
+incr(loc); cur_char:=xord[buffer[loc]];
+if cur_char>="a" then
+ if cur_char<="z" then cur_char:=cur_char-@'40 {uppercasify}
+ else begin
+ if cur_char=invalid_code then begin
+ err_print('Illegal character in the file');
+@.Illegal character...@>
+ cur_char:="?";
+ end;
+ end
+else if (cur_char<=")")and(cur_char>="(") then decr(loc);
+end;
+
+@ Here's a procedure that scans a hexadecimal digit or a right parenthesis.
+
+@p function get_hex:byte;
+var @!a:integer; {partial result}
+begin repeat get_next;
+until cur_char<>" ";
+a:=cur_char-")";
+if a>0 then begin
+ a:=cur_char-"0";
+ if cur_char>"9" then
+ if cur_char<"A" then a:=-1 else a:=cur_char-"A"+10;
+ end;
+if (a<0)or(a>15) then begin
+ err_print('Illegal hexadecimal digit'); get_hex:=0;
+@.Illegal hexadecimal digit@>
+ end
+else get_hex:=a;
+end;
+
+@ The next procedure is used to ignore the text of a comment, or to pass over
+erroneous material. As such, it has the privilege of passing parentheses.
+It stops after the first right parenthesis that drops the level below
+the level in force when the procedure was called.
+
+@p procedure skip_to_end_of_item;
+var l:integer; {initial value of |level|}
+begin l:=level;
+while level>=l do begin
+ while loc=limit do fill_buffer;
+ incr(loc);
+ if buffer[loc]=')' then decr(level)
+ else if buffer[loc]='(' then incr(level);
+ end;
+if input_has_ended then err_print('File ended unexpectedly: No closing ")"');
+@.File ended unexpectedly...@>
+cur_char:=" "; {now the right parenthesis has been read and digested}
+end;
+
+@ A similar procedure copies the bytes remaining in an item. The copied bytes
+go into an array |vf| that we'll declare later. Leading blanks are ignored.
+
+@d vf_store(#)==
+ begin vf[vf_ptr]:=#;
+ if vf_ptr=vf_size then err_print('I''m out of memory---increase my vfsize!')
+@.I'm out of memory...@>
+ else incr(vf_ptr);
+ end
+
+@p procedure copy_to_end_of_item;
+label 30;
+var l:integer; {initial value of |level|}
+@!nonblank_found:boolean; {have we seen a nonblank character yet?}
+begin l:=level; nonblank_found:=false;
+while true do begin
+ while loc=limit do fill_buffer;
+ if buffer[loc+1]=')' then
+ if level=l then goto 30@+else decr(level);
+ incr(loc);
+ if buffer[loc]='(' then incr(level);
+ if buffer[loc]<>' ' then nonblank_found:=true;
+ if nonblank_found then
+ if xord[buffer[loc]]=invalid_code then begin
+ err_print('Illegal character in the file');
+@.Illegal character...@>
+ vf_store("?");
+ end
+ else vf_store(xord[buffer[loc]]);
+ end;
+30:end;
+
+@ Sometimes we merely want to skip past characters in the input until we
+reach a left or a right parenthesis. For example, we do this whenever we
+have finished scanning a property value and we hope that a right parenthesis
+is next (except for possible blank spaces).
+
+@d skip_to_paren==repeat get_next@;@+ until (cur_char="(")or(cur_char=")")
+@d skip_error(#)==begin err_print(#); skip_to_paren;
+ end {this gets to the right parenthesis if something goes wrong}
+@d flush_error(#)==begin err_print(#); skip_to_end_of_item;
+ end {this gets past the right parenthesis if something goes wrong}
+
+@ After a property value has been scanned, we want to move just past the
+right parenthesis that should come next in the input (except for possible
+blank spaces).
+
+@p procedure finish_the_property; {do this when the value has been scanned}
+begin while cur_char=" " do get_next;
+if cur_char<>")" then err_print('Junk after property value will be ignored');
+@.Junk after property value...@>
+skip_to_end_of_item;
+end;
+
+@* Scanning property names.
+We have to figure out the meaning of names that appear in the \.{VPL} file,
+by looking them up in a dictionary of known keywords. Keyword number $n$
+appears in locations |start[n]| through |start[n+1]-1| of an array called
+|dictionary|.
+
+@d max_name_index=300 {upper bound on the number of keywords}
+@d max_letters=3000 {upper bound on the total length of all keywords}
+
+@<Global...@>=
+@!start:array[1..max_name_index] of 0..max_letters;
+@!dictionary:array[0..max_letters] of ASCII_code;
+@!start_ptr:0..max_name_index; {the first available place in |start|}
+@!dict_ptr:0..max_letters; {the first available place in |dictionary|}
+
+@ @<Set init...@>=
+start_ptr:=1; start[1]:=0; dict_ptr:=0;
+
+@ When we are looking for a name, we put it into the |cur_name| array.
+When we have found it, the corresponding |start| index will go into
+the global variable |name_ptr|.
+
+@d longest_name=20 {length of \.{DEFAULTRULETHICKNESS}}
+
+@<Glob...@>=
+@!cur_name:array[1..longest_name] of ASCII_code; {a name to look up}
+@!name_length:0..longest_name; {its length}
+@!name_ptr:0..max_name_index; {its ordinal number in the dictionary}
+
+@ A conventional hash table with linear probing (cf.\ Algorithm 6.4L
+in {\sl The Art of Computer Pro\-gram\-ming\/}) is used for the dictionary
+operations. If |nhash[h]=0|, the table position is empty, otherwise |nhash[h]|
+points into the |start| array.
+
+@d hash_prime=307 {size of the hash table}
+
+@<Glob...@>=
+@!nhash:array[0..hash_prime-1] of 0..max_name_index;
+@!cur_hash:0..hash_prime-1; {current position in the hash table}
+
+@ @<Local...@>=
+@!h:0..hash_prime-1; {runs through the hash table}
+
+@ @<Set init...@>=
+for h:=0 to hash_prime-1 do nhash[h]:=0;
+
+@ Since there is no chance of the hash table overflowing, the procedure
+is very simple. After |lookup| has done its work, |cur_hash| will point
+to the place where the given name was found, or where it should be inserted.
+
+@p procedure lookup; {finds |cur_name| in the dictionary}
+var k:0..longest_name; {index into |cur_name|}
+@!j:0..max_letters; {index into |dictionary|}
+@!not_found:boolean; {clumsy thing necessary to avoid |goto| statement}
+@!cur_hash_reset:boolean;
+begin @<Compute the hash code, |cur_hash|, for |cur_name|@>;
+not_found:=true;
+cur_hash_reset:=false;
+while not_found do begin
+ if (cur_hash=0) and (cur_hash_reset) then
+ not_found:=false
+ else begin
+ if cur_hash=0 then begin
+ cur_hash:=hash_prime-1;
+ cur_hash_reset:=true
+ end
+ else decr(cur_hash);
+ if nhash[cur_hash]=0 then not_found:=false
+ else begin
+ j:=start[nhash[cur_hash]];
+ if start[nhash[cur_hash]+1]=j+name_length then begin
+ not_found:=false;
+ for k:=1 to name_length do
+ if dictionary[j+k-1]<>cur_name[k] then not_found:=true;
+ end
+ end
+ end
+ end;
+name_ptr:=nhash[cur_hash];
+end;
+
+@ @<Compute the hash...@>=
+cur_hash:=cur_name[1];
+for k:=2 to name_length do
+ cur_hash:=(cur_hash+cur_hash+cur_name[k]) mod hash_prime
+
+@ The ``meaning'' of the keyword that begins at |start[k]| in the
+dictionary is kept in |equiv[k]|. The numeric |equiv| codes are given
+symbolic meanings by the following definitions.
+
+@d comment_code=0
+@d check_sum_code=1
+@d design_size_code=2
+@d design_units_code=3
+@d coding_scheme_code=4
+@d family_code=5
+@d face_code=6
+@d seven_bit_safe_flag_code=7
+@d header_code= 8
+@d font_dimen_code=9
+@d lig_table_code=10
+@d boundary_char_code=11
+@d virtual_title_code=12
+@d map_font_code=13
+@d font_dir_code=14
+@d n_font_dir_code=15
+@d character_code=16
+@d font_name_code=21
+@d font_area_code=22
+@d font_checksum_code=23
+@d font_at_code=24
+@d font_dsize_code=25
+@d parameter_code=30
+@d char_info_code=70
+@d width=1
+@d height=2
+@d depth=3
+@d italic=4
+@d sec_width=5
+@d sec_height=6
+@d sec_depth=7
+@d sec_italic=8
+@d accent=9
+@d prim_top_axis=10
+@d prim_top_axis_bis=11
+@d prim_bot_axis=12
+@d prim_bot_axis_bis=13
+@d prim_mid_hor=14
+@d prim_mid_vert=15
+@d prim_base_slant=16
+@d sec_top_axis=17
+@d sec_top_axis_bis=18
+@d sec_bot_axis=19
+@d sec_bot_axis_bis=20
+@d sec_mid_hor=21
+@d sec_mid_vert=22
+@d sec_base_slant=23
+@d char_wd_code=char_info_code+width
+@d char_ht_code=char_info_code+height
+@d char_dp_code=char_info_code+depth
+@d char_ic_code=char_info_code+italic
+@d sec_width_code=char_info_code+sec_width
+@d sec_height_code=char_info_code+sec_height
+@d sec_depth_code=char_info_code+sec_depth
+@d sec_italic_code=char_info_code+sec_italic
+@d accent_code=char_info_code+accent
+@d prim_top_axis_code=char_info_code+prim_top_axis
+@d prim_top_axis_bis_code=char_info_code+prim_top_axis_bis
+@d prim_bot_axis_code=char_info_code+prim_bot_axis
+@d prim_bot_axis_bis_code=char_info_code+prim_bot_axis_bis
+@d prim_mid_hor_code=char_info_code+prim_mid_hor
+@d prim_mid_vert_code=char_info_code+prim_mid_vert
+@d prim_base_slant_code=char_info_code+prim_base_slant
+@d sec_top_axis_code=char_info_code+sec_top_axis
+@d sec_top_axis_bis_code=char_info_code+sec_top_axis_bis
+@d sec_bot_axis_code=char_info_code+sec_bot_axis
+@d sec_bot_axis_bis_code=char_info_code+sec_bot_axis_bis
+@d sec_mid_hor_code=char_info_code+sec_mid_hor
+@d sec_mid_vert_code=char_info_code+sec_mid_vert
+@d sec_base_slant_code=char_info_code+sec_base_slant
+@d next_larger_code=100
+@d map_code=101
+@d var_char_code=102
+@d select_font_code=110
+@d set_char_code=111
+@d set_rule_code=112
+@d move_right_code=113
+@d move_down_code=115
+@d push_code=117
+@d pop_code=118
+@d special_code=119
+@d special_hex_code=120
+@d label_code=130
+@d stop_code=131
+@d skip_code=132
+@d krn_code=133
+@d lig_code=134
+@d ofm_level_code=140
+@d char_repeat_code=150
+@d char_ivalue_code=151
+@d char_fvalue_code=152
+@d char_mvalue_code=153
+@d char_rule_code=154
+@d char_glue_code=155
+@d char_penalty_code=156
+@d font_rule_code=160
+@d rule_code=161
+@d rule_width_code=162
+@d rule_height_code=163
+@d rule_depth_code=164
+@d font_glue_code=170
+@d glue_code=171
+@d glue_type_code=172
+@d glue_stretch_order_code=173
+@d glue_shrink_order_code=174
+@d glue_width_code=175
+@d glue_stretch_code=176
+@d glue_shrink_code=177
+@d glue_char_code=178
+@d glue_rule_code=179
+@d order_unit_code=181
+@d order_fi_code=182
+@d order_fil_code=183
+@d order_fill_code=184
+@d order_filll_code=185
+@d type_normal_code=186
+@d type_aleaders_code=187
+@d type_cleaders_code=188
+@d type_xleaders_code=189
+@d font_penalty_code=190
+@d penalty_code=191
+@d penalty_val_code=192
+@d font_mvalue_code=200
+@d mvalue_code=201
+@d mvalue_val_code=202
+@d font_fvalue_code=210
+@d fvalue_code=211
+@d fvalue_val_code=212
+@d font_ivalue_code=220
+@d ivalue_code=221
+@d ivalue_val_code=222
+@d clabel_code=231
+@d cpen_code=232
+@d cglue_code=233
+@d cpenglue_code=234
+@d ckrn_code=235
+@d TL_dir_code=240
+@d LT_dir_code=241
+@d TR_dir_code=242
+@d LB_dir_code=243
+@d BL_dir_code=244
+@d RT_dir_code=245
+@d BR_dir_code=246
+@d RB_dir_code=247
+
+@<Glo...@>=
+@!equiv:array[0..max_name_index] of byte;
+@!cur_code:byte; {equivalent most recently found in |equiv|}
+
+@ We have to get the keywords into the hash table and into the dictionary in
+the first place (sigh). The procedure that does this has the desired
+|equiv| code as a parameter. In order to facilitate \.{WEB} macro writing
+for the initialization, the keyword being initialized is placed into the
+last positions of |cur_name|, instead of the first positions.
+
+@p procedure enter_name(v:byte); {|cur_name| goes into the dictionary}
+var k:0..longest_name;
+begin for k:=1 to name_length do
+ cur_name[k]:=cur_name[k+longest_name-name_length];
+{now the name has been shifted into the correct position}
+lookup; {this sets |cur_hash| to the proper insertion place}
+nhash[cur_hash]:=start_ptr; equiv[start_ptr]:=v;
+for k:=1 to name_length do begin
+ dictionary[dict_ptr]:=cur_name[k]; incr(dict_ptr);
+ end;
+incr(start_ptr); start[start_ptr]:=dict_ptr;
+end;
+
+@ Here are the macros to load a name of up to 20 letters into the
+dictionary. For example, the macro |load5| is used for five-letter keywords.
+
+@d tail(#)==enter_name(#)
+@d t20(#)==cur_name[20]:=#;tail
+@d t19(#)==cur_name[19]:=#;t20
+@d t18(#)==cur_name[18]:=#;t19
+@d t17(#)==cur_name[17]:=#;t18
+@d t16(#)==cur_name[16]:=#;t17
+@d t15(#)==cur_name[15]:=#;t16
+@d t14(#)==cur_name[14]:=#;t15
+@d t13(#)==cur_name[13]:=#;t14
+@d t12(#)==cur_name[12]:=#;t13
+@d t11(#)==cur_name[11]:=#;t12
+@d t10(#)==cur_name[10]:=#;t11
+@d t9(#)==cur_name[9]:=#;t10
+@d t8(#)==cur_name[8]:=#;t9
+@d t7(#)==cur_name[7]:=#;t8
+@d t6(#)==cur_name[6]:=#;t7
+@d t5(#)==cur_name[5]:=#;t6
+@d t4(#)==cur_name[4]:=#;t5
+@d t3(#)==cur_name[3]:=#;t4
+@d t2(#)==cur_name[2]:=#;t3
+@d t1(#)==cur_name[1]:=#;t2
+@d load2==name_length:=2;t19
+@d load3==name_length:=3;t18
+@d load4==name_length:=4;t17
+@d load5==name_length:=5;t16
+@d load6==name_length:=6;t15
+@d load7==name_length:=7;t14
+@d load8==name_length:=8;t13
+@d load9==name_length:=9;t12
+@d load10==name_length:=10;t11
+@d load11==name_length:=11;t10
+@d load12==name_length:=12;t9
+@d load13==name_length:=13;t8
+@d load14==name_length:=14;t7
+@d load15==name_length:=15;t6
+@d load16==name_length:=16;t5
+@d load17==name_length:=17;t4
+@d load18==name_length:=18;t3
+@d load19==name_length:=19;t2
+@d load20==name_length:=20;t1
+
+@ (Thank goodness for keyboard macros in the text editor used to create this
+\.{WEB} file.)
+
+@<Enter all the \.{PL} names and their equivalents,
+ except the parameter names@>=
+equiv[0]:=comment_code; {this is used after unknown keywords}
+load8("C")("H")("E")("C")("K")("S")("U")("M")(check_sum_code);@/
+load10("D")("E")("S")("I")("G")("N")("S")("I")("Z")("E")(design_size_code);@/
+load11("D")("E")("S")("I")("G")("N")
+ ("U")("N")("I")("T")("S")(design_units_code);@/
+load12("C")("O")("D")("I")("N")("G")
+ ("S")("C")("H")("E")("M")("E")(coding_scheme_code);@/
+load6("F")("A")("M")("I")("L")("Y")(family_code);@/
+load4("F")("A")("C")("E")(face_code);@/
+load16("S")("E")("V")("E")("N")("B")("I")("T")@/@t\hskip2em@>
+ ("S")("A")("F")("E")("F")("L")("A")("G")(seven_bit_safe_flag_code);@/
+load6("H")("E")("A")("D")("E")("R")(header_code);@/
+load9("F")("O")("N")("T")("D")("I")("M")("E")("N")(font_dimen_code);@/
+load8("L")("I")("G")("T")("A")("B")("L")("E")(lig_table_code);@/
+load12("B")("O")("U")("N")("D")("A")("R")("Y")("C")("H")("A")("R")
+ (boundary_char_code);@/
+load9("C")("H")("A")("R")("A")("C")("T")("E")("R")(character_code);@/
+load9("P")("A")("R")("A")("M")("E")("T")("E")("R")(parameter_code);@/
+load6("C")("H")("A")("R")("W")("D")(char_wd_code);@/
+load6("C")("H")("A")("R")("H")("T")(char_ht_code);@/
+load6("C")("H")("A")("R")("D")("P")(char_dp_code);@/
+load6("C")("H")("A")("R")("I")("C")(char_ic_code);@/
+load5("S")("E")("C")("W")("D")(sec_width_code);@/
+load5("S")("E")("C")("H")("T")(sec_height_code);@/
+load5("S")("E")("C")("D")("P")(sec_depth_code);@/
+load5("S")("E")("C")("I")("C")(sec_italic_code);@/
+load6("A")("C")("C")("E")("N")("T")(accent_code);@/
+load11("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")(prim_top_axis_code);@/
+load14("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(prim_top_axis_bis_code);@/
+load11("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")(prim_bot_axis_code);@/
+load14("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(prim_bot_axis_bis_code);@/
+load10("P")("R")("I")("M")("M")("I")("D")("H")("O")("R")(prim_mid_hor_code);@/
+load10("P")("R")("I")("M")("M")("I")("D")("V")("E")("R")(prim_mid_vert_code);@/
+load13("P")("R")("I")("M")("B")("A")("S")("E")("S")("L")("A")("N")("T")(prim_base_slant_code);@/
+load10("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")(sec_top_axis_code);@/
+load13("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(sec_top_axis_bis_code);@/
+load10("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")(sec_bot_axis_code);@/
+load13("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(sec_bot_axis_bis_code);@/
+load9("S")("E")("C")("M")("I")("D")("H")("O")("R")(sec_mid_hor_code);@/
+load9("S")("E")("C")("M")("I")("D")("V")("E")("R")(sec_mid_vert_code);@/
+load12("S")("E")("C")("B")("A")("S")("E")("S")("L")("A")("N")("T")(sec_base_slant_code);@/
+load10("N")("E")("X")("T")("L")("A")("R")("G")("E")("R")(next_larger_code);@/
+load7("V")("A")("R")("C")("H")("A")("R")(var_char_code);@/
+load3("T")("O")("P")(var_char_code+1);@/
+load3("M")("I")("D")(var_char_code+2);@/
+load3("B")("O")("T")(var_char_code+3);@/
+load3("R")("E")("P")(var_char_code+4);@/
+load3("E")("X")("T")(var_char_code+4); {compatibility with older \.{PL} format}
+load7("C")("O")("M")("M")("E")("N")("T")(comment_code);@/
+load5("L")("A")("B")("E")("L")(label_code);@/
+load4("S")("T")("O")("P")(stop_code);@/
+load4("S")("K")("I")("P")(skip_code);@/
+load3("K")("R")("N")(krn_code);@/
+load3("L")("I")("G")(lig_code);@/
+load4("/")("L")("I")("G")(lig_code+2);@/
+load5("/")("L")("I")("G")(">")(lig_code+6);@/
+load4("L")("I")("G")("/")(lig_code+1);@/
+load5("L")("I")("G")("/")(">")(lig_code+5);@/
+load5("/")("L")("I")("G")("/")(lig_code+3);@/
+load6("/")("L")("I")("G")("/")(">")(lig_code+7);@/
+load7("/")("L")("I")("G")("/")(">")(">")(lig_code+11);@/
+load6("C")("L")("A")("B")("E")("L")(clabel_code);@/
+load4("C")("P")("E")("N")(cpen_code);@/
+load5("C")("G")("L")("U")("E")(cglue_code);@/
+load8("C")("P")("E")("N")("G")("L")("U")("E")(cpenglue_code);@/
+load4("C")("K")("R")("N")(ckrn_code);@/
+load8("O")("F")("M")("L")("E")("V")("E")("L")(ofm_level_code);@/
+load7("F")("O")("N")("T")("D")("I")("R")(font_dir_code);@/
+load8("N")("F")("O")("N")("T")("D")("I")("R")(n_font_dir_code);@/
+load10("C")("H")("A")("R")("R")("E")("P")("E")("A")("T")(char_repeat_code);@/
+load10("C")("H")("A")("R")("I")("V")("A")("L")("U")("E")(char_ivalue_code);@/
+load10("C")("H")("A")("R")("F")("V")("A")("L")("U")("E")(char_fvalue_code);@/
+load10("C")("H")("A")("R")("M")("V")("A")("L")("U")("E")(char_mvalue_code);@/
+load8("C")("H")("A")("R")("R")("U")("L")("E")(char_rule_code);@/
+load8("C")("H")("A")("R")("G")("L")("U")("E")(char_glue_code);@/
+load11("C")("H")("A")("R")("P")("E")("N")("A")("L")("T")("Y")(char_penalty_code);@/
+load8("F")("O")("N")("T")("R")("U")("L")("E")(font_rule_code);@/
+load4("R")("U")("L")("E")(rule_code);@/
+load6("R")("U")("L")("E")("W")("D")(rule_width_code);@/
+load6("R")("U")("L")("E")("H")("T")(rule_height_code);@/
+load6("R")("U")("L")("E")("D")("P")(rule_depth_code);@/
+load8("F")("O")("N")("T")("G")("L")("U")("E")(font_glue_code);@/
+load4("G")("L")("U")("E")(glue_code);@/
+load8("G")("L")("U")("E")("T")("Y")("P")("E")(glue_type_code);@/
+load16("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")("O")("R")("D")("E")("R")(glue_stretch_order_code);@/
+load15("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")("O")("R")("D")("E")("R")(glue_shrink_order_code);@/
+load8("G")("L")("U")("E")("R")("U")("L")("E")(glue_rule_code);@/
+load8("G")("L")("U")("E")("C")("H")("A")("R")(glue_char_code);@/
+load6("G")("L")("U")("E")("W")("D")(glue_width_code);@/
+load11("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")(glue_stretch_code);@/
+load10("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")(glue_shrink_code);@/
+load4("U")("N")("I")("T")(order_unit_code);@/
+load2("F")("I")(order_fi_code);@/
+load3("F")("I")("L")(order_fil_code);@/
+load4("F")("I")("L")("L")(order_fill_code);@/
+load5("F")("I")("L")("L")("L")(order_filll_code);@/
+load6("N")("O")("R")("M")("A")("L")(type_normal_code);@/
+load8("A")("L")("E")("A")("D")("E")("R")("S")(type_aleaders_code);@/
+load8("C")("L")("E")("A")("D")("E")("R")("S")(type_cleaders_code);@/
+load8("X")("L")("E")("A")("D")("E")("R")("S")(type_xleaders_code);@/
+load11("F")("O")("N")("T")("P")("E")("N")("A")("L")("T")("Y")(font_penalty_code);@/
+load7("P")("E")("N")("A")("L")("T")("Y")(penalty_code);@/
+load10("P")("E")("N")("A")("L")("T")("Y")("V")("A")("L")(penalty_val_code);@/
+load10("F")("O")("N")("T")("M")("V")("A")("L")("U")("E")(font_mvalue_code);@/
+load6("M")("V")("A")("L")("U")("E")(mvalue_code);@/
+load9("M")("V")("A")("L")("U")("E")("V")("A")("L")(mvalue_val_code);@/
+load10("F")("O")("N")("T")("F")("V")("A")("L")("U")("E")(font_fvalue_code);@/
+load6("F")("V")("A")("L")("U")("E")(fvalue_code);@/
+load9("F")("V")("A")("L")("U")("E")("V")("A")("L")(fvalue_val_code);@/
+load10("F")("O")("N")("T")("I")("V")("A")("L")("U")("E")(font_ivalue_code);@/
+load6("I")("V")("A")("L")("U")("E")(ivalue_code);@/
+load9("I")("V")("A")("L")("U")("E")("V")("A")("L")(ivalue_val_code);@/
+load2("T")("L")(TL_dir_code);
+load2("L")("T")(LT_dir_code);
+load2("T")("R")(TR_dir_code);
+load2("L")("B")(LB_dir_code);
+load2("B")("L")(BL_dir_code);
+load2("R")("T")(RT_dir_code);
+load2("B")("R")(BR_dir_code);
+load2("R")("B")(RB_dir_code);
+
+@ \.{VPL} files may contain the following in addition to the \.{PL} names.
+
+@<Enter all the \.{VPL} names@>=
+load6("V")("T")("I")("T")("L")("E")(virtual_title_code);@/
+load7("M")("A")("P")("F")("O")("N")("T")(map_font_code);@/
+load3("M")("A")("P")(map_code);@/
+load8("F")("O")("N")("T")("N")("A")("M")("E")(font_name_code);@/
+load8("F")("O")("N")("T")("A")("R")("E")("A")(font_area_code);@/
+load12("F")("O")("N")("T")
+ ("C")("H")("E")("C")("K")("S")("U")("M")(font_checksum_code);@/
+load6("F")("O")("N")("T")("A")("T")(font_at_code);@/
+load9("F")("O")("N")("T")("D")("S")("I")("Z")("E")(font_dsize_code);@/
+load10("S")("E")("L")("E")("C")("T")("F")("O")("N")("T")(select_font_code);@/
+load7("S")("E")("T")("C")("H")("A")("R")(set_char_code);@/
+load7("S")("E")("T")("R")("U")("L")("E")(set_rule_code);@/
+load9("M")("O")("V")("E")("R")("I")("G")("H")("T")(move_right_code);@/
+load8("M")("O")("V")("E")("L")("E")("F")("T")(move_right_code+1);@/
+load8("M")("O")("V")("E")("D")("O")("W")("N")(move_down_code);@/
+load6("M")("O")("V")("E")("U")("P")(move_down_code+1);@/
+load4("P")("U")("S")("H")(push_code);@/
+load3("P")("O")("P")(pop_code);@/
+load7("S")("P")("E")("C")("I")("A")("L")(special_code);@/
+load10("S")("P")("E")("C")("I")("A")("L")("H")("E")("X")(special_hex_code);@/
+
+@ @<Enter the parameter names@>=
+load5("S")("L")("A")("N")("T")(parameter_code+1);@/
+load5("S")("P")("A")("C")("E")(parameter_code+2);@/
+load7("S")("T")("R")("E")("T")("C")("H")(parameter_code+3);@/
+load6("S")("H")("R")("I")("N")("K")(parameter_code+4);@/
+load7("X")("H")("E")("I")("G")("H")("T")(parameter_code+5);@/
+load4("Q")("U")("A")("D")(parameter_code+6);@/
+load10("E")("X")("T")("R")("A")("S")("P")("A")("C")("E")(parameter_code+7);@/
+load4("N")("U")("M")("1")(parameter_code+8);@/
+load4("N")("U")("M")("2")(parameter_code+9);@/
+load4("N")("U")("M")("3")(parameter_code+10);@/
+load6("D")("E")("N")("O")("M")("1")(parameter_code+11);@/
+load6("D")("E")("N")("O")("M")("2")(parameter_code+12);@/
+load4("S")("U")("P")("1")(parameter_code+13);@/
+load4("S")("U")("P")("2")(parameter_code+14);@/
+load4("S")("U")("P")("3")(parameter_code+15);@/
+load4("S")("U")("B")("1")(parameter_code+16);@/
+load4("S")("U")("B")("2")(parameter_code+17);@/
+load7("S")("U")("P")("D")("R")("O")("P")(parameter_code+18);@/
+load7("S")("U")("B")("D")("R")("O")("P")(parameter_code+19);@/
+load6("D")("E")("L")("I")("M")("1")(parameter_code+20);@/
+load6("D")("E")("L")("I")("M")("2")(parameter_code+21);@/
+load10("A")("X")("I")("S")("H")("E")("I")("G")("H")("T")(parameter_code+22);@/
+load20("D")("E")("F")("A")("U")("L")("T")("R")("U")("L")("E")@/@t\hskip2em@>
+ ("T")("H")("I")("C")("K")("N")("E")("S")("S")(parameter_code+8);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("1")(parameter_code+9);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("2")(parameter_code+10);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("3")(parameter_code+11);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("4")(parameter_code+12);@/
+load13("B")("I")("G")("O")("P")
+ ("S")("P")("A")("C")("I")("N")("G")("5")(parameter_code+13);@/
+
+@ When a left parenthesis has been scanned, the following routine
+is used to interpret the keyword that follows, and to store the
+equivalent value in |cur_code|.
+
+@p procedure get_name;
+begin incr(loc); incr(level); {pass the left parenthesis}
+cur_char:=" ";
+while cur_char=" " do get_next;
+if (cur_char>")")or(cur_char<"(") then decr(loc); {back up one character}
+name_length:=0; get_keyword_char; {prepare to scan the name}
+while cur_char<>" " do begin
+ if name_length=longest_name then cur_name[1]:="X" {force error}
+ else incr(name_length);
+ cur_name[name_length]:=cur_char;
+ get_keyword_char;
+ end;
+lookup;
+if name_ptr=0 then err_print('Sorry, I don''t know that property name');
+@.Sorry, I don't know...@>
+cur_code:=equiv[name_ptr];
+end;
+
+@* Scanning numeric data.
+The next thing we need is a trio of subroutines to read the one-byte,
+four-byte, and real numbers that may appear as property values.
+These subroutines are careful to stick to numbers between $-2^{31}$
+and $2^{31}-1$, inclusive, so that a computer with two's complement
+32-bit arithmetic will not be interrupted by overflow.
+
+@ The first number scanner, which returns a one-byte value, surely has
+no problems of arithmetic overflow.
+
+@p function get_byte:byte; {scans a one-byte property value}
+var acc:integer; {an accumulator}
+@!t:ASCII_code; {the type of value to be scanned}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+t:=cur_char; acc:=0;
+repeat get_next;
+until cur_char<>" "; {skip the blanks after the type code}
+if t="C" then @<Scan an ASCII character code@>
+else if t="D" then @<Scan a small decimal number@>
+else if t="O" then @<Scan a small octal number@>
+else if t="H" then @<Scan a small hexadecimal number@>
+else if t="F" then @<Scan a face code@>
+else skip_error('You need "C" or "D" or "O" or "H" or "F" here');
+@.You need "C" or "D" ...here@>
+cur_char:=" "; get_byte:=acc;
+end;
+
+@ The |get_next| routine converts lower case to upper case, but it leaves
+the character in the buffer, so we can unconvert it.
+
+@<Scan an ASCII...@>=
+if (cur_char>=@'41)and(cur_char<=@'176)and
+ ((cur_char<"(")or(cur_char>")")) then
+ acc:=xord[buffer[loc]]
+else skip_error('"C" value must be standard ASCII and not a paren')
+@:C value}\.{"C" value must be...@>
+
+@ @<Scan a small dec...@>=
+begin while (cur_char>="0")and(cur_char<="9") do begin
+ acc:=acc*10+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed 65535');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a small oct...@>=
+begin while (cur_char>="0")and(cur_char<="7") do begin
+ acc:=acc*8+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed ''177777');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a small hex...@>=
+begin while ((cur_char>="0")and(cur_char<="9"))or
+ ((cur_char>="A")and(cur_char<="F")) do begin
+ if cur_char>="A" then cur_char:=cur_char+"0"+10-"A";
+ acc:=acc*16+cur_char-"0";
+ if acc>65535 then begin
+ skip_error('This value shouldn''t exceed "FFFF');
+@.This value shouldn't...@>
+ acc:=0; cur_char:=" ";
+ end
+ else get_next;
+ end;
+backup;
+end
+
+@ @<Scan a face...@>=
+begin if cur_char="B" then acc:=2
+else if cur_char="L" then acc:=4
+else if cur_char<>"M" then acc:=18;
+get_next;
+if cur_char="I" then incr(acc)
+else if cur_char<>"R" then acc:=18;
+get_next;
+if cur_char="C" then acc:=acc+6
+else if cur_char="E" then acc:=acc+12
+else if cur_char<>"R" then acc:=18;
+if acc>=18 then begin
+ skip_error('Illegal face code, I changed it to MRR');
+@.Illegal face code...@>
+ acc:=0;
+ end;
+end
+
+@ The routine that scans a four-byte value puts its output into |cur_bytes|,
+which is a record containing (yes, you guessed it) four bytes.
+
+@<Types...@>=
+@!four_bytes=record @!b0:byte;@+@!b1:byte;@+@!b2:byte;@+@!b3:byte;@+end;
+
+@ @d c0==cur_bytes.b0
+@d c1==cur_bytes.b1
+@d c2==cur_bytes.b2
+@d c3==cur_bytes.b3
+
+@<Glob...@>=
+@!cur_bytes:four_bytes; {a four-byte accumulator}
+@!zero_bytes:four_bytes; {four bytes all zero}
+
+@ @<Set init...@>=
+zero_bytes.b0:=0; zero_bytes.b1:=0; zero_bytes.b2:=0; zero_bytes.b3:=0;
+
+@ Since the |get_four_bytes| routine is used very infrequently, no attempt
+has been made to make it fast; we only want it to work.
+This is no longer the case, but we hope it's not too slow.
+
+@p procedure get_four_bytes; {scans an unsigned constant and sets |four_bytes|}
+var c:integer; {local two-byte accumulator}
+@!r:integer; {radix}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+r:=0; cur_bytes:=zero_bytes; {start with the accumulator zero}
+if cur_char="H" then r:=16
+else if cur_char="O" then r:=8
+else if cur_char="D" then r:=10
+else skip_error('Decimal ("D"), octal ("O"), or hex ("H") value needed here');
+@.Decimal ("D"), octal ("O"), or hex...@>
+if r>0 then begin
+ repeat get_next;
+ until cur_char<>" "; {skip the blanks after the type code}
+ while ((cur_char>="0")and(cur_char<="9"))or@|
+ ((cur_char>="A")and(cur_char<="F")) do
+ @<Multiply by |r|, add |cur_char-"0"|, and |get_next|@>;
+ end;
+end;
+
+function get_integer:integer; {scans an integer property value}
+begin get_four_bytes;
+get_integer:=(c0*@"1000000)+(c1*@"10000)+(c2*@"100)+c3;
+end;
+
+
+@ @<Multiply by |r|...@>=
+begin if cur_char>="A" then cur_char:=cur_char+"0"+10-"A";
+if cur_char>="0"+r then skip_error('Illegal digit')
+@.Illegal digit@>
+else begin
+ c:=c3*r+cur_char-"0"; c3:=c mod 256;@/
+ c:=c2*r+c div 256; c2:=c mod 256;@/
+ c:=c1*r+c div 256; c1:=c mod 256;@/
+ c:=c0*r+c div 256;
+ if c<256 then c0:=c
+ else begin
+ cur_bytes:=zero_bytes;
+ if r=8 then
+ skip_error('Sorry, the maximum octal value is O 37777777777')
+@.Sorry, the maximum...@>
+ else if r=10 then
+ skip_error('Sorry, the maximum decimal value is D 4294967295')
+ else skip_error('Sorry, the maximum hex value is H FFFFFFFF');
+ end;
+ get_next;
+ end;
+end
+
+@ The remaining scanning routine is the most interesting. It scans a real
+constant and returns the nearest |fix_word| approximation to that constant.
+A |fix_word| is a 32-bit integer that represents a real value that
+has been multiplied by $2^{20}$. Since \.{VPtoVF} restricts the magnitude
+of reals to 2048, the |fix_word| will have a magnitude less than $2^{31}$.
+
+@d unity==@'4000000 {$2^{20}$, the |fix_word| 1.0}
+
+@<Types...@>=
+@!fix_word=integer; {a scaled real value with 20 bits of fraction}
+@!unsigned_integer=integer;
+
+@ When a real value is desired, we might as well treat `\.D' and `\.R'
+formats as if they were identical.
+
+@p function get_fix:fix_word; {scans a real property value}
+var negative:boolean; {was there a minus sign?}
+@!acc:integer; {an accumulator}
+@!int_part:integer; {the integer part}
+@!j:0..7; {the number of decimal places stored}
+begin repeat get_next;
+until cur_char<>" "; {skip the blanks before the type code}
+negative:=false; acc:=0; {start with the accumulators zero}
+if (cur_char<>"R")and(cur_char<>"D") then
+ skip_error('An "R" or "D" value is needed here')
+@.An "R" or "D" ... needed here@>
+else begin @<Scan the blanks and/or signs after the type code@>;
+ while (cur_char>="0") and (cur_char<="9") do
+ @<Multiply by 10, add |cur_char-"0"|, and |get_next|@>;
+ int_part:=acc; acc:=0;
+ if cur_char="." then @<Scan the fraction part and put it in |acc|@>;
+ if (acc>=unity)and(int_part=2047) then
+ skip_error('Real constants must be less than 2048')
+@.Real constants must be...@>
+ else acc:=int_part*unity+acc;
+ end;
+if negative then get_fix:=-acc@+else get_fix:=acc;
+end;
+
+@ @<Scan the blanks...@>=
+repeat get_next;
+if cur_char="-" then begin
+ cur_char:=" "; negative:=true;
+ end
+else if cur_char="+" then cur_char:=" ";
+until cur_char<>" "
+
+@ @<Multiply by 10...@>=
+begin acc:=acc*10+cur_char-"0";
+if acc>=2048 then begin
+ skip_error('Real constants must be less than 2048');
+@.Real constants must be...@>
+ acc:=0; cur_char:=" ";
+ end
+else get_next;
+end
+
+@ To scan the fraction $.d_1d_2\ldots\,$, we keep track of up to seven
+of the digits $d_j$. A correct result is obtained if we first compute
+$f^\prime=\lfloor 2^{21}(d_1\ldots d_j)/10^j\rfloor$, after which
+$f=\lfloor(f^\prime+1)/2\rfloor$. It is possible to have $f=1.0$.
+
+@<Glob...@>=
+@!fraction_digits:array[1..7] of integer; {$2^{21}$ times $d_j$}
+
+@ @<Scan the frac...@>=
+begin j:=0; get_next;
+while (cur_char>="0")and(cur_char<="9") do begin
+ if j<7 then begin
+ incr(j); fraction_digits[j]:=@'10000000*(cur_char-"0");
+ end;
+ get_next;
+ end;
+acc:=0;
+while j>0 do begin
+ acc:=fraction_digits[j]+(acc div 10); decr(j);
+ end;
+acc:=(acc+10) div 20;
+end
+
+@* Storing the property values.
+When property values have been found, they are squirreled away in a bunch
+of arrays. The header information is unpacked into bytes in an array
+called |header_bytes|. The ligature/kerning program is stored in an array
+of type |four_bytes|.
+Another |four_bytes| array holds the specifications of extensible characters.
+The kerns and parameters are stored in separate arrays of |fix_word| values.
+Virtual font data goes into an array |vf| of single-byte values.
+
+We maintain information about at most |max_font+1| local fonts.
+
+Instead of storing the design size in the header array, we will keep it
+in a |fix_word| variable until the last minute. The number of units in the
+design size is also kept in a |fix_word|.
+
+@<Glob...@>=
+@!header_bytes:array[header_index] of byte; {the header block}
+@!header_ptr:header_index; {the number of header bytes in use}
+@!design_size:fix_word; {the design size}
+@!design_units:fix_word; {reciprocal of the scaling factor}
+@!frozen_du:boolean; {have we used |design_units| irrevocably?}
+@!seven_bit_safe_flag:boolean; {does the file claim to be seven-bit-safe?}
+@!lig_kern:array[0..max_lig_steps] of four_bytes; {the ligature program}
+@!nl:unsigned_integer; {the number of ligature/kern instructions so far}
+@!min_nl:unsigned_integer; {the final value of |nl| must be at least this}
+@!kern:array[0..max_kerns] of fix_word; {the distinct kerning amounts}
+@!nk:0..max_kerns; {the number of entries of |kern|}
+@!exten:array[char_type] of four_bytes; {extensible character specs}
+@!ne:xchar_type; {the number of extensible characters}
+@!param:array[1..max_param_words] of fix_word; {\.{FONTDIMEN} parameters}
+@!np:0..max_param_words; {the largest parameter set nonzero}
+@!check_sum_specified:boolean; {did the user name the check sum?}
+@!bchar:xchar_type; {right boundary character, |xmax_char| if unspecified}
+@!font_dir:integer; {font direction}
+@!vf:array[0..vf_size] of byte; {stored bytes for \.{VF} file}
+@!vf_ptr:0..vf_size; {first unused location in |vf|}
+@!vtitle_start:0..vf_size; {starting location of \.{VTITLE} string}
+@!vtitle_length:byte; {length of \.{VTITLE} string}
+@!packet_start:array[char_type] of 0..vf_size;
+ {beginning location of character packet}
+@!packet_length:array[char_type] of integer; {length of character packet}
+@!font_ptr:xfont_type; {number of distinct local fonts seen}
+@!cur_font:xfont_type; {number of the current local font}
+@!fname_start:array[font_type] of 0..vf_size; {beginning of local font name}
+@!fname_length:array[font_type] of byte; {length of local font name}
+@!farea_start:array[font_type] of 0..vf_size; {beginning of local font area}
+@!farea_length:array[font_type] of byte; {length of local font area}
+@!font_checksum:array[font_type] of four_bytes; {local font checksum}
+@!font_number:array[xfont_type] of integer; {local font id number}
+@!font_at:array[font_type] of fix_word; {local font ``at size''}
+@!font_dsize:array[font_type] of fix_word; {local font design size}
+
+@ @<Types...@>=
+@!char_type=0..max_char;
+@!xchar_type=0..xmax_char;
+@!xxchar_type=0..xxmax_char;
+@!font_type=0..max_font;
+@!xfont_type=0..xmax_font;
+@!header_index=0..max_header_bytes;
+@!indx=xxchar_type;
+
+@ @<Local...@>=
+@!d:header_index; {an index into |header_bytes|}
+
+@ We start by setting up the default values.
+
+@d check_sum_loc=0
+@d design_size_loc=4
+@d coding_scheme_loc=8
+@d family_loc=coding_scheme_loc+40
+@d seven_flag_loc=family_loc+20
+@d face_loc=seven_flag_loc+3
+
+@<Set init...@>=
+for d:=0 to 18*4-1 do header_bytes[d]:=0;
+header_bytes[8]:=11; header_bytes[9]:="U";
+header_bytes[10]:="N";
+header_bytes[11]:="S";
+header_bytes[12]:="P";
+header_bytes[13]:="E";
+header_bytes[14]:="C";
+header_bytes[15]:="I";
+header_bytes[16]:="F";
+header_bytes[17]:="I";
+header_bytes[18]:="E";
+header_bytes[19]:="D";
+@.UNSPECIFIED@>
+for d:=family_loc to family_loc+11 do header_bytes[d]:=header_bytes[d-40];
+design_size:=10*unity; design_units:=unity; frozen_du:=false;
+seven_bit_safe_flag:=false;@/
+header_ptr:=18*4; nl:=0; min_nl:=0; nk:=0; ne:=0; np:=0;@/
+check_sum_specified:=false; bchar:=xmax_char;@/
+font_dir:=0;
+vf_ptr:=0; vtitle_start:=0; vtitle_length:=0; font_ptr:=0;
+for k:=0 to max_char do packet_start[k]:=vf_size;
+for k:=0 to 127 do packet_length[k]:=1;
+for k:=128 to 255 do packet_length[k]:=2;
+for k:=256 to max_char do packet_length[k]:=3;
+
+@ Most of the dimensions, however, go into the |memory| array. There are
+at most |max_char+2| widths, |max_char+2| heights,
+|max_char+2| depths, and |max_char+2| italic corrections,
+since the value 0 is required but it need not be used. So |memory| has room
+for |4*max_char+8| entries, each of which is a |fix_word|. An auxiliary table called
+|link| is used to link these words together in linear lists, so that
+sorting and other operations can be done conveniently.
+
+We also add four ``list head'' words to the |memory| and |link| arrays;
+these are in locations |width| through |italic|, i.e., 1 through 4.
+For example, |link[height]| points to the smallest element in
+the sorted list of distinct heights that have appeared so far, and
+|memory[height]| is the number of distinct heights.
+
+@<Types...@>=
+@!pointer=0..mem_size; {an index into memory}
+
+@ The arrays |char_wd|, |char_ht|, |char_dp|, and |char_ic| contain
+pointers to the |memory| array entries where the corresponding dimensions
+appear. Two other arrays, |char_tag| and |char_remainder|, hold
+the other information that \.{TFM} files pack into a |char_info_word|.
+
+@d no_tag=0 {vanilla character}
+@d lig_tag=1 {character has a ligature/kerning program}
+@d list_tag=2 {character has a successor in a charlist}
+@d ext_tag=3 {character is extensible}
+@d bchar_label==char_remainder[xmax_char]
+ {beginning of ligature program for left boundary}
+
+@<Glob...@>=
+@!memory:array[pointer] of fix_word; {character dimensions and kerns}
+@!mem_ptr:pointer; {largest |memory| word in use}
+@!link:array[pointer] of pointer; {to make lists of |memory| items}
+@!char_wd:array[char_type] of pointer; {pointers to the widths}
+@!char_ht:array[char_type] of pointer; {pointers to the heights}
+@!char_dp:array[char_type] of pointer; {pointers to the depths}
+@!char_ic:array[char_type] of pointer; {pointers to italic corrections}
+@!char_tag:array[char_type] of no_tag..ext_tag; {character tags}
+@!char_remainder:array[xchar_type] of xchar_type;
+ {pointers to ligature labels,
+ next larger characters, or extensible characters}
+@!top_width,@!top_height,@!top_depth,@!top_italic:integer;
+
+@ @<Local...@>=
+@!c:integer; {runs through all character codes}
+
+@ @<Set init...@>=
+bchar_label:=xmax_label;
+for c:=0 to max_char do begin
+ char_wd[c]:=0; char_ht[c]:=0; char_dp[c]:=0; char_ic[c]:=0;@/
+ char_tag[c]:=no_tag; char_remainder[c]:=0;
+ end;
+memory[0]:=@'17777777777; {an ``infinite'' element at the end of the lists}
+memory[width]:=0; link[width]:=0; {width list is empty}
+memory[height]:=0; link[height]:=0; {height list is empty}
+memory[depth]:=0; link[depth]:=0; {depth list is empty}
+memory[italic]:=0; link[italic]:=0; {italic list is empty}
+mem_ptr:=italic;
+
+@ As an example of these data structures, let us consider the simple
+routine that inserts a potentially new element into one of the dimension
+lists. The first parameter indicates the list head (i.e., |h=width| for
+the width list, etc.); the second parameter is the value that is to be
+inserted into the list if it is not already present. The procedure
+returns the value of the location where the dimension appears in |memory|.
+The fact that |memory[0]| is larger than any legal dimension makes the
+algorithm particularly short.
+
+We do have to handle two somewhat subtle situations. A width of zero must be
+put into the list, so that a zero-width character in the font will not appear
+to be nonexistent (i.e., so that its |char_wd| index will not be zero), but
+this does not need to be done for heights, depths, or italic corrections.
+Furthermore, it is necessary to test for memory overflow even though we
+have provided room for the maximum number of different dimensions in any
+legal font, since the \.{VPL} file might foolishly give any number of
+different sizes to the same character.
+
+@p function sort_in(@!h:pointer;@!d:fix_word):pointer; {inserts into list}
+var p:pointer; {the current node of interest}
+begin if (d=0)and(h<>width) then sort_in:=0
+else begin p:=h;
+ while d>=memory[link[p]] do p:=link[p];
+ if (d=memory[p])and(p<>h) then sort_in:=p
+ else if mem_ptr=mem_size then begin
+ err_print('Memory overflow: too many widths, etc');
+@.Memory overflow...@>
+ print_ln('Congratulations! It''s hard to make this error.');
+ sort_in:=p;
+ end
+ else begin
+ incr(mem_ptr); memory[mem_ptr]:=d;
+ link[mem_ptr]:=link[p]; link[p]:=mem_ptr; incr(memory[h]);
+ sort_in:=mem_ptr;
+ end;
+ end;
+end;
+
+@ When these lists of dimensions are eventually written to the \.{OFM}
+file, we may have to do some rounding of values, because the \.{OFM} file
+allows at most 65536 widths, 256 heights, 256 depths, and 256 italic
+corrections. The following procedure takes a given list head |h| and a
+given dimension |d|, and returns the minimum $m$ such that the elements
+of the list can be covered by $m$ intervals of width $d$. It also sets
+|next_d| to the smallest value $d^\prime>d$ such that the covering found
+by this procedure would be different. In particular, if $d=0$ it computes
+the number of elements of the list, and sets |next_d| to the smallest
+distance between two list elements. (The covering by intervals of width
+|next_d| is not guaranteed to have fewer than $m$ elements, but in
+practice this seems to happen most of the time.)
+
+@<Glob...@>=
+@!next_d:fix_word; {the next larger interval that is worth trying}
+
+@ Once again we can make good use of the fact that |memory[0]| is ``infinite.''
+
+@p function min_cover(@!h:pointer;@!d:fix_word):integer;
+var p:pointer; {the current node of interest}
+@!l:fix_word; {the least element covered by the current interval}
+@!m:integer; {the current size of the cover being generated}
+begin m:=0; p:=link[h]; next_d:=memory[0];
+while p<>0 do begin
+ incr(m); l:=memory[p];
+ while memory[link[p]]<=l+d do p:=link[p];
+ p:=link[p];
+ if memory[p]-l<next_d then next_d:=memory[p]-l;
+ end;
+min_cover:=m;
+end;
+
+@ The following procedure uses |min_cover| to determine the smallest $d$
+such that a given list can be covered with at most a given number of
+intervals.
+
+@p function shorten(@!h:pointer;m:integer):fix_word; {finds best way to round}
+var d:fix_word; {the current trial interval length}
+@!k:integer; {the size of a minimum cover}
+begin if memory[h]>m then begin
+ excess:=memory[h]-m;
+ k:=min_cover(h,0); d:=next_d; {now the answer is at least |d|}
+ repeat d:=d+d; k:=min_cover(h,d);
+ until k<=m; {first we ascend rapidly until finding the range}
+ d:=d div 2; k:=min_cover(h,d); {now we run through the feasible steps}
+ while k>m do begin
+ d:=next_d; k:=min_cover(h,d);
+ end;
+ shorten:=d;
+ end
+else shorten:=0;
+end;
+
+@ When we are nearly ready to output the \.{TFM} file, we will set
+|index[p]:=k| if the dimension in |memory[p]| is being rounded to the
+|k|th element of its list.
+
+@<Glob...@>=
+@!index:array[pointer] of byte;
+@!excess:byte; {number of words to remove, if list is being shortened}
+
+@ Here is the procedure that sets the |index| values. It also shortens
+the list so that there is only one element per covering interval;
+the remaining elements are the midpoints of their clusters.
+
+@p procedure set_indices(@!h:pointer;@!d:fix_word); {reduces and indexes a list}
+var p:pointer; {the current node of interest}
+@!q:pointer; {trails one step behind |p|}
+@!m:byte; {index number of nodes in the current interval}
+@!l:fix_word; {least value in the current interval}
+begin q:=h; p:=link[q]; m:=0;
+while p<>0 do begin
+ incr(m); l:=memory[p]; index[p]:=m;
+ while memory[link[p]]<=l+d do begin
+ p:=link[p]; index[p]:=m; decr(excess);
+ if excess=0 then d:=0;
+ end;
+ link[q]:=p; memory[p]:=l+(memory[p]-l) div 2; q:=p; p:=link[p];
+ end;
+memory[h]:=m;
+end;
+
+@* The input phase.
+We're ready now to read and parse the \.{VPL} file, storing property
+values as we go.
+
+@<Glob...@>=
+@!c:integer; {the current character or byte being processed}
+@!cprime:char_type; {Processing for several characters together}
+@!crange:char_type; {ditto}
+@!x:fix_word; {current dimension of interest}
+@!k:integer; {general-purpose index}
+
+@ @<Read all the input@>=
+cur_char:=" ";
+repeat while cur_char=" " do get_next;
+if cur_char="(" then @<Read a font property value@>
+else if (cur_char=")")and not input_has_ended then begin
+ err_print('Extra right parenthesis');
+ incr(loc); cur_char:=" ";
+ end
+@.Extra right parenthesis@>
+else if not input_has_ended then junk_error;
+until input_has_ended
+
+@ The |junk_error| routine just referred to is called when something
+appears in the forbidden area between properties of a property list.
+
+@p procedure junk_error; {gets past no man's land}
+begin err_print('There''s junk here that is not in parentheses');
+@.There's junk here...@>
+skip_to_paren;
+end;
+
+@ For each font property, we are supposed to read the data from the
+left parenthesis that is the current value of |cur_char| to the right
+parenthesis that matches it in the input. The main complication is
+to recover with reasonable grace from various error conditions that
+might arise.
+
+@<Read a font property value@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<110) and (cur_code>character_code) then
+ flush_error('This property name doesn''t belong on the outer level')
+else if (cur_code>=110) and ((cur_code mod 10)<>0) then
+ flush_error('This property name doesn''t belong on the outer level')
+@.This property name doesn't belong...@>
+else begin
+ @<Read the font property value specified by |cur_code|@>;
+ finish_the_property;
+ end;
+end
+
+@ @<Read the font property value spec...@>=
+case cur_code of
+check_sum_code: begin check_sum_specified:=true; read_four_bytes(check_sum_loc);
+ end;
+design_size_code: @<Read the design size@>;
+design_units_code: @<Read the design units@>;
+coding_scheme_code: read_BCPL(coding_scheme_loc,40);
+family_code: read_BCPL(family_loc,20);
+face_code: begin c:=get_byte; if c>255 then begin
+ err_print('FACE clipped to 255'); c:=255 end;
+ header_bytes[face_loc]:=c
+ end;
+seven_bit_safe_flag_code: @<Read the seven-bit-safe flag@>;
+header_code: @<Read an indexed header word@>;
+font_dimen_code: @<Read font parameter list@>;
+lig_table_code: read_lig_kern;
+boundary_char_code: bchar:=get_byte;
+virtual_title_code: begin vtitle_start:=vf_ptr; copy_to_end_of_item;
+ if vf_ptr>vtitle_start+255 then begin
+ err_print('VTITLE clipped to 255 characters'); vtitle_length:=255;
+@.VTITLE clipped...@>
+ end
+ else vtitle_length:=vf_ptr-vtitle_start;
+ end;
+map_font_code:@<Read a local font list@>;
+character_code: read_char_info;
+ofm_level_code: @<Read OFM level code@>;
+font_dir_code: @<Read font direction code@>;
+n_font_dir_code: @<Read natural font direction code@>;
+char_repeat_code: read_repeated_character_info;
+font_rule_code: read_font_rule_list;
+font_glue_code: read_font_glue_list;
+font_penalty_code: read_font_penalty_list;
+font_mvalue_code: read_font_mvalue_list;
+font_fvalue_code: read_font_fvalue_list;
+font_ivalue_code: read_font_ivalue_list;
+end
+
+@ The |case| statement just given makes use of three subroutines that we
+haven't defined yet. The first of these puts a 32-bit octal quantity
+into four specified bytes of the header block.
+
+@p procedure read_four_bytes(l:header_index);
+begin get_four_bytes;
+header_bytes[l]:=c0;
+header_bytes[l+1]:=c1;
+header_bytes[l+2]:=c2;
+header_bytes[l+3]:=c3;
+end;
+
+@ The second little procedure is used to scan a string and to store it in
+the ``{\mc BCPL} format'' required by \.{TFM} files. The string is supposed
+to contain at most |n| bytes, including the first byte (which holds the
+length of the rest of the string).
+
+@p procedure read_BCPL(l:header_index;n:byte);
+var k:header_index;
+begin k:=l;
+while cur_char=" " do get_next;
+while (cur_char<>"(")and(cur_char<>")") do begin
+ if k<l+n then incr(k);
+ if k<l+n then header_bytes[k]:=cur_char;
+ get_next;
+ end;
+if k=l+n then begin
+ err_print('String is too long; its first ',n-1:1,
+@.String is too long...@>
+ ' characters will be kept'); decr(k);
+ end;
+header_bytes[l]:=k-l;
+while k<l+n-1 do begin {tidy up the remaining bytes by setting them to nulls}
+ incr(k); header_bytes[k]:=0;
+ end;
+end;
+
+@ @<Read the design size@>=
+begin next_d:=get_fix;
+if next_d<unity then
+ err_print('The design size must be at least 1')
+@.The design size must...@>
+else design_size:=next_d;
+end
+
+@ @<Read the design units@>=
+begin next_d:=get_fix;
+if next_d<=0 then
+ err_print('The number of units per design size must be positive')
+@.The number of units...@>
+else if frozen_du then
+ err_print('Sorry, it''s too late to change the design units')
+@.Sorry, it's too late...@>
+else design_units:=next_d;
+end
+
+@ @<Read the seven-bit-safe...@>=
+begin while cur_char=" " do get_next;
+if cur_char="T" then seven_bit_safe_flag:=true
+else if cur_char="F" then seven_bit_safe_flag:=false
+else err_print('The flag value should be "TRUE" or "FALSE"');
+@.The flag value should be...@>
+skip_to_paren;
+end
+
+@ @<Read an indexed header word@>=
+begin c:=get_byte;
+if c<18 then skip_error('HEADER indices should be 18 or more')
+@.HEADER indices...@>
+else if 4*c+4>max_header_bytes then
+ skip_error('This HEADER index is too big for my present table size')
+@.This HEADER index is too big...@>
+else begin
+ while header_ptr<4*c+4 do begin
+ header_bytes[header_ptr]:=0; incr(header_ptr);
+ end;
+ read_four_bytes(4*c);
+ end;
+end
+
+@ The remaining kinds of font property values that need to be read are
+those that involve property lists on higher levels. Each of these has a
+loop similar to the one that was used at level zero. Then we put the
+right parenthesis back so that `|finish_the_property|' will be happy;
+there is probably a more elegant way to do this.
+
+@d finish_inner_property_list==begin decr(loc); incr(level); cur_char:=")";
+ end
+
+@<Read font parameter list@>=
+begin while level=1 do
+ begin while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a parameter value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a parameter value@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<parameter_code)or(cur_code>=char_wd_code) then
+ flush_error('This property name doesn''t belong in a FONTDIMEN list')
+@.This property name doesn't belong...@>
+else begin if cur_code=parameter_code then c:=get_integer
+ else c:=cur_code-parameter_code;
+ if c=0 then flush_error('PARAMETER index must not be zero')
+@.PARAMETER index must not...@>
+ else if c>max_param_words then
+ flush_error('This PARAMETER index is too big for my present table size')
+@.This PARAMETER index is too big...@>
+ else begin
+ while np<c do begin
+ incr(np); param[np]:=0;
+ end;
+ param[c]:=get_fix;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Read a local font list@>=
+begin font_number[font_ptr]:=get_integer; cur_font:=0;
+while font_number[font_ptr]<>font_number[cur_font] do incr(cur_font);
+if cur_font=font_ptr then {it's a new font number}
+ if font_ptr<xmax_font then @<Initialize a new local font@>
+ else err_print('Sorry, too many different mapfonts');
+@.Sorry, too many different mapfonts@>
+if cur_font=font_ptr then skip_to_end_of_item
+else while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a local font property@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Initialize a new local font@>=
+begin incr(font_ptr);
+fname_start[cur_font]:=vf_size; fname_length[cur_font]:=4; {\.{NULL}}
+farea_start[cur_font]:=vf_size; farea_length[cur_font]:=0;
+font_checksum[cur_font]:=zero_bytes;
+font_at[cur_font]:=@'4000000; {denotes design size of this virtual font}
+font_dsize[cur_font]:=@'50000000; {the |fix_word| for 10}
+end
+
+@ @<Read a local font property@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<font_name_code)or(cur_code>font_dsize_code) then
+ flush_error('This property name doesn''t belong in a MAPFONT list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code of
+ font_name_code:@<Read a local font name@>;
+ font_area_code:@<Read a local font area@>;
+ font_checksum_code:begin
+ get_four_bytes; font_checksum[cur_font]:=cur_bytes;
+ end;
+ font_at_code: begin frozen_du:=true;
+ if design_units=unity then font_at[cur_font]:=get_fix
+ else font_at[cur_font]:=round((get_fix/design_units)*1048576.0);
+ end;
+ font_dsize_code:font_dsize[cur_font]:=get_fix;
+ end; {there are no other cases}
+ finish_the_property;
+ end;
+end
+
+@ @<Read a local font name@>=
+begin fname_start[cur_font]:=vf_ptr; copy_to_end_of_item;
+if vf_ptr>fname_start[cur_font]+255 then begin
+ err_print('FONTNAME clipped to 255 characters');
+@.FONTNAME clipped...@>
+ fname_length[cur_font]:=255;
+ end
+else fname_length[cur_font]:=vf_ptr-fname_start[cur_font];
+end
+
+@ @<Read a local font area@>=
+begin farea_start[cur_font]:=vf_ptr; copy_to_end_of_item;
+if vf_ptr>farea_start[cur_font]+255 then begin
+ err_print('FONTAREA clipped to 255 characters');
+@.FONTAREA clipped...@>
+ farea_length[cur_font]:=255;
+ end
+else farea_length[cur_font]:=vf_ptr-farea_start[cur_font];
+end
+
+@ @<Read ligature/kern list@>=
+begin lk_step_ended:=false;
+while level=1 do
+ begin while cur_char=" " do get_next;
+ if cur_char="(" then read_lig_kern_command
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a ligature/kern command@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code>=label_code) and (cur_code<=(lig_code+11)) then begin
+ case cur_code of
+ label_code:@<Read a label step@>;
+ stop_code:@<Read a stop step@>;
+ skip_code:@<Read a skip step@>;
+ krn_code:@<Read a kerning step@>;
+ lig_code,lig_code+1,lig_code+2,lig_code+3,lig_code+5,lig_code+6,
+ lig_code+7,lig_code+11:@<Read a ligature step@>;
+ end; {there are no other cases |>=label_code|}
+ finish_the_property;
+ end
+else if (cur_code>=clabel_code) and (cur_code<=cpenglue_code) then begin
+ case cur_code of
+ clabel_code:@<Read an extended label step@>;
+ cpen_code:@<Read an extended penalty step@>;
+ cglue_code:@<Read an extended glue step@>;
+ cpenglue_code:@<Read an extended penalty/glue step@>;
+ ckrn_code:@<Read an extended kern step@>;
+ end; {there are no other cases |>=label_code|}
+ finish_the_property;
+ end
+else flush_error('This property name doesn''t belong in a LIGTABLE list');
+@.This property name doesn't belong...@>
+end
+
+@ When a character is about to be tagged, we call the following
+procedure so that an error message is given in case of multiple tags.
+
+@p procedure check_tag(c:byte); {print error if |c| already tagged}
+begin case char_tag[c] of
+no_tag: do_nothing;
+lig_tag: err_print('This character already appeared in a LIGTABLE LABEL');
+@.This character already...@>
+list_tag: err_print('This character already has a NEXTLARGER spec');
+ext_tag: err_print('This character already has a VARCHAR spec');
+end;
+end;
+
+@ @<Read a label step@>=
+begin while cur_char=" " do get_next;
+if cur_char="B" then begin
+ bchar_label:=nl; skip_to_paren; {\.{LABEL BOUNDARYCHAR}}
+ end
+else begin
+ backup; c:=get_byte;
+ check_tag(c); char_tag[c]:=lig_tag; char_remainder[c]:=nl;
+ end;
+if min_nl<=nl then min_nl:=nl+1;
+lk_step_ended:=false;
+end
+
+@ @d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program}
+@d kern_flag=128 {op code for a kern step}
+
+@<Globals...@>=
+@!lk_step_ended:boolean;
+ {was the last \.{LIGTABLE} property \.{LIG} or \.{KRN}?}
+@!krn_ptr:0..max_kerns; {an index into |kern|}
+
+@ @<Read a stop step@>=
+if not lk_step_ended then
+ err_print('STOP must follow LIG or KRN')
+@.STOP must follow LIG or KRN@>
+else begin
+ lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag;
+ lk_step_ended:=false;
+ end
+
+@ @<Read a skip step@>=
+if not lk_step_ended then
+ err_print('SKIP must follow LIG or KRN')
+@.SKIP must follow LIG or KRN@>
+else begin
+ c:=get_byte;
+ if c>=128 then err_print('Maximum SKIP amount is 127')
+@.Maximum SKIP amount...@>
+ else if nl+c>=max_lig_steps then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+ else begin
+ lig_kern[nl-1].b0:=c;
+ if min_nl<=nl+c then min_nl:=nl+c+1;
+ end;
+ lk_step_ended:=false;
+ end
+
+@ @<Read a ligature step@>=
+begin lig_kern[nl].b0:=0;
+lig_kern[nl].b2:=cur_code-lig_code;
+lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b3:=get_byte;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read a kerning step@>=
+begin lig_kern[nl].b0:=0; lig_kern[nl].b1:=get_byte;
+kern[nk]:=get_fix; krn_ptr:=0;
+while kern[krn_ptr]<>kern[nk] do incr(krn_ptr);
+if krn_ptr=nk then begin
+ if nk<max_kerns then incr(nk)
+ else begin
+ err_print('Sorry, too many different kerns for me to handle');
+@.Sorry, too many different kerns...@>
+ decr(krn_ptr);
+ end;
+ end;
+if ofm_level=-1 then begin
+ lig_kern[nl].b2:=kern_flag+(krn_ptr div 256);
+ lig_kern[nl].b3:=krn_ptr mod 256;
+ end
+else begin
+ lig_kern[nl].b2:=kern_flag+(krn_ptr div 65536);
+ lig_kern[nl].b3:=krn_ptr mod 65536;
+ end;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Global...@>=
+@!category_remainders:array[0..256] of integer;
+@!ivalue_category,@!max_ivalue_category:integer;
+@!glue_category,@!max_glue_category:integer;
+@!penalty_category,@!max_penalty_category:integer;
+
+@ @<Set init...@>=
+for ivalue_category:=0 to 256 do begin
+ category_remainders[ivalue_category]:=-1;
+end;
+max_ivalue_category:=-1;
+max_glue_category:=-1;
+max_penalty_category:=-1;
+
+@ @<Read an extended label step@>=
+begin
+c:=get_byte;
+category_remainders[c]:=nl;
+if max_ivalue_category<c then max_ivalue_category:=c;
+if min_nl<=nl then min_nl:=nl+1;
+lk_step_ended:=false;
+end
+
+@ @<Read an extended penalty step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=17;
+penalty_category:=get_byte;
+if max_penalty_category<penalty_category then
+ max_penalty_category:=penalty_category;
+lig_kern[nl].b3:=penalty_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended glue step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=18;
+glue_category:=get_byte;
+if max_glue_category<glue_category then
+ max_glue_category:=glue_category;
+lig_kern[nl].b3:=glue_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended penalty/glue step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=19;
+penalty_category:=get_byte;
+if max_penalty_category<penalty_category then
+ max_penalty_category:=penalty_category;
+glue_category:=get_byte;
+if max_glue_category<glue_category then
+ max_glue_category:=glue_category;
+lig_kern[nl].b3:=penalty_category*256+glue_category;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Read an extended kern step@>=
+begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte;
+lig_kern[nl].b2:=20;
+kern[nk]:=get_fix; krn_ptr:=0;
+while kern[krn_ptr]<>kern[nk] do incr(krn_ptr);
+if krn_ptr=nk then begin
+ if nk<max_kerns then incr(nk)
+ else begin
+ err_print('Sorry, too many different kerns for me to handle');
+@.Sorry, too many different kerns...@>
+ decr(krn_ptr);
+ end;
+ end;
+if krn_ptr>65535 then
+ err_print('Sorry, too many different kerns for me to handle');
+lig_kern[nl].b3:=krn_ptr;
+if nl>=max_lig_steps-1 then
+ err_print('Sorry, LIGTABLE too long for me to handle')
+@.Sorry, LIGTABLE too long...@>
+else incr(nl);
+lk_step_ended:=true;
+end
+
+@ @<Globals...@>=
+@!char_extended_tag:array [char_type] of boolean;
+
+@ @<Set init...@>=
+for c:=0 to max_char do
+ char_extended_tag[c]:=false;
+
+@ @<Finish up the extended font stuff@>=
+begin
+if max_penalty_category>0 then begin
+ if nkp=0 then
+ err_print('No PENALTY table')
+ else if npp[0]<max_penalty_category then
+ err_print('Not enough PENALTY entries');
+ end;
+if max_glue_category>0 then begin
+ if nkg=0 then
+ err_print('No GLUE table')
+ else if npg[0]<max_glue_category then
+ err_print('Not enough GLUE entries');
+ end;
+if max_ivalue_category>0 then begin
+ if nki=0 then
+ err_print('No IVALUE table')
+ else if npi[0]<max_ivalue_category then
+ err_print('Not enough IVALUE entries')
+ else begin
+ for c:=0 to max_char do begin
+ if (char_wd[c]<>0) then begin
+ for j:=0 to max_ivalue_category do
+ if char_table[c,0]=j then begin
+ if category_remainders[j]<>-1 then begin
+ if char_tag[c]<>0 then
+ err_print('Character already has a tag')
+ else begin
+ char_extended_tag[c]:=true;
+ char_remainder[c]:=category_remainders[j];
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+ end;
+end
+
+@ @<Global...@>=
+tables_read:boolean;
+
+@ @<Set init...@>=
+tables_read:=false;
+
+@ Finally we come to the part of \.{VPtoVF}'s input mechanism
+that is used most, the processing of individual character data.
+
+@<Read character info list@>=
+begin
+if not tables_read then begin
+ @<Compute the new header information for OFM files@>;
+ tables_read:=true;
+ end;
+c:=get_byte; {read the character code that is being specified}
+@<Print |c| in hex notation@>;
+while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then read_character_property
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|}
+finish_inner_property_list;
+end
+
+@ @<Globals...@>=
+@!char_original:array [0..max_char] of integer;
+@!char_repeats:array [0..max_char] of integer;
+@!diff:boolean;
+@!needed_space,@!extra_bytes:integer;
+
+@ @<Set init...@>=
+for ch_entry:=0 to max_char do begin
+ char_original[ch_entry]:=ch_entry;
+ char_repeats[ch_entry]:=0;
+ end;
+
+@ @<Read repeated character info@>=
+begin
+if not tables_read then begin
+ compute_new_header_ofm;
+ tables_read:=true;
+ end;
+c:=get_byte; {read the character code that is being specified}
+@<Print |c| in hex notation@>;
+crange:=get_byte; {read how many characters are being defined}
+if (crange<0) then begin
+ err_print('Character ranges must be positive');
+ crange:=0;
+ end;
+if ((c+crange)>max_char) then begin
+ err_print('Character range too large');
+ crange:=0;
+ end;
+print('-'); print_hex(c+crange);
+while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then read_character_property
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|}
+finish_inner_property_list;
+cprime:=c;
+for c:=(cprime+1) to (cprime+crange) do begin
+ char_wd[c]:=char_wd[cprime];
+ char_ht[c]:=char_ht[cprime];
+ char_dp[c]:=char_dp[cprime];
+ char_ic[c]:=char_ic[cprime];
+ for tab:=0 to (nki+nkf+nkr+nkg+nkp-1) do begin
+ char_table[c,tab]:= char_table[cprime,tab];
+ end;
+ end;
+end
+
+@ Tables for character parameters
+
+@d char_param_tables==8
+
+@<Globals...@>=
+@!char_table:array [0..max_char,0..char_param_tables] of integer;
+@!ch_table,@!ch_entry:integer;
+@!temp_value:integer;
+
+@ @<Set init...@>=
+for c:=0 to max_char do
+ for ch_table:=0 to char_param_tables do
+ char_table[c,ch_table]:=0;
+
+@ @<Read a character property@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<char_wd_code) or
+ ((cur_code>var_char_code) and not
+ ((cur_code>=char_ivalue_code) and (cur_code<=char_penalty_code)))
+ then
+ flush_error('This property name doesn''t belong in a CHARACTER list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code of
+ char_wd_code:char_wd[c]:=sort_in(width,get_fix);
+ char_ht_code:char_ht[c]:=sort_in(height,get_fix);
+ char_dp_code:char_dp[c]:=sort_in(depth,get_fix);
+ char_ic_code:char_ic[c]:=sort_in(italic,get_fix);
+ sec_width_code:temp_value:=get_fix;
+ sec_height_code:temp_value:=get_fix;
+ sec_depth_code:temp_value:=get_fix;
+ sec_italic_code:temp_value:=get_fix;
+ accent_code:temp_value:=get_fix;
+ prim_top_axis_code:temp_value:=get_fix;
+ prim_top_axis_bis_code:temp_value:=get_fix;
+ prim_bot_axis_code:temp_value:=get_fix;
+ prim_bot_axis_bis_code:temp_value:=get_fix;
+ prim_mid_hor_code:temp_value:=get_fix;
+ prim_mid_vert_code:temp_value:=get_fix;
+ prim_base_slant_code:temp_value:=get_fix;
+ sec_top_axis_code:temp_value:=get_fix;
+ sec_top_axis_bis_code:temp_value:=get_fix;
+ sec_bot_axis_code:temp_value:=get_fix;
+ sec_bot_axis_bis_code:temp_value:=get_fix;
+ sec_mid_hor_code:temp_value:=get_fix;
+ sec_mid_vert_code:temp_value:=get_fix;
+ sec_base_slant_code:temp_value:=get_fix;
+ next_larger_code:begin check_tag(c); char_tag[c]:=list_tag;
+ char_remainder[c]:=get_byte;
+ end;
+ map_code:read_packet(c);
+ var_char_code:@<Read an extensible recipe for |c|@>;
+ char_ivalue_code: begin
+ ch_table:=get_integer;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkci then nkci:=ch_table;
+ end;
+ char_fvalue_code: begin
+ ch_table:=get_integer+nki;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcf then nkcf:=ch_table;
+ end;
+ char_mvalue_code: begin
+ ch_table:=get_integer+nki+nkf;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcm then nkcm:=ch_table;
+ end;
+ char_rule_code: begin
+ ch_table:=get_integer+nki+nkf+nkm;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcr then nkcr:=ch_table;
+ end;
+ char_glue_code: begin
+ ch_table:=get_integer+nki+nkf+nkm+nkr;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcg then nkcg:=ch_table;
+ end;
+ char_penalty_code: begin
+ ch_table:=get_integer+nki+nkf+nkm+nkr+nkg;
+ ch_entry:=get_integer;
+ char_table[c,ch_table]:=ch_entry;
+ if ch_table>nkcp then nkcp:=ch_table;
+ end;
+ end;@/
+ finish_the_property;
+ end;
+end
+
+@ @<Read an extensible r...@>=
+begin if ne=xmax_char then
+ err_print('Sorry, too many VARCHAR specs')
+@.Sorry, too many VARCHAR specs@>
+else begin
+ check_tag(c); char_tag[c]:=ext_tag; char_remainder[c]:=ne;@/
+ exten[ne]:=zero_bytes;
+ while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an extensible piece@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ incr(ne);
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an extensible p...@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<var_char_code+1)or(cur_code>var_char_code+4) then
+ flush_error('This property name doesn''t belong in a VARCHAR list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code-(var_char_code+1) of
+ 0:exten[ne].b0:=get_byte;
+ 1:exten[ne].b1:=get_byte;
+ 2:exten[ne].b2:=get_byte;
+ 3:exten[ne].b3:=get_byte;
+ end;@/
+ finish_the_property;
+ end;
+end
+
+@ The input routine is now complete except for the following code,
+which prints a progress report as the file is being read.
+
+@ @<Glob...@>=
+@!HEX: packed array [1..32] of char;
+
+@ @<Set init...@>=
+HEX:='0123456789ABCDEF';@/
+
+@ The array |dig| will hold a sequence of digits to be output.
+
+@<Glob...@>=
+@!dig:array[0..32] of integer;
+
+@ Here, in fact, are two procedures that output
+|dig[j-1]|$\,\ldots\,$|dig[0]|, given $j>0$.
+
+@p procedure out_digs(j:integer); {outputs |j| digits}
+begin repeat decr(j); out(HEX[1+dig[j]]);
+ until j=0;
+end;
+@#
+procedure print_digs(j:integer); {prints |j| digits}
+begin repeat decr(j); print(HEX[1+dig[j]]);
+ until j=0;
+end;
+
+@ The |print_number| procedure indicates how |print_digs| can be used.
+This procedure can print in octal, decimal or hex notation.
+
+@d print_hex(#)==print_number(#,16)
+@d print_octal(#)==print_number(#,8)
+@d print_decimal(#)==print_number(#,10)
+
+@p procedure print_number(c:integer; form:integer); {prints value of
+|c|}
+var j:0..32; {index into |dig|}
+begin
+j:=0;
+if (c<0) then begin
+ print_ln('Internal error: print_number (negative value)');
+ c:=0;
+ end;
+if form=8 then
+ print('''') {an apostrophe indicates the octal notation}
+else if form=16 then
+ print('"') { a double apostrophe indicates the hexadecimal
+notation}
+else if form<>10 then begin
+ print_ln('Internal error: print_number (form)');
+ form:=16;
+ end;
+while (c>0) or (j=0) do begin
+ dig[j]:=c mod form; c:=c div form;
+ j:=j+1;
+ end;
+print_digs(j);
+end;
+
+@ @<Print |c| in hex...@>=
+begin if chars_on_line=8 then begin
+ print_ln(' '); chars_on_line:=1;
+ end
+else begin
+ if chars_on_line>0 then print(' ');
+ incr(chars_on_line);
+ end;
+print_hex(c); {progress report}
+end
+
+
+@* Assembling the mappings.
+Each \.{MAP} property is a sequence of \.{DVI} instructions, for which
+we need to know some of the opcodes.
+We add afterwards the definitions for outputting typesetting commands.
+
+@d set_char_0=0 {\.{DVI} command to typeset character 0 and move right}
+@d set1=128 {typeset a character and move right}
+@d set_rule=132 {typeset a rule and move right}
+@d push=141 {save the current positions}
+@d pop=142 {restore previous positions}
+@d right1=143 {move right}
+@d w0=147 {move right by |w|}
+@d w1=148 {move right and set |w|}
+@d x0=152 {move right by |x|}
+@d x1=153 {move right and set |x|}
+@d down1=157 {move down}
+@d y0=161 {move down by |y|}
+@d y1=162 {move down and set |y|}
+@d z0=166 {move down by |z|}
+@d z1=167 {move down and set |z|}
+@d fnt_num_0=171 {set current font to 0}
+@d fnt1=235 {set current font}
+@d xxx1=239 {extension to \.{DVI} primitives}
+@d xxx4=242 {potentially long extension to \.{DVI} primitives}
+@d fnt_def1=243 {define the meaning of a font number}
+@d pre=247 {preamble}
+@d post=248 {postamble beginning}
+@d Incr_Decr(#) == #
+@d Incr(#) == #:=#+Incr_Decr {increase a variable}
+
+@d out_four(#) ==
+if x>=0 then #(x div @"1000000)
+else begin Incr(x)(@"40000000); Incr(x)(@"40000000);
+ #((x div @"1000000) + 128);
+ end;
+x:=x mod @"1000000; #(x div @"10000);
+x:=x mod @"10000; #(x div @"100);
+#(x mod @"100)
+
+@d out_cmd(#) ==
+if (x<@"100)and(x>=0) then begin
+ if (o<>set1)or(x>127) then
+ if (o=fnt1)and(x<64) then Incr(x)(fnt_num_0) @+ else #(o);
+ end
+else begin
+ if (x<@"10000)and(x>=0) then #(o+1) @+ else begin
+ if (x<@"1000000)and(x>=0) then #(o+2) @+ else begin
+ #(o+3);
+ if x>=0 then #(x div @"1000000)
+ else begin
+ Incr(x)(@"40000000); Incr(x)(@"40000000);
+ #((x div @"1000000) + 128); x:=x mod @"1000000;
+ end;
+ #(x div @"10000); x:=x mod @"10000;
+ end;
+ #(x div @"10000); x:=x mod @"10000;
+ end;
+ #(x div @"100); x:=x mod @"100;
+ end;
+#(x)
+
+@p
+procedure vf_store_set(@!x:integer);
+var @!o:byte;
+begin o:=set1; out_cmd(vf_store);
+end;
+
+procedure vfout_set(@!x:integer);
+var @!o:byte;
+begin o:=set1; out_cmd(vout);
+end;
+
+procedure vf_store_fnt(@!x:integer);
+var @!o:byte;
+begin o:=fnt1; out_cmd(vf_store);
+end;
+
+procedure vfout_fntdef(@!x:integer);
+var @!o:byte;
+begin o:=fnt_def1; out_cmd(vout);
+end;
+
+procedure vfout_char(@!x:integer);
+begin out_four(vout);
+end;
+
+
+@ We keep stacks of movement values, in order to optimize the \.{DVI} code
+in simple cases.
+
+@<Glob...@>=
+@!hstack:array[0..max_stack] of 0..2; {number of known horizontal movements}
+@!vstack:array[0..max_stack] of 0..2; {number of known vertical movements}
+@!wstack,@!xstack,@!ystack,@!zstack:array[0..max_stack] of fix_word;
+@!stack_ptr:0..max_stack;
+
+@ The packet is built by straightforward assembly of \.{DVI} instructions.
+
+@p @<Declare the |vf_fix| procedure@>@;@/
+procedure read_packet(@!c:byte);
+var @!cc:char_type; {character being typeset}
+@!x:fix_word; {movement}
+@!h,@!v:0..2; {top of |hstack| and |vstack|}
+@!special_start:0..vf_size; {location of |xxx1| command}
+@!k:0..vf_size; {loop index}
+begin packet_start[c]:=vf_ptr; stack_ptr:=0; h:=0; v:=0;
+cur_font:=0;
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read and assemble a list of \.{DVI} commands@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+while stack_ptr>0 do begin
+ err_print('Missing POP supplied');
+@.Missing POP supplied@>
+ vf_store(pop); decr(stack_ptr);
+ end;
+packet_length[c]:=vf_ptr-packet_start[c];
+finish_inner_property_list;
+end;
+
+@ @<Read and assemble a list of \.{DVI}...@>=
+begin get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if (cur_code<select_font_code)or(cur_code>special_hex_code) then
+ flush_error('This property name doesn''t belong in a MAP list')
+@.This property name doesn't belong...@>
+else begin
+ case cur_code of
+ select_font_code:@<Assemble a font selection@>;
+ set_char_code:@<Assemble a typesetting instruction@>;
+ set_rule_code:@<Assemble a rulesetting instruction@>;
+ move_right_code,move_right_code+1:@<Assemble a horizontal movement@>;
+ move_down_code,move_down_code+1:@<Assemble a vertical movement@>;
+ push_code:@<Assemble a stack push@>;
+ pop_code:@<Assemble a stack pop@>;
+ special_code,special_hex_code:@<Assemble a special command@>;
+ end;@/
+ finish_the_property;
+ end;
+end
+
+@ @<Assemble a font selection@>=
+begin font_number[font_ptr]:=get_integer;
+cur_font:=0;
+while font_number[font_ptr]<>font_number[cur_font] do incr(cur_font);
+if cur_font=font_ptr then err_print('Undefined MAPFONT cannot be selected')
+@.Undefined MAPFONT...@>
+else vf_store_fnt(cur_font);
+end
+
+@ @<Assemble a typesetting instruction@>=
+if cur_font=font_ptr then
+ err_print('Character cannot be typeset in undefined font')
+@.Character cannot be typeset...@>
+else begin
+ cc:=get_byte; vf_store_set(cc);
+ end
+
+@ Here's a procedure that converts a |fix_word| to a sequence of
+\.{DVI} bytes.
+
+@<Declare the |vf_fix|...@>=
+procedure vf_fix(@!opcode:byte;@!x:fix_word);
+var negative:boolean;
+@!k:0..4; {number of bytes to typeset}
+@!t:integer; {threshold}
+begin frozen_du:=true;
+if design_units<>unity then x:=round((x/design_units)*1048576.0);
+if x>0 then negative:=false
+else begin negative:=true; x:=-1-x;@+end;
+if opcode=0 then begin
+ k:=4; t:=@'100000000;@+end
+else begin
+ t:=127; k:=1;
+ while x>t do begin
+ t:=256*t+255; incr(k);
+ end;
+ vf_store(opcode+k-1); t:=t div 128 +1;
+ end;
+repeat if negative then begin
+ vf_store(255-(x div t)); negative:=false;
+ x:=(x div t)*t+t-1-x;
+ end
+else vf_store((x div t) mod 256);
+decr(k); t:=t div 256;
+until k=0;
+end;
+
+@ @<Assemble a rulesetting instruction@>=
+begin vf_store(set_rule); vf_fix(0,get_fix); vf_fix(0,get_fix);
+end
+
+@ @<Assemble a horizontal movement@>=
+begin if cur_code=move_right_code then x:=get_fix@+else x:=-get_fix;
+if h=0 then begin
+ wstack[stack_ptr]:=x; h:=1; vf_fix(w1,x);@+end
+else if x=wstack[stack_ptr] then vf_store(w0)
+else if h=1 then begin
+ xstack[stack_ptr]:=x; h:=2; vf_fix(x1,x);@+end
+else if x=xstack[stack_ptr] then vf_store(x0)
+else vf_fix(right1,x);
+end
+
+@ @<Assemble a vertical movement@>=
+begin if cur_code=move_down_code then x:=get_fix@+else x:=-get_fix;
+if v=0 then begin
+ ystack[stack_ptr]:=x; v:=1; vf_fix(y1,x);@+end
+else if x=ystack[stack_ptr] then vf_store(y0)
+else if v=1 then begin
+ zstack[stack_ptr]:=x; v:=2; vf_fix(z1,x);@+end
+else if x=zstack[stack_ptr] then vf_store(z0)
+else vf_fix(down1,x);
+end
+
+@ @<Assemble a stack push@>=
+if stack_ptr=max_stack then {too pushy}
+ err_print('Don''t push so much---stack is full!')
+@.Don't push so much...@>
+else begin
+ vf_store(push); hstack[stack_ptr]:=h; vstack[stack_ptr]:=v;
+ incr(stack_ptr); h:=0; v:=0;
+ end
+
+@ @<Assemble a stack pop@>=
+if stack_ptr=0 then
+ err_print('Empty stack cannot be popped')
+@.Empty stack...@>
+else begin
+ vf_store(pop); decr(stack_ptr);
+ h:=hstack[stack_ptr]; v:=vstack[stack_ptr];
+ end
+
+@ @<Assemble a special command@>=
+begin vf_store(xxx1); vf_store(0); {dummy length}
+special_start:=vf_ptr;
+if cur_code=special_code then copy_to_end_of_item
+else begin
+ repeat x:=get_hex;
+ if cur_char>")" then vf_store(x*16+get_hex);
+ until cur_char<=")";
+ end;
+if vf_ptr-special_start>255 then @<Convert |xxx1| command to |xxx4|@>
+else vf[special_start-1]:=vf_ptr-special_start;
+end
+
+@ @<Convert |xxx1|...@>=
+if vf_ptr+3>vf_size then begin
+ err_print('Special command being clipped---no room left!');
+@.Special command being clipped...@>
+ vf_ptr:=special_start+255; vf[special_start-1]:=255;
+ end
+else begin
+ for k:=vf_ptr downto special_start do vf[k+3]:=vf[k];
+ x:=vf_ptr-special_start; vf_ptr:=vf_ptr+3;
+ vf[special_start-2]:=xxx4;
+ vf[special_start-1]:=x div @'100000000;
+ vf[special_start]:=(x div @'200000) mod 256;
+ vf[special_start+1]:=(x div @'400) mod 256;
+ vf[special_start+2]:=x mod 256;
+ end
+
+@* The checking and massaging phase.
+Once the whole \.{VPL} file has been read in, we must check it for consistency
+and correct any errors. This process consists mainly of running through
+the characters that exist and seeing if they refer to characters that
+don't exist. We also compute the true value of |seven_unsafe|; we make sure
+that the charlists and ligature programs contain no loops; and we
+shorten the lists of widths, heights, depths, and italic corrections,
+if necessary, to keep from exceeding the required maximum sizes.
+
+@<Glob...@>=
+@!seven_unsafe:boolean; {do seven-bit characters generate eight-bit ones?}
+
+@ @<Correct and check the information@>=
+if nl>0 then @<Make sure the ligature/kerning program ends appropriately@>;
+seven_unsafe:=false;
+for c:=0 to max_char do if char_wd[c]<>0 then
+ @<For all characters |g| generated by |c|,
+ make sure that |char_wd[g]| is nonzero, and
+ set |seven_unsafe| if |c<128<=g|@>;
+if bchar_label<xmax_label then begin
+ c:=xmax_char; @<Check ligature program of |c|@>;
+ end;
+if seven_bit_safe_flag and seven_unsafe then
+ print_ln('The font is not really seven-bit-safe!');
+@.The font is not...safe@>
+@<Check for infinite ligature loops@>;
+@<Doublecheck the lig/kern commands and the extensible recipes@>;
+finish_extended_font;
+for c:=0 to max_char do
+ @<Make sure that |c| is not the largest element of a charlist cycle@>;
+@<Put the width, height, depth, and italic lists into final form@>
+
+@ The checking that we need in several places is accomplished by three
+macros that are only slightly tricky.
+
+@d existence_tail(#)==begin char_wd[g]:=sort_in(width,0);
+ print(#,' '); print_hex(c);
+ print_ln(' had no CHARACTER spec.');
+ end;
+ end
+@d check_existence_and_safety(#)==begin g:=#;
+ if (g>=128)and(c<128) then seven_unsafe:=true;
+ if char_wd[g]=0 then existence_tail
+@d check_existence(#)==begin g:=#;
+ if char_wd[g]=0 then existence_tail
+
+@<For all characters |g| generated by |c|...@>=
+case char_tag[c] of
+no_tag: do_nothing;
+lig_tag: @<Check ligature program of |c|@>;
+list_tag: check_existence_and_safety(char_remainder[c])
+ ('The character NEXTLARGER than');
+@.The character NEXTLARGER...@>
+ext_tag:@<Check the pieces of |exten[c]|@>;
+end
+
+@ @<Check the pieces...@>=
+begin if exten[char_remainder[c]].b0>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b0)
+ ('TOP piece of character');
+@.TOP piece of character...@>
+if exten[char_remainder[c]].b1>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b1)
+ ('MID piece of character');
+@.MID piece of character...@>
+if exten[char_remainder[c]].b2>0 then
+ check_existence_and_safety(exten[char_remainder[c]].b2)
+ ('BOT piece of character');
+@.BOT piece of character...@>
+check_existence_and_safety(exten[char_remainder[c]].b3)
+ ('REP piece of character');
+@.REP piece of character...@>
+end
+
+@ @<Make sure that |c| is not the largest element of a charlist cycle@>=
+if char_tag[c]=list_tag then begin
+ g:=char_remainder[c];
+ while (g<c)and(char_tag[g]=list_tag) do g:=char_remainder[g];
+ if g=c then begin
+ char_tag[c]:=no_tag;
+ print('A cycle of NEXTLARGER characters has been broken at ');
+@.A cycle of NEXTLARGER...@>
+ print_hex(c); print_ln('.');
+ end;
+ end
+
+@ @<Glob...@>=
+@!delta:fix_word; {size of the intervals needed for rounding}
+
+@ @d round_message(#)==if delta>0 then print_ln('I had to round some ',
+@.I had to round...@>
+ #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.')
+
+@<Put the width, height, depth, and italic lists into final form@>=
+case ofm_level of
+ -1: begin
+ top_width:=255; top_depth:=15; top_height:=15; top_italic:=63;
+ end;
+ 0: begin
+ top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255;
+ end;
+ 1: begin
+ top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255;
+ end;
+ end;
+delta:=shorten(width,max_width); set_indices(width,delta);
+ round_message('width');@/
+delta:=shorten(height,max_height); set_indices(height,delta);
+ round_message('height');@/
+delta:=shorten(depth,max_depth); set_indices(depth,delta);
+ round_message('depth');@/
+delta:=shorten(italic,max_italic); set_indices(italic,delta);
+ round_message('italic correction');
+
+@ @d clear_lig_kern_entry== {make an unconditional \.{STOP}}
+ lig_kern[nl].b0:=255; lig_kern[nl].b1:=0;
+ lig_kern[nl].b2:=0; lig_kern[nl].b3:=0
+
+@<Make sure the ligature/kerning program ends...@>=
+begin if bchar_label<xmax_label then begin {make room for it}
+ clear_lig_kern_entry; incr(nl);
+ end; {|bchar_label| will be stored later}
+while min_nl>nl do begin
+ clear_lig_kern_entry; incr(nl);
+ end;
+if (lig_kern[nl-1].b0 mod 256)=0 then
+ lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag;
+end
+
+@ It's not trivial to check for infinite loops generated by repeated
+insertion of ligature characters. But fortunately there is a nice
+algorithm for such testing, copied here from the program \.{TFtoPL}
+where it is explained further.
+
+@d simple=0 {$f(x,y)=z$}
+@d left_z=1 {$f(x,y)=f(z,y)$}
+@d right_z=2 {$f(x,y)=f(x,z)$}
+@d both_z=3 {$f(x,y)=f(f(x,z),y)$}
+@d pending=4 {$f(x,y)$ is being evaluated}
+
+
+@ @<Glo...@>=
+@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|}
+@!hash:array[0..hash_size] of integer;
+@!class:array[0..hash_size] of simple..pending;
+@!lig_z:array[0..hash_size] of xxchar_type;
+@!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|}
+@!hash_list:array[0..hash_size] of 0..hash_size; {list of those nonzero entries}
+@!h,@!hh:0..hash_size; {indices into the hash table}
+@!tt:indx; {temporary register}
+@!x_lig_cycle,@!y_lig_cycle:xchar_type; {problematic ligature pair}
+
+@ @<Set init...@>=
+hash_ptr:=0; y_lig_cycle:=xmax_char;
+for k:=0 to hash_size do hash[k]:=0;
+
+@ @d lig_exam==lig_kern[lig_ptr].b1
+@d lig_gen==lig_kern[lig_ptr].b3
+
+@<Check lig...@>=
+begin lig_ptr:=char_remainder[c];
+repeat if hash_input(lig_ptr,c) then begin
+ if lig_kern[lig_ptr].b2<kern_flag then begin
+ if lig_exam<>bchar then
+ check_existence(lig_exam)('LIG character examined by');
+@.LIG character examined...@>
+ check_existence(lig_gen)('LIG character generated by');
+@.LIG character generated...@>
+ if lig_gen>=128 then if(c<128)or(c=bchar) then
+ if(lig_exam<128)or(lig_exam=bchar) then seven_unsafe:=true;
+ end
+ else if lig_exam<>bchar then
+ check_existence(lig_exam)('KRN character examined by');
+@.KRN character examined...@>
+ end;
+if (lig_kern[lig_ptr].b0 mod 256)>=stop_flag then lig_ptr:=nl
+else lig_ptr:=lig_ptr+1+lig_kern[lig_ptr].b0;
+until lig_ptr>=nl;
+end
+
+@ The |hash_input| procedure is copied from \.{TFtoPL}, but it is made
+into a boolean function that returns |false| if the ligature command
+was masked by a previous one.
+
+@p function hash_input(@!p,@!c:indx):boolean;
+ {enter data for character |c| and command in location |p|, unless it isn't new}
+label 30; {go here for a quick exit}
+var @!cc:simple..both_z; {class of data being entered}
+@!zz:char_type; {function value or ligature character being entered}
+@!y:char_type; {the character after the cursor}
+@!key:integer; {value to be stored in |hash|}
+@!t:integer; {temporary register for swapping}
+begin if hash_ptr=hash_size then
+ begin hash_input:=false; goto 30;@+end;
+@<Compute the command parameters |y|, |cc|, and |zz|@>;
+key:=xmax_char*c+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size;
+while hash[h]>0 do begin
+ if hash[h]<=key then begin
+ if hash[h]=key then begin
+ hash_input:=false; goto 30; {unused ligature command}
+ end;
+ t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion}
+ t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap}
+ t:=lig_z[h]; lig_z[h]:=zz; zz:=t;
+ end;
+ if h>0 then decr(h)@+else h:=hash_size;
+ end;
+hash[h]:=key; class[h]:=cc; lig_z[h]:=zz;
+incr(hash_ptr); hash_list[hash_ptr]:=h;
+hash_input:=true;
+30:end;
+
+@ @<Compute the command param...@>=
+y:=lig_kern[p].b1; t:=lig_kern[p].b2; cc:=simple;
+zz:=lig_kern[p].b3;
+if t>=kern_flag then zz:=y
+else begin
+ case t of
+ 0,6:do_nothing; {\.{LIG},\.{/LIG>}}
+ 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}}
+ 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}}
+ 2:cc:=right_z; {\.{/LIG}}
+ 3:cc:=both_z; {\.{/LIG/}}
+ end; {there are no other cases}
+ end
+
+@ (More good stuff from \.{TFtoPL}.)
+
+@p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@>
+ {compute $f$ for arguments known to be in |hash[h]|}
+function eval(@!x,@!y:indx):indx; {compute $f(x,y)$ with hashtable lookup}
+var @!key:integer; {value sought in hash table}
+begin key:=xmax_char*x+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size;
+while hash[h]>key do
+ if h>0 then decr(h)@+else h:=hash_size;
+if hash[h]<key then eval:=y {not in ordered hash table}
+else eval:=f(h,x,y);
+end;
+
+@ Pascal's beastly convention for |forward| declarations prevents us from
+saying |function f(h,x,y:indx):indx| here.
+
+@p function f;
+begin case class[h] of
+ simple: do_nothing;
+ left_z: begin class[h]:=pending; lig_z[h]:=eval(lig_z[h],y); class[h]:=simple;
+ end;
+ right_z: begin class[h]:=pending; lig_z[h]:=eval(x,lig_z[h]); class[h]:=simple;
+ end;
+ both_z: begin class[h]:=pending; lig_z[h]:=eval(eval(x,lig_z[h]),y);
+ class[h]:=simple;
+ end;
+ pending: begin x_lig_cycle:=x; y_lig_cycle:=y;
+ lig_z[h]:=xxmax_char; class[h]:=simple;
+ end; {the value |xxmax_char| will break all cycles, since it's not in |hash|}
+ end; {there are no other cases}
+f:=lig_z[h];
+end;
+
+@ @<Check for infinite...@>=
+if hash_ptr<hash_size then for hh:=1 to hash_ptr do begin
+ tt:=hash_list[hh];
+ if class[tt]>simple then {make sure $f$ is well defined}
+ tt:=f(tt,(hash[tt]-1)div xmax_char,(hash[tt]-1)mod xmax_char);
+ end;
+if(hash_ptr=hash_size)or(y_lig_cycle<xmax_char) then begin
+ if hash_ptr<hash_size then begin
+ print('Infinite ligature loop starting with ');
+@.Infinite ligature loop...@>
+ if x_lig_cycle=xmax_char
+ then print('boundary')@+else print_hex(x_lig_cycle);
+ print(' and '); print_hex(y_lig_cycle); print_ln('!');
+ end
+ else print_ln('Sorry, I haven''t room for so many ligature/kern pairs!');
+@.Sorry, I haven't room...@>
+ print_ln('All ligatures will be cleared.');
+ for c:=0 to max_char do if char_tag[c]=lig_tag then begin
+ char_tag[c]:=no_tag; char_remainder[c]:=0;
+ end;
+ nl:=0; bchar:=xmax_char; bchar_label:=xmax_label;
+ end
+
+@ The lig/kern program may still contain references to nonexistent characters,
+if parts of that program are never used. Similarly, there may be extensible
+characters that are never used, because they were overridden by
+\.{NEXTLARGER}, say. This would produce an invalid \.{TFM} file; so we
+must fix such errors.
+
+@d double_check_tail(#)==@t\1@>if char_wd[0]=0
+ then char_wd[0]:=sort_in(width,0);
+ print('Unused ',#,' refers to nonexistent character ');
+ print_hex(c); print_ln('!');
+ end;
+ end
+@d double_check_lig(#)==begin c:=lig_kern[lig_ptr].#;
+ if char_wd[c]=0 then if c<>bchar then
+ begin lig_kern[lig_ptr].#:=0; double_check_tail
+@d double_check_ext(#)==begin c:=exten[g].#;
+ if c>0 then if char_wd[c]=0 then
+ begin exten[g].#:=0; double_check_tail
+@d double_check_rep(#)==begin c:=exten[g].#;
+ if char_wd[c]=0 then
+ begin exten[g].#:=0; double_check_tail
+
+@<Doublecheck...@>=
+if nl>0 then for lig_ptr:=0 to nl-1 do
+ if (lig_kern[lig_ptr].b0 div 256)=0 then begin
+ if lig_kern[lig_ptr].b2<kern_flag then begin
+ if lig_kern[lig_ptr].b0<255 then begin
+ double_check_lig(b1)('LIG step'); double_check_lig(b3)('LIG step');
+ end;
+ end
+ else double_check_lig(b1)('KRN step');
+ end;
+@.Unused LIG step...@>
+@.Unused KRN step...@>
+if ne>0 then for g:=0 to ne-1 do begin
+ double_check_ext(b0)('VARCHAR TOP');
+ double_check_ext(b1)('VARCHAR MID');
+ double_check_ext(b2)('VARCHAR BOT');
+ double_check_rep(b3)('VARCHAR REP');
+@.Unused VARCHAR...@>
+ end
+
+@* The TFM output phase.
+Now that we know how to get all of the font data correctly stored in
+\.{VPtoVF}'s memory, it only remains to write the answers out.
+
+First of all, it is convenient to have an abbreviation for output to the
+\.{TFM} file:
+
+@d out(#)==write(tfm_file,#)
+
+@p procedure out_int(@!x:integer);
+begin out_four(out);
+end;
+
+
+@ The general plan for producing \.{TFM} files is long but simple:
+
+@<Do the font metric output@>=
+compute_subfile_sizes;
+output_subfile_sizes;
+@<Output the header block@>;
+output_new_information_ofm;
+output_character_info;
+@<Output the dimensions themselves@>;
+@<Output the ligature/kern program@>;
+@<Output the extensible character recipes@>;
+@<Output the parameters@>
+
+@ A \.{TFM} file begins with 12 numbers that tell how big its subfiles are.
+We already know most of these numbers; for example, the number of distinct
+widths is |memory[width]+1|, where the $+1$ accounts for the zero width that
+is always supposed to be present. But we still should compute the beginning
+and ending character codes (|bc| and |ec|), the number of header words (|lh|),
+and the total number of words in the \.{TFM} file (|lf|).
+
+@<Gl...@>=
+@!bc:char_type; {the smallest character code in the font}
+@!ec:char_type; {the largest character code in the font}
+@!lh:char_type; {the number of words in the header block}
+@!lf:unsigned_integer; {the number of words in the entire \.{TFM} file}
+@!not_found:boolean; {has a font character been found?}
+@!temp_width:fix_word; {width being used to compute a check sum}
+@!ncw,@!nco,@!npc:integer;
+
+@ It might turn out that no characters exist at all. But \.{VPtoVF} keeps
+going and writes the \.{TFM} anyway. In this case |ec| will be~0 and |bc|
+will be~1.
+
+@<Compute the subfile sizes@>=
+case ofm_level of
+ -1: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=255) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=255;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ lf:=6+lh+(ec-bc+1)+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+nl+lk_offset+nk+ne+np;
+ end;
+ 0: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=max_char) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=max_char;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ lf:=14+lh+2*(ec-bc+1)+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+2*nl+lk_offset+nk+2*ne+np;
+ end;
+ 1: begin
+ lh:=header_ptr div 4;@/
+ not_found:=true; bc:=0;
+ while not_found do
+ if (char_wd[bc]>0)or(bc=max_char) then not_found:=false
+ else incr(bc);
+ not_found:=true; ec:=max_char;
+ while not_found do
+ if (char_wd[ec]>0)or(ec=0) then not_found:=false
+ else decr(ec);
+ if bc>ec then bc:=1;
+ incr(memory[width]); incr(memory[height]); incr(memory[depth]);
+ incr(memory[italic]);@/
+ @<Compute the ligature/kern program offset@>;
+ @<Compute the character info size@>;
+ lf:=29+lh+ncw+memory[width]+memory[height]+memory[depth]+
+ memory[italic]+2*(nl+lk_offset)+nk+2*ne+np+
+ nki+nwi+nkf+nwf+nkm+nwm+nkr+nwr+nkg+nwg+nkp+nwp;
+ nco:=29+lh+nki+nwi+nkf+nwf+nkm+nwm+nkr+nwr+nkg+nwg+nkp+nwp;
+ end;
+ end;
+
+@ @d out_size(#)==out((#) div 256); out((#) mod 256)
+ @d out_integer(#)==out((#) div @"1000000);
+ out(((#) mod @"1000000) div @"10000);
+ out(((#) mod @"10000) div @"100);
+ out((#) mod @"100)
+
+@<Output the subfile sizes@>=
+case ofm_level of
+ -1: begin
+ out_size(lf); out_size(lh); out_size(bc); out_size(ec);
+ out_size(memory[width]); out_size(memory[height]);
+ out_size(memory[depth]); out_size(memory[italic]);
+ out_size(nl+lk_offset); out_size(nk); out_size(ne); out_size(np);
+ end;
+ 0: begin
+ out_integer(0);
+ out_integer(lf); out_integer(lh); out_integer(bc); out_integer(ec);
+ out_integer(memory[width]); out_integer(memory[height]);
+ out_integer(memory[depth]); out_integer(memory[italic]);
+ out_integer(nl+lk_offset); out_integer(nk);
+ out_integer(ne); out_integer(np); out_integer(font_dir);
+ end;
+ 1: begin
+ out_integer(1);
+ out_integer(lf); out_integer(lh);
+ out_integer(bc); out_integer(ec);
+ out_integer(memory[width]); out_integer(memory[height]);
+ out_integer(memory[depth]); out_integer(memory[italic]);
+ out_integer(nl+lk_offset); out_integer(nk);
+ out_integer(ne); out_integer(np); out_integer(font_dir);
+ out_integer(nco); out_integer(ncw); out_integer(npc);
+ out_integer(nki); out_integer(nwi); out_integer(nkf); out_integer(nwf);
+ out_integer(nkm); out_integer(nwm); out_integer(nkr); out_integer(nwr);
+ out_integer(nkg); out_integer(nwg); out_integer(nkp); out_integer(nwp);
+ end;
+ end;
+
+@ The routines that follow need a few temporary variables of different types.
+
+@<Gl...@>=
+@!j:0..max_header_bytes; {index into |header_bytes|}
+@!p:pointer; {index into |memory|}
+@!q:width..italic; {runs through the list heads for dimensions}
+@!par_ptr:0..max_param_words; {runs through the parameters}
+
+@ The header block follows the subfile sizes. The necessary information all
+appears in |header_bytes|, except that the design size and the seven-bit-safe
+flag must still be set.
+
+@<Output the header block@>=
+if not check_sum_specified then @<Compute the check sum@>;
+header_bytes[design_size_loc]:=design_size div @'100000000;
+ {this works since |design_size>0|}
+header_bytes[design_size_loc+1]:=(design_size div @'200000) mod 256;
+header_bytes[design_size_loc+2]:=(design_size div 256) mod 256;
+header_bytes[design_size_loc+3]:=design_size mod 256;
+if not seven_unsafe then header_bytes[seven_flag_loc]:=128;
+for j:=0 to header_ptr-1 do out(header_bytes[j]);
+
+@ @<Compute the check sum@>=
+begin c0:=bc; c1:=ec; c2:=bc; c3:=ec;
+for c:=bc to ec do if char_wd[c]>0 then begin
+ temp_width:=memory[char_wd[c]];
+ if design_units<>unity then
+ temp_width:=round((temp_width/design_units)*1048576.0);
+ temp_width:=temp_width + (c+4)*@'20000000; {this should be positive}
+ c0:=(c0+c0+temp_width) mod 255;
+ c1:=(c1+c1+temp_width) mod 253;
+ c2:=(c2+c2+temp_width) mod 251;
+ c3:=(c3+c3+temp_width) mod 247;
+ end;
+header_bytes[check_sum_loc]:=c0;
+header_bytes[check_sum_loc+1]:=c1;
+header_bytes[check_sum_loc+2]:=c2;
+header_bytes[check_sum_loc+3]:=c3;
+end
+
+@ @<Global...@>=
+@!tab:integer;
+
+@
+@<Compute the character info size@>=
+if ofm_level=1 then begin
+ ncw:=0;
+ if nkcp>-1 then
+ npc:=nki+nkf+nkr+nkg+nkcp+1
+ else if nkcg>-1 then
+ npc:=nki+nkf+nkr+nkcg+1
+ else if nkcr>-1 then
+ npc:=nki+nkf+nkcr+1
+ else if nkcf>-1 then
+ npc:=nki+nkcf+1
+ else if nkci>-1 then
+ npc:=nkci+1
+ else
+ npc:=0;
+ needed_space:=(12+npc*2) div 4;
+ extra_bytes:=(needed_space*4) - (10+npc*2);
+ for c:=bc to ec do begin
+ if char_original[c]=c then begin
+ cprime:=c+1;
+ diff:=false;
+ while (not diff) and (cprime<=ec) do begin
+ if index[char_wd[c]]<>index[char_wd[cprime]] then diff:=true;
+ if index[char_ht[c]]<>index[char_ht[cprime]] then diff:=true;
+ if index[char_dp[c]]<>index[char_dp[cprime]] then diff:=true;
+ if index[char_ic[c]]<>index[char_ic[cprime]] then diff:=true;
+ if char_remainder[c]<>char_remainder[cprime] then diff:=true;
+ for tab:=0 to npc-1 do begin
+ if char_table[c,tab]<>char_table[cprime,tab] then diff:=true;
+ end;
+ if not diff then begin
+ char_original[cprime]:=c;
+ cprime:=cprime+1;
+ end;
+ end;
+ if cprime>(c+1) then begin
+ char_repeats[c]:=cprime-c-1;
+ end;
+ ncw:=ncw+needed_space;
+ end;
+ end;
+ end;
+
+@ The next block contains packed |char_info|.
+
+@d out_two(#)==out((#) div 256); out((#) mod 256)
+
+@d out_three(#)==out((#) div 65536); out_two((#) mod 65536)
+
+
+@<Output the character info@>=
+index[0]:=0;
+for c:=bc to ec do
+case ofm_level of
+ -1: begin
+ out(index[char_wd[c]]);
+ out(index[char_ht[c]]*16+index[char_dp[c]]);
+ out(index[char_ic[c]]*4+char_tag[c]);
+ out(char_remainder[c]);
+ end;
+ 0: begin
+ out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256);
+ out(index[char_ht[c]]); out(index[char_dp[c]]);
+ out(index[char_ic[c]] div 64);out((index[char_ic[c]] mod 64)*4+char_tag[c]);
+ out(char_remainder[c] div 256); out(char_remainder[c] mod 256);
+ end;
+ 1: begin
+ if c=char_original[c] then begin
+ out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256);
+ out(index[char_ht[c]]); out(index[char_dp[c]]);
+ out(index[char_ic[c]]);
+ tab:=char_tag[c];
+ if char_extended_tag[c] then begin
+ tab:=5;
+ end;
+ out(tab);
+ out(char_remainder[c] div 256); out(char_remainder[c] mod 256);
+ out_size(char_repeats[c]);
+ for tab:=0 to npc-1 do begin
+ out(char_table[c,tab] div 256); out(char_table[c,tab] mod 256);
+ end;
+ for tab:=1 to extra_bytes do begin
+ out(0);
+ end;
+ end;
+ end;
+ end;
+
+@ When a scaled quantity is output, we may need to divide it by |design_units|.
+The following subroutine takes care of this, using floating point arithmetic
+only if |design_units<>1.0|.
+
+@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|}
+var @!n:byte; {the first byte after the sign}
+@!m:0..65535; {the two least significant bytes}
+begin if abs(x/design_units)>=16.0 then begin
+ print_ln('The relative dimension ',x/@'4000000:1:3,
+ ' is too large.');
+@.The relative dimension...@>
+ print(' (Must be less than 16*designsize');
+ if design_units<>unity then print(' =',design_units/@'200000:1:3,
+ ' designunits');
+ print_ln(')'); x:=0;
+ end;
+if design_units<>unity then x:=round((x/design_units)*1048576.0);
+if x<0 then begin
+ out(255); x:=x+@'100000000;
+ if x<=0 then x:=1;
+ end
+else begin
+ out(0);
+ if x>=@'100000000 then x:=@'77777777;
+ end;
+n:=x div @'200000; m:=x mod @'200000;
+out(n); out(m div 256); out(m mod 256);
+end;
+
+@ We have output the packed indices for individual characters.
+The scaled widths, heights, depths, and italic corrections are next.
+
+@<Output the dimensions themselves@>=
+for q:=width to italic do begin
+ out(0); out(0); out(0); out(0); {output the zero word}
+ p:=link[q]; {head of list}
+ while p>0 do begin
+ out_scaled(memory[p]);
+ p:=link[p];
+ end;
+ end;
+
+@ One embarrassing problem remains: The ligature/kern program might be very
+long, but the starting addresses in |char_remainder| can be at most~65535.
+Therefore we need to output some indirect address information; we want to
+compute |lk_offset| so that addition of |lk_offset| to all remainders makes
+all but |lk_offset| distinct remainders less than~65536.
+
+For this we need a sorted table of all relevant remainders.
+
+@<Glob...@>=
+@!label_table:array[xchar_type] of record
+ @!rr: -1..xmax_label; {sorted label values}
+ @!cc: char_type; {associated characters}
+ end;
+@!label_ptr:xchar_type; {index of highest entry in |label_table|}
+@!sort_ptr:xchar_type; {index into |label_table|}
+@!lk_offset:xchar_type; {smallest offset value that might work}
+@!t:0..xmax_label; {label value that is being redirected}
+@!extra_loc_needed:boolean; {do we need a special word for |bchar|?}
+
+@ @<Compute the ligature/kern program offset@>=
+@<Insert all labels into |label_table|@>;
+if bchar<xmax_char then begin
+ extra_loc_needed:=true; lk_offset:=1;
+ end
+else begin
+ extra_loc_needed:=false; lk_offset:=0;
+ end;
+@<Find the minimum |lk_offset| and adjust all remainders@>;
+if bchar_label<xmax_label then begin
+ lig_kern[nl-1].b2:=(bchar_label+lk_offset)div 65536;
+ lig_kern[nl-1].b3:=(bchar_label+lk_offset)mod 65536;
+ end
+
+@ @<Insert all labels...@>=
+label_ptr:=0; label_table[0].rr:=-1; {sentinel}
+for c:=bc to ec do if char_tag[c]=lig_tag then begin
+ sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|}
+ while label_table[sort_ptr].rr>char_remainder[c] do begin
+ label_table[sort_ptr+1]:=label_table[sort_ptr];
+ decr(sort_ptr); {move the hole}
+ end;
+ label_table[sort_ptr+1].cc:=c;
+ label_table[sort_ptr+1].rr:=char_remainder[c];
+ incr(label_ptr);
+ end
+
+@ @<Find the minimum |lk_offset| and adjust all remainders@>=
+begin sort_ptr:=label_ptr; {the largest unallocated label}
+if ofm_level=-1 then begin
+ if label_table[sort_ptr].rr+lk_offset > 255 then begin
+ lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty}
+ repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin
+ decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ end;
+ incr(lk_offset); decr(sort_ptr);
+ until lk_offset+label_table[sort_ptr].rr<256;
+ {N.B.: |lk_offset=256| satisfies this when |sort_ptr=0|}
+ end;
+ end
+else begin
+ if label_table[sort_ptr].rr+lk_offset > 65535 then begin
+ lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty}
+ repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin
+ decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset;
+ end;
+ incr(lk_offset); decr(sort_ptr);
+ until lk_offset+label_table[sort_ptr].rr<65536;
+ {N.B.: |lk_offset=65536| satisfies this when |sort_ptr=0|}
+ end;
+ end;
+if lk_offset>0 then
+ while sort_ptr>0 do begin
+ char_remainder[label_table[sort_ptr].cc]:=
+ char_remainder[label_table[sort_ptr].cc]+lk_offset;
+ decr(sort_ptr);
+ end;
+end
+
+@ @<Output the ligature/kern program@>=
+if ofm_level=-1 then begin
+ if extra_loc_needed then begin {|lk_offset=1|}
+ out(255); out(bchar); out(0); out(0);
+ end
+ else for sort_ptr:=1 to lk_offset do begin {output the redirection specs}
+ t:=label_table[label_ptr].rr;
+ if bchar<256 then begin
+ out(255); out(bchar);
+ end
+ else begin
+ out(254); out(0);
+ end;
+ out_size(t+lk_offset);
+ repeat decr(label_ptr); until label_table[label_ptr].rr<t;
+ end;
+ if nl>0 then for lig_ptr:=0 to nl-1 do begin
+ out(lig_kern[lig_ptr].b0);
+ out(lig_kern[lig_ptr].b1);
+ out(lig_kern[lig_ptr].b2);
+ out(lig_kern[lig_ptr].b3);
+ end;
+ if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr])
+ end
+else begin
+ if extra_loc_needed then begin {|lk_offset=1|}
+ out_size(255); out_size(bchar); out_size(0); out_size(0);
+ end
+ else for sort_ptr:=1 to lk_offset do begin {output the redirection specs}
+ t:=label_table[label_ptr].rr;
+ if bchar<xmax_char then begin
+ out_size(255); out_size(bchar);
+ end
+ else begin
+ out_size(254); out_size(0);
+ end;
+ out_size((t+lk_offset) div 256);
+ out_size((t+lk_offset) mod 256);
+ repeat decr(label_ptr); until label_table[label_ptr].rr<t;
+ end;
+ if nl>0 then for lig_ptr:=0 to nl-1 do begin
+ out_size(lig_kern[lig_ptr].b0);
+ out_size(lig_kern[lig_ptr].b1);
+ out_size(lig_kern[lig_ptr].b2);
+ out_size(lig_kern[lig_ptr].b3);
+ end;
+ if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr])
+ end
+
+@ @<Output the extensible character recipes@>=
+if ofm_level=-1 then begin
+ if ne>0 then for c:=0 to ne-1 do begin
+ out(exten[c].b0);
+ out(exten[c].b1);
+ out(exten[c].b2);
+ out(exten[c].b3);
+ end;
+ end
+else begin
+ if ne>0 then for c:=0 to ne-1 do begin
+ out_size(exten[c].b0);
+ out_size(exten[c].b1);
+ out_size(exten[c].b2);
+ out_size(exten[c].b3);
+ end;
+ end;
+
+@ For our grand finale, we wind everything up by outputting the parameters.
+
+@<Output the parameters@>=
+for par_ptr:=1 to np do begin
+ if par_ptr=1 then
+ @<Output the slant (|param[1]|) without scaling@>
+ else out_scaled(param[par_ptr]);
+ end
+
+@ @<Output the slant...@>=
+begin if param[1]<0 then begin
+ param[1]:=param[1]+@'10000000000;
+ out((param[1] div @'100000000)+256-64);
+ end
+else out(param[1] div @'100000000);
+out((param[1] div @'200000) mod 256);
+out((param[1] div 256) mod 256);
+out(param[1] mod 256);
+end
+
+@* The VF output phase.
+Output to |vf_file| is considerably simpler.
+
+@d id_byte=202 {current version of \.{VF} format}
+@d vout(#)==write(vf_file,#)
+
+@<Glob...@>=
+@!vcount:integer; {number of bytes written to |vf_file|}
+
+@ We need a routine to output integers as four bytes. Negative values
+will never be less than $-2^{24}$.
+
+@p procedure vout_int(@!x:integer);
+begin if x>=0 then vout(x div @'100000000)
+else begin
+ vout(255); x:=x+@'100000000;
+ end;
+vout((x div @'200000) mod 256);
+vout((x div @'400) mod 256); vout(x mod 256);
+end;
+
+@ @<Do the \.{VF} output@>=
+vout(pre); vout(id_byte); vout(vtitle_length);
+for k:=0 to vtitle_length-1 do vout(vf[vtitle_start+k]);
+for k:=check_sum_loc to design_size_loc+3 do vout(header_bytes[k]);
+vcount:=vtitle_length+11;
+for cur_font:=0 to font_ptr-1 do @<Output a local font definition@>;
+for c:=bc to ec do if char_wd[c]>0 then
+ @<Output a packet for character |c|@>;
+repeat vout(post); incr(vcount);
+until vcount mod 4 = 0
+
+@ @<Output a local font definition@>=
+begin vfout_fntdef(cur_font);@/
+vout(font_checksum[cur_font].b0);
+vout(font_checksum[cur_font].b1);
+vout(font_checksum[cur_font].b2);
+vout(font_checksum[cur_font].b3);
+vout_int(font_at[cur_font]);
+vout_int(font_dsize[cur_font]);
+vout(farea_length[cur_font]);
+vout(fname_length[cur_font]);
+for k:=0 to farea_length[cur_font]-1 do vout(vf[farea_start[cur_font]+k]);
+if fname_start[cur_font]=vf_size then begin
+ vout("N"); vout("U"); vout("L"); vout("L");
+ end
+else for k:=0 to fname_length[cur_font]-1 do vout(vf[fname_start[cur_font]+k]);
+vcount:=vcount+12+farea_length[cur_font]+fname_length[cur_font];
+end
+
+@ @<Output a packet for character |c|@>=
+begin x:=memory[char_wd[c]];
+if design_units<>unity then x:=round((x/design_units)*1048576.0);
+if (packet_length[c]>241)or(x<0)or(x>=@'100000000)or(c<0)or(c>255) then begin
+ vout(242); vout_int(packet_length[c]); vfout_char(c); vout_int(x);
+ vcount:=vcount+13+packet_length[c];
+ end
+else begin
+ vout(packet_length[c]); vout(c); vout(x div @'200000);
+ vout((x div @'400) mod 256); vout(x mod 256);
+ vcount:=vcount+5+packet_length[c];
+ end;
+if packet_start[c]=vf_size then
+ vfout_set(c)
+else for k:=0 to packet_length[c]-1 do vout(vf[packet_start[c]+k]);
+end
+
+@* The main program.
+The routines sketched out so far need to be packaged into separate procedures,
+on some systems, since some \PASCAL\ compilers place a strict limit on the
+size of a routine. The packaging is done here in an attempt to avoid some
+system-dependent changes.
+
+@p procedure param_enter;
+begin @<Enter the parameter names@>;
+end;
+@#
+procedure vpl_enter;
+begin @<Enter all the \.{VPL} names@>;
+end;
+@#
+procedure name_enter; {enter all names and their equivalents}
+begin @<Enter all the \.{PL} names...@>;
+vpl_enter; param_enter;
+end;
+@#
+procedure read_lig_kern;
+var @!krn_ptr:0..max_kerns; {an index into |kern|}
+@!c:byte; {runs through all character codes}
+begin @<Read ligature/kern list@>;
+end;
+@#
+procedure output_new_information_ofm;
+begin @<Output the new information for OFM files@>;
+end;
+@#
+procedure compute_new_header_ofm;
+begin @<Compute the new header information for OFM files@>;
+end;
+@#
+procedure finish_extended_font;
+begin @<Finish up the extended font stuff@>;
+end;
+@#
+procedure output_subfile_sizes;
+begin @<Output the subfile sizes@>;
+end;
+@#
+procedure compute_subfile_sizes;
+begin @<Compute the subfile sizes@>;
+end;
+@#
+procedure output_character_info;
+begin @<Output the character info@>;
+end;
+@#
+@#
+procedure read_font_rule_list;
+begin @<Read font rule list@>;
+end;
+@#
+procedure read_font_glue_list;
+begin @<Read font glue list@>;
+end;
+@#
+procedure read_font_penalty_list;
+begin @<Read font penalty list@>;
+end;
+@#
+procedure read_font_mvalue_list;
+begin @<Read font mvalue list@>;
+end;
+@#
+procedure read_font_fvalue_list;
+begin @<Read font fvalue list@>;
+end;
+@#
+procedure read_font_ivalue_list;
+begin @<Read font ivalue list@>;
+end;
+@#
+procedure read_repeated_character_info;
+begin @<Read repeated character info@>;
+end;
+@#
+procedure read_lig_kern_command;
+begin @<Read a ligature/kern command@>;
+end;
+@#
+procedure read_character_property;
+begin @<Read a character property@>;
+end;
+@#
+procedure read_char_info;
+begin @<Read character info list@>;
+end;
+@#
+procedure read_input;
+var @!c:byte; {header or parameter index}
+begin @<Read all the input@>;
+end;
+@#
+procedure corr_and_check;
+var @!c:xchar_type; {runs through all character codes}
+@!hh:0..hash_size; {an index into |hash_list|}
+@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|}
+@!g:byte; {a character generated by the current character |c|}
+begin @<Correct and check the information@>
+end;
+@#
+procedure vf_output;
+var @!c:char_type; {runs through all character codes}
+@!cur_font:xfont_type; {runs through all local fonts}
+@!k:integer; {loop index}
+begin @<Do the \.{VF} output@>;
+end;
+
+@ Here is where \.{VPtoVF} begins and ends.
+
+@p begin initialize;@/
+name_enter;@/
+read_input; print_ln('.');@/
+corr_and_check;@/
+@<Do the font metric output@>;
+vf_output;
+end.
+
+@ @<Global...@>=
+@!ofm_level:integer;
+
+@ @<Set init...@>=
+ofm_level:=0; {Suppose that it is a level 0 OFM file}
+
+@ @<Read OFM level code@>=
+begin
+ofm_level:=get_integer;
+if (ofm_level<0) or (ofm_level>1) then begin
+ flush_error('OFMLEVEL must be 0 or 1 -- 1 assumed');
+ ofm_level:=1;
+ end;
+end
+
+@ @<Read font direction code@>=
+begin
+font_dir:=-1;
+repeat get_next;
+until cur_char<>" ";
+case cur_char of
+ "T": begin get_next;
+ if cur_char="L" then font_dir:=0
+ else if cur_char="R" then font_dir:=2;
+ end;
+ "B": begin get_next;
+ if cur_char="L" then font_dir:=4
+ else if cur_char="R" then font_dir:=6;
+ end;
+ "R": begin get_next;
+ if cur_char="T" then font_dir:=5
+ else if cur_char="B" then font_dir:=7;
+ end;
+ "L": begin get_next;
+ if cur_char="T" then font_dir:=1
+ else if cur_char="B" then font_dir:=3;
+ end;
+ end;
+while cur_char<>")" do get_next;
+if font_dir = -1 then begin
+ flush_error('FONTDIR must be valid direction, -- TR assumed');
+ font_dir:=0;
+ end;
+end
+
+@ @<Read natural font direction code@>=
+begin
+font_dir:=-1;
+repeat get_next;
+until cur_char<>" ";
+case cur_char of
+ "T": begin get_next;
+ if cur_char="L" then font_dir:=8
+ else if cur_char="R" then font_dir:=10;
+ end;
+ "B": begin get_next;
+ if cur_char="L" then font_dir:=12
+ else if cur_char="R" then font_dir:=14;
+ end;
+ "R": begin get_next;
+ if cur_char="T" then font_dir:=13
+ else if cur_char="B" then font_dir:=15;
+ end;
+ "L": begin get_next;
+ if cur_char="T" then font_dir:=9
+ else if cur_char="B" then font_dir:=11;
+ end;
+ end;
+while cur_char<>")" do get_next;
+if font_dir = -1 then begin
+ flush_error('NFONTDIR must be valid direction, -- TR assumed');
+ font_dir:=8;
+ end;
+end
+
+@
+Here are some general values for the various entries.
+They can all be changed.
+
+@d arrays_per_kind==20
+@d entries_per_array==200
+
+@ @<Constants...@>=
+@!rule_arrays=arrays_per_kind;
+@!rule_entries=entries_per_array;
+
+@ @<Types...@>=
+rule_array_type=0..rule_arrays;
+rule_entry_type=0..rule_entries;
+rule_node=
+record
+ rn_width: fix_word;
+ rn_height: fix_word;
+ rn_depth: fix_word;
+end;
+
+@ @<Global...@>=
+@!rules:array[rule_array_type,rule_entry_type] of rule_node;
+@!npr:array[rule_array_type] of integer;
+@!nkr:integer;
+@!nkcr:integer;
+@!nwr:integer;
+@!r_array:integer;
+@!r_number:integer;
+
+@ @<Set init...@>=
+for r_array := 0 to rule_arrays do begin
+ npr[r_array]:=0;
+ @<Null out the rule@>;
+ end;
+nkr:=-1;
+nkcr:=-1;
+
+@ @<Read font rule list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+r_array:=get_integer;
+if r_array>rule_arrays then
+ flush_error('This FONTRULE table index is too big for my present size')
+else if r_array<0 then
+ flush_error('This FONTRULE index is negative')
+else begin
+ if r_array>nkr then nkr:=r_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a rule@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a rule@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>rule_code then
+ flush_error('This property name doesn''t belong in a RULE list')
+else begin
+ r_number:=get_integer;
+ if r_number>rule_entries then
+ flush_error('This RULE index is too big for my present table size')
+ else if r_number<0 then
+ flush_error('This RULE index is negative')
+ else begin
+ while npr[r_array]<r_number do begin
+ incr(npr[r_array]); @<Null out the rule@>;
+ end;
+ @<Read all of a rule's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the rule@>=
+begin
+rules[r_array,npr[r_array]].rn_width:=0;
+rules[r_array,npr[r_array]].rn_depth:=0;
+rules[r_array,npr[r_array]].rn_height:=0;
+end
+
+@ @<Read all of a rule's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single rule value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single rule value@>=
+begin
+get_name;
+case cur_code of
+ rule_width_code:
+ rules[r_array,r_number].rn_width:=get_fix;
+ rule_height_code:
+ rules[r_array,r_number].rn_height:=get_fix;
+ rule_depth_code:
+ rules[r_array,r_number].rn_depth:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for rules@>=
+begin
+nwr:=0;
+for r_array := 0 to nkr do begin
+ incr(npr[r_array]);
+ nwr := nwr + 3*npr[r_array];
+ end;
+incr(nkr);
+end
+
+@ @<Output the rules@>=
+begin
+for r_array:= 0 to nkr-1 do
+ for r_number:=0 to npr[r_array]-1 do begin
+ out_scaled(rules[r_array,r_number].rn_width);
+ out_scaled(rules[r_array,r_number].rn_height);
+ out_scaled(rules[r_array,r_number].rn_depth);
+ end;
+end
+
+@ @<Output the rule headers@>=
+begin
+for r_array:= 0 to nkr-1 do begin
+ out_integer(npr[r_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!glue_arrays=arrays_per_kind;
+@!glue_entries=entries_per_array;
+
+@
+@d t_normal==0
+@d t_aleaders==1
+@d t_cleaders==2
+@d t_xleaders==3
+
+@d o_unit==0
+@d o_fi==1
+@d o_fil==2
+@d o_fill==3
+@d o_filll==4
+
+@d g_space==0
+@d g_rule==1
+@d g_char==2
+
+@<Types...@>=
+glue_array_type=0..glue_arrays;
+glue_entry_type=0..glue_entries;
+glue_node=
+record
+ gn_width: fix_word;
+ gn_stretch: fix_word;
+ gn_shrink: fix_word;
+ gn_type: integer;
+ gn_arg_type: g_space..g_char;
+ gn_stretch_order: integer;
+ gn_shrink_order: integer;
+ gn_argument: integer;
+end;
+
+@ @<Global...@>=
+@!glues:array[glue_array_type,glue_entry_type] of glue_node;
+@!npg:array[glue_array_type] of integer;
+@!nkg:integer;
+@!nkcg:integer;
+@!nwg:integer;
+@!g_array:integer;
+@!g_byte:integer;
+@!g_number:integer;
+
+@ @<Set init...@>=
+for g_array := 0 to glue_arrays do
+begin
+ npg[g_array]:=0;
+ @<Null out the glue@>;
+end;
+nkg:=-1;
+nkcg:=-1;
+
+@ @<Read font glue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+g_array:=get_integer;
+if g_array>glue_arrays then
+ flush_error('This FONTGLUE table index is too big for my present size')
+else if g_array<0 then
+ flush_error('This FONTGLUE index is negative')
+else begin
+ if g_array>nkg then nkg:=g_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a glue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a glue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>glue_code then
+ flush_error('This property name doesn''t belong in a GLUE list')
+else begin
+ g_number:=get_integer;
+ if g_number>glue_entries then
+ flush_error('This GLUE index is too big for my present table size')
+ else if g_number<0 then
+ flush_error('This GLUE index is negative')
+ else begin
+ while npg[g_array]<g_number do begin
+ incr(npg[g_array]); @<Null out the glue@>;
+ end;
+ @<Read all of a glue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the glue@>=
+begin
+glues[g_array,npg[g_array]].gn_width:=0;
+glues[g_array,npg[g_array]].gn_stretch:=0;
+glues[g_array,npg[g_array]].gn_shrink:=0;
+glues[g_array,npg[g_array]].gn_type:=0;
+glues[g_array,npg[g_array]].gn_arg_type:=0;
+glues[g_array,npg[g_array]].gn_stretch_order:=0;
+glues[g_array,npg[g_array]].gn_shrink_order:=0;
+glues[g_array,npg[g_array]].gn_argument:=0;
+end
+
+@ @<Read all of a glue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single glue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single glue value@>=
+begin
+get_name;
+case cur_code of
+ glue_width_code:
+ glues[g_array,g_number].gn_width:=get_fix;
+ glue_stretch_code:
+ glues[g_array,g_number].gn_stretch:=get_fix;
+ glue_shrink_code:
+ glues[g_array,g_number].gn_shrink:=get_fix;
+ glue_type_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>3) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_type:=g_byte;
+ end;
+ glue_stretch_order_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>4) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_stretch_order:=g_byte;
+ end;
+ glue_shrink_order_code: begin
+ g_byte:=get_integer;
+ if (g_byte<0) or (g_byte>4) then begin
+ g_byte:=0;
+ end;
+ glues[g_array,g_number].gn_shrink_order:=g_byte;
+ end;
+ glue_char_code: begin
+ glues[g_array,g_number].gn_argument:=get_integer;
+ glues[g_array,g_number].gn_arg_type:=g_char;
+ end;
+ glue_rule_code: begin
+ glues[g_array,g_number].gn_argument:=get_integer;
+ glues[g_array,g_number].gn_arg_type:=g_rule;
+ end;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for glues@>=
+begin
+nwg:=0;
+for g_array := 0 to nkg do begin
+ incr(npg[g_array]);
+ nwg := nwg + 4*npg[g_array];
+ end;
+incr(nkg);
+end
+
+@ @<Output the glues@>=
+begin
+for g_array:= 0 to nkg-1 do
+ for g_number:=0 to npg[g_array]-1 do begin
+ g_byte:=glues[g_array,g_number].gn_type*16+
+ glues[g_array,g_number].gn_arg_type;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_stretch_order*16+
+ glues[g_array,g_number].gn_shrink_order;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_argument div 256;
+ out(g_byte);
+ g_byte:=glues[g_array,g_number].gn_argument mod 256;
+ out(g_byte);
+ out_scaled(glues[g_array,g_number].gn_width);
+ out_scaled(glues[g_array,g_number].gn_stretch);
+ out_scaled(glues[g_array,g_number].gn_shrink);
+ end;
+end
+
+@ @<Output the glue headers@>=
+begin
+for g_array:= 0 to nkg-1 do begin
+ out_integer(npg[g_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!penalty_arrays=arrays_per_kind;
+@!penalty_entries=entries_per_array;
+
+@ @<Types...@>=
+penalty_array_type=0..penalty_arrays;
+penalty_entry_type=0..penalty_entries;
+penalty_node=
+record
+ pn_val: integer;
+end;
+
+@ @<Global...@>=
+@!penalties:array[penalty_array_type,penalty_entry_type] of penalty_node;
+@!npp:array[penalty_array_type] of integer;
+@!nkp:integer;
+@!nkcp:integer;
+@!nwp:integer;
+@!p_array:integer;
+@!p_number:integer;
+
+@ @<Set init...@>=
+for p_array := 0 to penalty_arrays do begin
+ npp[p_array]:=0;
+ @<Null out the penalty@>;
+ end;
+nkp:=-1;
+nkcp:=-1;
+
+@ @<Read font penalty list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+p_array:=get_integer;
+if p_array>penalty_arrays then
+ flush_error('This FONTPENALTY table index is too big for my present size')
+else if p_array<0 then
+ flush_error('This FONTPENALTY index is negative')
+else begin
+ if p_array>nkp then nkp:=p_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a penalty@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read a penalty@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>penalty_code then
+ flush_error('This property name doesn''t belong in a PENALTY list')
+else begin
+ p_number:=get_integer;
+ if p_number>penalty_entries then
+ flush_error('This PENALTY index is too big for my present table size')
+ else if p_number<0 then
+ flush_error('This PENALTY index is negative')
+ else begin
+ while npp[p_array]<p_number do begin
+ incr(npp[p_array]); @<Null out the penalty@>;
+ end;
+ @<Read all of a penalty's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the penalty@>=
+begin
+penalties[p_array,npp[p_array]].pn_val:=0;
+end
+
+@ @<Read all of a penalty's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single penalty value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single penalty value@>=
+begin
+get_name;
+case cur_code of
+ penalty_val_code:
+ penalties[p_array,p_number].pn_val:=get_integer;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for penalties@>=
+begin
+nwp:=0;
+for p_array := 0 to nkp do begin
+ incr(npp[p_array]);
+ nwp := nwp + npp[p_array];
+ end;
+incr(nkp);
+end
+
+@ @<Output the penalties@>=
+begin
+for p_array:= 0 to nkp-1 do
+ for p_number:=0 to npp[p_array]-1 do begin
+ out_integer(penalties[p_array,p_number].pn_val);
+ end;
+end
+
+@ @<Output the penalty headers@>=
+begin
+for p_array:= 0 to nkp-1 do begin
+ out_integer(npp[p_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!mvalue_arrays=arrays_per_kind;
+@!mvalue_entries=entries_per_array;
+
+@ @<Types...@>=
+mvalue_array_type=0..mvalue_arrays;
+mvalue_entry_type=0..mvalue_entries;
+mvalue_node=
+record
+ fn_val: fix_word;
+end;
+
+@ @<Global...@>=
+@!mvalues:array[mvalue_array_type,mvalue_entry_type] of mvalue_node;
+@!npm:array[mvalue_array_type] of integer;
+@!nkm:integer;
+@!nkcm:integer;
+@!nwm:integer;
+@!m_array:integer;
+@!m_number:integer;
+
+@ @<Set init...@>=
+for m_array := 0 to mvalue_arrays do begin
+ npm[m_array]:=0;
+ @<Null out the mvalue@>;
+ end;
+nkm:=-1;
+nkcm:=-1;
+
+@ @<Read font mvalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+m_array:=get_integer;
+if m_array>mvalue_arrays then
+ flush_error('This FONTMVALUE table index is too big for my present size')
+else if m_array<0 then
+ flush_error('This FONTMVALUE index is negative')
+else begin
+ if m_array>nkm then nkm:=m_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an mvalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an mvalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>mvalue_code then
+ flush_error('This property name doesn''t belong in an MVALUE list')
+else begin
+ m_number:=get_integer;
+ if m_number>mvalue_entries then
+ flush_error('This MVALUE index is too big for my present table size')
+ else if m_number<0 then
+ flush_error('This MVALUE index is negative')
+ else begin
+ while npm[m_array]<m_number do begin
+ incr(npm[m_array]); @<Null out the mvalue@>;
+ end;
+ @<Read all of an mvalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the mvalue@>=
+begin
+mvalues[m_array,npm[m_array]].fn_val:=0;
+end
+
+@ @<Read all of an mvalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single mvalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single mvalue value@>=
+begin
+get_name;
+case cur_code of
+ mvalue_val_code:
+ mvalues[m_array,m_number].fn_val:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for mvalues@>=
+begin
+nwm:=0;
+for m_array := 0 to nkm do begin
+ incr(npm[m_array]);
+ nwm := nwm + npm[m_array];
+ end;
+incr(nkm);
+end
+
+@ @<Output the mvalues@>=
+begin
+for m_array:= 0 to nkm-1 do
+ for m_number:=0 to npm[m_array]-1 do begin
+ out_scaled(mvalues[m_array,m_number].fn_val);
+ end;
+end
+
+@ @<Output the mvalue headers@>=
+begin
+for m_array:= 0 to nkm-1 do begin
+ out_integer(npm[m_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!fvalue_arrays=arrays_per_kind;
+@!fvalue_entries=entries_per_array;
+
+@ @<Types...@>=
+fvalue_array_type=0..fvalue_arrays;
+fvalue_entry_type=0..fvalue_entries;
+fvalue_node=
+record
+ fn_val: fix_word;
+end;
+
+@ @<Global...@>=
+@!fvalues:array[fvalue_array_type,fvalue_entry_type] of fvalue_node;
+@!npf:array[fvalue_array_type] of integer;
+@!nkf:integer;
+@!nkcf:integer;
+@!nwf:integer;
+@!f_array:integer;
+@!f_number:integer;
+
+@ @<Set init...@>=
+for f_array := 0 to fvalue_arrays do begin
+ npf[f_array]:=0;
+ @<Null out the fvalue@>;
+ end;
+nkf:=-1;
+nkcf:=-1;
+
+@ @<Read font fvalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+f_array:=get_integer;
+if f_array>fvalue_arrays then
+ flush_error('This FONTFVALUE table index is too big for my present size')
+else if f_array<0 then
+ flush_error('This FONTFVALUE index is negative')
+else begin
+ if f_array>nkf then nkf:=f_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an fvalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an fvalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>fvalue_code then
+ flush_error('This property name doesn''t belong in an FVALUE list')
+else begin
+ f_number:=get_integer;
+ if f_number>fvalue_entries then
+ flush_error('This FVALUE index is too big for my present table size')
+ else if f_number<0 then
+ flush_error('This FVALUE index is negative')
+ else begin
+ while npf[f_array]<f_number do begin
+ incr(npf[f_array]); @<Null out the fvalue@>;
+ end;
+ @<Read all of an fvalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the fvalue@>=
+begin
+fvalues[f_array,npf[f_array]].fn_val:=0;
+end
+
+@ @<Read all of an fvalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single fvalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single fvalue value@>=
+begin
+get_name;
+case cur_code of
+ fvalue_val_code:
+ fvalues[f_array,f_number].fn_val:=get_fix;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for fvalues@>=
+begin
+nwf:=0;
+for f_array := 0 to nkf do begin
+ incr(npf[f_array]);
+ nwf := nwf + npf[f_array];
+ end;
+incr(nkf);
+end
+
+@ @<Output the fvalues@>=
+begin
+for f_array:= 0 to nkf-1 do
+ for f_number:=0 to npf[f_array]-1 do begin
+ out_scaled(fvalues[f_array,f_number].fn_val);
+ end;
+end
+
+@ @<Output the fvalue headers@>=
+begin
+for f_array:= 0 to nkf-1 do begin
+ out_integer(npf[f_array]);
+ end;
+end
+
+@ @<Constants...@>=
+@!ivalue_arrays=arrays_per_kind;
+@!ivalue_entries=entries_per_array;
+
+@ @<Types...@>=
+ivalue_array_type=0..ivalue_arrays;
+ivalue_entry_type=0..ivalue_entries;
+ivalue_node=
+record
+ in_val: integer;
+end;
+
+@ @<Global...@>=
+@!ivalues:array[ivalue_array_type,ivalue_entry_type] of ivalue_node;
+@!npi:array[ivalue_array_type] of integer;
+@!font_i_array:boolean;
+@!nki:integer;
+@!nkci:integer;
+@!nwi:integer;
+@!i_array:integer;
+@!i_number:integer;
+
+@ @<Set init...@>=
+for i_array := 0 to ivalue_arrays do begin
+ npi[i_array]:=0;
+ @<Null out the ivalue@>;
+ end;
+nki:=-1;
+nkci:=-1;
+
+@ @<Read font ivalue list@>=
+begin
+if tables_read then
+ flush_error('All parameter tables must appear before character info');
+i_array:=get_integer;
+if i_array>ivalue_arrays then
+ flush_error('This FONTIVALUE table index is too big for my present size')
+else if i_array<0 then
+ flush_error('This FONTIVALUE index is negative')
+else begin
+ if i_array>nki then nki:=i_array;
+ while level=1 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read an ivalue@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+ finish_inner_property_list;
+ end;
+end
+
+@ @<Read an ivalue@>=
+begin
+get_name;
+if cur_code=comment_code then skip_to_end_of_item
+else if cur_code<>ivalue_code then
+ flush_error('This property name doesn''t belong in an IVALUE list')
+else begin
+ i_number:=get_integer;
+ if i_number>ivalue_entries then
+ flush_error('This IVALUE index is too big for my present table size')
+ else if i_number<0 then
+ flush_error('This IVALUE index is negative')
+ else begin
+ while npi[i_array]<i_number do begin
+ incr(npi[i_array]); @<Null out the ivalue@>;
+ end;
+ @<Read all of an ivalue's values@>;
+ finish_the_property;
+ end;
+ end;
+end
+
+@ @<Null out the ivalue@>=
+begin
+ivalues[i_array,npi[i_array]].in_val:=0;
+end
+
+@ @<Read all of an ivalue's values@>=
+begin
+while level=2 do begin
+ while cur_char=" " do get_next;
+ if cur_char="(" then @<Read a single ivalue value@>
+ else if cur_char=")" then skip_to_end_of_item
+ else junk_error;
+ end;
+finish_inner_property_list;
+end
+
+@ @<Read a single ivalue value@>=
+begin
+get_name;
+case cur_code of
+ ivalue_val_code:
+ ivalues[i_array,i_number].in_val:=get_integer;
+ end;
+finish_the_property;
+end
+
+@ @<Header information for ivalues@>=
+begin
+nwi:=0;
+for i_array := 0 to nki do begin
+ incr(npi[i_array]);
+ nwi := nwi + npi[i_array];
+ end;
+incr(nki);
+end
+
+@ @<Output the ivalues@>=
+begin
+for i_array:= 0 to nki-1 do
+ for i_number:=0 to npi[i_array]-1 do begin
+ out_integer(ivalues[i_array,i_number].in_val);
+ end;
+end
+
+@ @<Output the ivalue headers@>=
+begin
+for i_array:= 0 to nki-1 do begin
+ out_integer(npi[i_array]);
+ end;
+end
+
+@ @<Compute the new header information for OFM files@>=
+begin
+@<Header information for ivalues@>;
+@<Header information for fvalues@>;
+@<Header information for mvalues@>;
+@<Header information for rules@>;
+@<Header information for glues@>;
+@<Header information for penalties@>;
+end
+
+@ @<Output the new information for OFM files@>=
+begin
+@<Output the ivalue headers@>;
+@<Output the fvalue headers@>;
+@<Output the mvalue headers@>;
+@<Output the rule headers@>;
+@<Output the glue headers@>;
+@<Output the penalty headers@>;
+@<Output the ivalues@>;
+@<Output the fvalues@>;
+@<Output the rules@>;
+@<Output the glues@>;
+@<Output the penalties@>;
+end
+
+@* System-dependent changes.
+This section should be replaced, if necessary, by changes to the program
+that are necessary to make \.{VPtoVF} work at a particular installation.
+It is usually best to design your change file so that all changes to
+previous sections preserve the section numbering; then everybody's version
+will be consistent with the printed program. More extensive changes,
+which introduce new sections, can be inserted here; then only the index
+itself will get a new section number.
+@^system dependencies@>
+
+@* Index.
+Pointers to error messages appear here together with the section numbers
+where each ident\-i\-fier is used.