diff options
author | Karl Berry <karl@freefriends.org> | 2006-01-17 21:41:51 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2006-01-17 21:41:51 +0000 |
commit | 487ca4806cc046076293cf6cc5fbba0db282bac7 (patch) | |
tree | 847b412ab5158dd7bdd7ed7e5a4cc3fbca94be32 /Build/source/texk/web2c/omegaware | |
parent | a3d3111bfe26b8e5f5bc6049dfb2a4ca2edc7881 (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/ChangeLog | 0 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/odvicopy.ch | 710 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/odvicopy.web | 4688 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/odvitype.ch | 767 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/odvitype.web | 2594 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ofm2opl.ch | 461 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ofm2opl.web | 2322 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/opl2ofm.ch | 337 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/opl2ofm.web | 4363 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/otangle.ch | 474 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/otangle.web | 3328 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ovf2ovp.ch | 610 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ovf2ovp.web | 3138 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ovp2ovf.ch | 320 | ||||
-rw-r--r-- | Build/source/texk/web2c/omegaware/ovp2ovf.web | 5071 |
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. |