modernc.org/knuth@v0.0.4/web/testdata/ctan.org/tex-archive/systems/knuth/dist/etc/vptovf.web (about) 1 % This program by D. E. Knuth is not copyrighted and can be used freely. 2 % Version 1 was implemented in December 1989. 3 % Version 1.1 fixed some for-loop indices for stricter Pascal (April 1990). 4 % Version 1.2 fixed `nonexistent char 0' bug, and a bit more (September 1990). 5 % Version 1.3 has more robust `out_scaled' (March 1991). 6 % Version 1.4 (March 1995) initialized lk_step_ended (Armin K\"ollner). 7 % Version 1.5 (August 1998) corrected vf_fix(0) (Wayne Sullivan). 8 % Version 1.6 (January 2014) corrected possible end-of-line glitch (Ken Nakano), 9 % and get_fix now treats -- as + (Peter Breitenlohner). 10 11 % Here is TeX material that gets inserted after \input webmac 12 \def\hang{\hangindent 3em\indent\ignorespaces} 13 \font\ninerm=cmr9 14 \let\mc=\ninerm % medium caps for names like SAIL 15 \def\PASCAL{Pascal} 16 \font\logo=logo10 % for the METAFONT logo 17 \def\MF{{\logo METAFONT}} 18 19 \def\(#1){} % this is used to make section names sort themselves better 20 \def\9#1{} % this is used for sort keys in the index 21 22 \def\title{VP\lowercase{to}VF} 23 \def\contentspagenumber{201} 24 \def\topofcontents{\null 25 \titlefalse % include headline on the contents page 26 \def\rheader{\mainfont\hfil \contentspagenumber} 27 \vfill 28 \centerline{\titlefont The {\ttitlefont VPtoVF} processor} 29 \vskip 15pt 30 \centerline{(Version 1.6, January 2014)} 31 \vfill} 32 \def\botofcontents{\vfill 33 \centerline{\hsize 5in\baselineskip9pt 34 \vbox{\ninerm\noindent 35 The preparation of this program 36 was supported in part by the National Science 37 Foundation and by the System Development Foundation. `\TeX' is a 38 trademark of the American Mathematical Society.}}} 39 \pageno=\contentspagenumber \advance\pageno by 1 40 41 @* Introduction. 42 The \.{VPtoVF} utility program converts virtual-property-list (``\.{VPL}'') 43 files into an equivalent pair of files called a virtual font (``\.{VF}'') file 44 and a \TeX\ font metric (``\.{TFM}'') file. It also makes a thorough check 45 of the given \.{VPL} file, so that the \.{VF} file should be acceptable to 46 device drivers and the \.{TFM} file should be acceptable to \TeX. 47 48 \indent\.{VPtoVF} is an extended version of the program \.{PLtoTF}, which 49 is part of the standard \TeX ware library. 50 The idea of a virtual font was inspired by the work of David R. Fuchs 51 @^Fuchs, David Raymond@> 52 who designed a similar set of conventions in 1984 while developing a 53 device driver for ArborText, Inc. He wrote a somewhat similar program 54 called \.{PLFONT}. 55 56 The |banner| string defined here should be changed whenever \.{VPtoVF} 57 gets modified. 58 59 @d banner=='This is VPtoVF, Version 1.6' {printed when the program starts} 60 61 @ This program is written entirely in standard \PASCAL, except that 62 it has to do some slightly system-dependent character code conversion 63 on input. Furthermore, lower case letters are used in error messages; 64 they could be converted to upper case if necessary. The input is read 65 from |vpl_file|, and the output is written on |vf_file| and |tfm_file|; 66 error messages and 67 other remarks are written on the |output| file, which the user may 68 choose to assign to the terminal if the system permits it. 69 @^system dependencies@> 70 71 The term |print| is used instead of |write| when this program writes on 72 the |output| file, so that all such output can be easily deflected. 73 74 @d print(#)==write(#) 75 @d print_ln(#)==write_ln(#) 76 77 @p program VPtoVF(@!vpl_file,@!vf_file,@!tfm_file,@!output); 78 const @<Constants in the outer block@>@/ 79 type @<Types in the outer block@>@/ 80 var @<Globals in the outer block@>@/ 81 procedure initialize; {this procedure gets things started properly} 82 var @<Local variables for initialization@>@/ 83 begin print_ln(banner);@/ 84 @<Set initial values@>@/ 85 end; 86 87 @ The following parameters can be changed at compile time to extend or 88 reduce \.{VPtoVF}'s capacity. 89 90 @<Constants...@>= 91 @!buf_size=60; {length of lines displayed in error messages} 92 @!max_header_bytes=100; {four times the maximum number of words allowed in 93 the \.{TFM} file header block, must be 1024 or less} 94 @!vf_size=10000; {maximum length of |vf| data, in bytes} 95 @!max_stack=100; {maximum depth of simulated \.{DVI} stack} 96 @!max_param_words=30; {the maximum number of \.{fontdimen} parameters allowed} 97 @!max_lig_steps=5000; 98 {maximum length of ligature program, must be at most $32767-257=32510$} 99 @!max_kerns=500; {the maximum number of distinct kern values} 100 @!hash_size=5003; {preferably a prime number, a bit larger than the number 101 of character pairs in lig/kern steps} 102 103 @ Here are some macros for common programming idioms. 104 105 @d incr(#) == #:=#+1 {increase a variable by unity} 106 @d decr(#) == #:=#-1 {decrease a variable by unity} 107 @d do_nothing == {empty statement} 108 109 @* Property list description of font metric data. 110 The idea behind \.{VPL} files is that precise details about fonts, i.e., the 111 facts that are needed by typesetting routines like \TeX, sometimes have to 112 be supplied by hand. The nested property-list format provides a reasonably 113 convenient way to do this. 114 115 A good deal of computation is necessary to parse and process a 116 \.{VPL} file, so it would be inappropriate for \TeX\ itself to do this 117 every time it loads a font. \TeX\ deals only with the compact descriptions 118 of font metric data that appear in \.{TFM} files. Such data is so compact, 119 however, it is almost impossible for anybody but a computer to read it. 120 121 Device drivers also need a compact way to describe mappings from \TeX's idea 122 of a font to the actual characters a device can produce. They can do this 123 conveniently when given a packed sequence of bytes called a \.{VF} file. 124 125 The purpose of \.{VPtoVF} is to convert from a human-oriented file of text 126 to computer-oriented files of binary numbers. There's a companion program, 127 \.{VFtoVP}, which goes the other way. 128 129 @<Glob...@>= 130 @!vpl_file:text; 131 132 @ @<Set init...@>= 133 reset(vpl_file); 134 135 @ A \.{VPL} file is like a \.{PL} file with a few extra features, so we 136 can begin to define it by reviewing the definition of \.{PL} files. The 137 material in the next few sections is copied from the program \.{PLtoTF}. 138 139 A \.{PL} file is a list of entries of the form 140 $$\.{(PROPERTYNAME VALUE)}$$ 141 where the property name is one of a finite set of names understood by 142 this program, and the value may itself in turn be a property list. 143 The idea is best understood by looking at an example, so let's consider 144 a fragment of the \.{PL} file for a hypothetical font. 145 $$\vbox{\halign{\.{#}\hfil\cr 146 (FAMILY NOVA)\cr 147 (FACE F MIE)\cr 148 (CODINGSCHEME ASCII)\cr 149 (DESIGNSIZE D 10)\cr 150 (DESIGNUNITS D 18)\cr 151 (COMMENT A COMMENT IS IGNORED)\cr 152 (COMMENT (EXCEPT THIS ONE ISN'T))\cr 153 (COMMENT (ACTUALLY IT IS, EVEN THOUGH\cr 154 \qquad\qquad IT SAYS IT ISN'T))\cr 155 (FONTDIMEN\cr 156 \qquad (SLANT R -.25)\cr 157 \qquad (SPACE D 6)\cr 158 \qquad (SHRINK D 2)\cr 159 \qquad (STRETCH D 3)\cr 160 \qquad (XHEIGHT R 10.55)\cr 161 \qquad (QUAD D 18)\cr 162 \qquad )\cr 163 (LIGTABLE\cr 164 \qquad (LABEL C f)\cr 165 \qquad (LIG C f O 200)\cr 166 \qquad (SKIP D 1)\cr 167 \qquad (LABEL O 200)\cr 168 \qquad (LIG C i O 201)\cr 169 \qquad (KRN O 51 R 1.5)\cr 170 \qquad (/LIG C ? C f)\cr 171 \qquad (STOP)\cr 172 \qquad )\cr 173 (CHARACTER C f\cr 174 \qquad (CHARWD D 6)\cr 175 \qquad (CHARHT R 13.5)\cr 176 \qquad (CHARIC R 1.5)\cr 177 \qquad )\cr}}$$ 178 This example says that the font whose metric information is being described 179 belongs to the hypothetical 180 \.{NOVA} family; its face code is medium italic extended; 181 and the characters appear in ASCII code positions. The design size is 10 points, 182 and all other sizes in this \.{PL} file are given in units such that 18 units 183 equals the design size. The font is slanted with a slope of $-.25$ (hence the 184 letters actually slant backward---perhaps that is why the family name is 185 \.{NOVA}). The normal space between words is 6 units (i.e., one third of 186 the 18-unit design size), with glue that shrinks by 2 units or stretches by 3. 187 The letters for which accents don't need to be raised or lowered are 10.55 188 units high, and one em equals 18 units. 189 190 The example ligature table is a bit trickier. It specifies that the 191 letter \.f followed by another \.f is changed to code @'200, while 192 code @'200 followed by \.i is changed to @'201; presumably codes @'200 193 and @'201 represent the ligatures `ff' and `ffi'. Moreover, in both cases 194 \.f and @'200, if the following character is the code @'51 (which is a 195 right parenthesis), an additional 1.5 units of space should be inserted 196 before the @'51. (The `\.{SKIP}~\.D~\.1' skips over one \.{LIG} or 197 \.{KRN} command, which in this case is the second \.{LIG}; in this way 198 two different ligature/kern programs can come together.) 199 Finally, if either \.f or @'200 is followed by a question mark, 200 the question mark is replaced by \.f and the ligature program is 201 started over. (Thus, the character pair `\.{f?}' would actually become 202 the ligature `ff', and `\.{ff?}' or `\.{f?f}' would become `fff'. To 203 avoid this restart procedure, the \.{/LIG} command could be replaced 204 by \.{/LIG>}; then `\.{f?}' would become `f\kern0ptf' and `\.{f?f}' 205 would become `f\kern0ptff'.) 206 207 Character \.f itself is 6 units wide and 13.5 units tall, in this example. 208 Its depth is zero (since \.{CHARDP} is not given), and its italic correction 209 is 1.5 units. 210 211 @ The example above illustrates most of the features found in \.{PL} files. 212 Note that some property names, like \.{FAMILY} or \.{COMMENT}, take a 213 string as their value; this string continues until the first unmatched 214 right parenthesis. But most property names, like \.{DESIGNSIZE} and \.{SLANT} 215 and \.{LABEL}, take a number as their value. This number can be expressed in 216 a variety of ways, indicated by a prefixed code; \.D stands for decimal, 217 \.H for hexadecimal, \.O for octal, \.R for real, \.C for character, and 218 \.F for ``face.'' Other property names, like \.{LIG}, take two numbers as 219 their value. And still other names, like \.{FONTDIMEN} and \.{LIGTABLE} and 220 \.{CHARACTER}, have more complicated values that involve property lists. 221 222 A property name is supposed to be used only in an appropriate property 223 list. For example, \.{CHARWD} shouldn't occur on the outer level or 224 within \.{FONTDIMEN}. 225 226 The individual property-and-value pairs in a property list can appear in 227 any order. For instance, `\.{SHRINK}' precedes `\.{STRETCH}' in the example 228 above, although the \.{TFM} file always puts the stretch parameter first. 229 One could even give the information about characters like `\.f' before 230 specifying the number of units in the design size, or before specifying the 231 ligature and kerning table. However, the \.{LIGTABLE} itself is an exception 232 to this rule; the individual elements of the \.{LIGTABLE} property list 233 can be reordered only to a certain extent without changing the meaning 234 of that table. 235 236 If property-and-value pairs are omitted, a default value is used. For example, 237 we have already noted that the default for \.{CHARDP} is zero. The default 238 for {\sl every\/} numeric value is, in fact, zero, unless otherwise stated 239 below. 240 241 If the same property name is used more than once, \.{VPtoVF} will not notice 242 the discrepancy; it simply uses the final value given. Once again, however, the 243 \.{LIGTABLE} is an exception to this rule; \.{VPtoVF} will complain if there 244 is more than one label for some character. And of course many of the 245 entries in the \.{LIGTABLE} property list have the same property name. 246 247 @ A \.{VPL} file also includes information about how to create each character, 248 by typesetting characters from other fonts and/or by drawing lines, etc. 249 Such information is the value of the `\.{MAP}' property, which can be 250 illustrated as follows: 251 $$\vbox{\halign{\.{#}\hfil\cr 252 (MAPFONT D 0 (FONTNAME Times-Roman))\cr 253 (MAPFONT D 1 (FONTNAME Symbol))\cr 254 (MAPFONT D 2 (FONTNAME cmr10)(FONTAT D 20))\cr 255 (CHARACTER O 0 (MAP (SELECTFONT D 1)(SETCHAR C G)))\cr 256 (CHARACTER O 76 (MAP (SETCHAR O 277)))\cr 257 (CHARACTER D 197 (MAP\cr 258 \qquad(PUSH)(SETCHAR C A)(POP)\cr 259 \qquad(MOVEUP R 0.937)(MOVERIGHT R 1.5)(SETCHAR O 312)))\cr 260 (CHARACTER O 200 (MAP (MOVEDOWN R 2.1)(SETRULE R 1 R 8)))\cr 261 (CHARACTER O 201 (MAP\cr 262 \qquad (SPECIAL ps: /SaveGray currentgray def .5 setgray)\cr 263 \qquad (SELECTFONT D 2)(SETCHAR C A)\cr 264 \qquad (SPECIAL ps: SaveGray setgray)))\cr 265 }}$$ 266 (These specifications appear in addition to the conventional \.{PL} 267 information. The \.{MAP} attribute can be mixed in with other attributes 268 like \.{CHARWD} or it can be given separately.) 269 270 In this example, the virtual font is composed of characters that can be 271 fabricated from three actual fonts, `\.{Times-Roman}', 272 `\.{Symbol}', and `\.{cmr10} \.{at} \.{20\\u}' (where \.{\\u} 273 is the unit size in this \.{VPL} file). Character |@'0| is typeset as 274 a `G' from the symbol font. Character |@'76| is typeset as character |@'277| 275 from the ordinary Times font. (If no other font is selected, font 276 number~0 is the default. If no \.{MAP} attribute is given, the default map 277 is a character of the same number in the default font.) 278 279 Character 197 (decimal) is more interesting: First an A is typeset (in the 280 default font Times), and this is enclosed by \.{PUSH} and \.{POP} so that 281 the original position is restored. Then the accent character |@'312| is 282 typeset, after moving up .937 units and right 1.5 units. 283 284 To typeset character |@'200| in this virtual font, we move down 2.1 units, 285 then typeset a rule that is 1 unit high and 8 units wide. 286 287 Finally, to typeset character |@'201|, we do something that requires a 288 special ability to interpret PostScript commands; this example 289 sets the PostScript ``color'' to 50\char`\%\ gray and typesets an `A' 290 from \.{cmr10} \.{at} \.{20\\u} in that color. 291 292 In general, the \.{MAP} attribute of a virtual character can be any sequence 293 of typesetting commands that might appear in a page of a \.{DVI} file. 294 A single character might map into an entire page. 295 296 @ But instead of relying on a hypothetical example, let's consider a complete 297 grammar for \.{VPL} files, beginning with the (unchanged) grammatical rules 298 for \.{PL} files. At the outer level, the following property names 299 are valid in any \.{PL} file: 300 301 \yskip\hang\.{CHECKSUM} (four-byte value). The value, which should be a 302 nonnegative integer less than $2^{32}$, is used to identify a particular 303 version of a font; it should match the check sum value stored with the font 304 itself. An explicit check sum of zero is used to bypass 305 check sum testing. If no checksum is specified in the \.{VPL} file, 306 \.{VPtoVF} will compute the checksum that \MF\ would compute from the 307 same data. 308 309 \yskip\hang\.{DESIGNSIZE} (numeric value, default is 10). The value, which 310 should be a real number in the range |1.0<=x<2048|, represents the default 311 amount by which all quantities will be scaled if the font is not loaded 312 with an `\.{at}' specification. For example, if one says 313 `\.{\\font\\A=cmr10 at 15pt}' in \TeX\ language, the design size in the \.{TFM} 314 file is ignored and effectively replaced by 15 points; but if one simply 315 says `\.{\\font\\A=cmr10}' the stated design size is used. This quantity is 316 always in units of printer's points. 317 318 \yskip\hang\.{DESIGNUNITS} (numeric value, default is 1). The value 319 should be a positive real number; it says how many units equals the design 320 size (or the eventual `\.{at}' size, if the font is being scaled). For 321 example, suppose you have a font that has been digitized with 600 pixels per 322 em, and the design size is one em; then you could say `\.{(DESIGNUNITS R 600)}' 323 if you wanted to give all of your measurements in units of pixels. 324 325 \yskip\hang\.{CODINGSCHEME} (string value, default is `\.{UNSPECIFIED}'). 326 The string should not contain parentheses, and its length must be less than 40. 327 It identifies the correspondence between the numeric codes and font characters. 328 (\TeX\ ignores this information, but other software programs make use of it.) 329 330 \yskip\hang\.{FAMILY} (string value, default is `\.{UNSPECIFIED}'). 331 The string should not contain parentheses, and its length must be less than 20. 332 It identifies the name of the family to which this font belongs, e.g., 333 `\.{HELVETICA}'. (\TeX\ ignores this information; but it is needed, for 334 example, when converting \.{DVI} files to \.{PRESS} files for Xerox 335 equipment.) 336 337 \yskip\hang\.{FACE} (one-byte value). This number, which must lie between 338 0 and 255 inclusive, is a subsidiary ident\-ifi\-ca\-tion of the font within its 339 family. For example, bold italic condensed fonts might have the same family name 340 as light roman extended fonts, differing only in their face byte. (\TeX\ 341 ignores this information; but it is needed, for example, when converting 342 \.{DVI} files to \.{PRESS} files for Xerox equipment.) 343 344 \yskip\hang\.{SEVENBITSAFEFLAG} (string value, default is `\.{FALSE}'). The 345 value should start with either `\.T' (true) or `\.F' (false). If true, character 346 codes less than 128 cannot lead to codes of 128 or more via ligatures or 347 charlists or extensible characters. (\TeX82 ignores this flag, but older 348 versions of \TeX\ would only accept \.{TFM} files that were seven-bit safe.) 349 \.{VPtoVF} computes the correct value of this flag and gives an error message 350 only if a claimed ``true'' value is incorrect. 351 352 \yskip\hang\.{HEADER} (a one-byte value followed by a four-byte value). 353 The one-byte value should be between 18 and a maximum limit that can be 354 raised or lowered depending on the compile-time setting of |max_header_bytes|. 355 The four-byte value goes into the header word whose index is the one-byte 356 value; for example, to set |header[18]:=1|, one may write 357 `\.{(HEADER D 18 O 1)}'. This notation is used for header information that 358 is presently unnamed. (\TeX\ ignores it.) 359 360 \yskip\hang\.{FONTDIMEN} (property list value). See below for the names 361 allowed in this property list. 362 363 \yskip\hang\.{LIGTABLE} (property list value). See below for the rules 364 about this special kind of property list. 365 366 \yskip\hang\.{BOUNDARYCHAR} (one-byte value). If this character appears in 367 a \.{LIGTABLE} command, it matches ``end of word'' as well as itself. 368 If no boundary character is given and no \.{LABEL} \.{BOUNDARYCHAR} occurs 369 within \.{LIGTABLE}, word boundaries will not affect ligatures or kerning. 370 371 \yskip\hang\.{CHARACTER}. The value is a one-byte integer followed by 372 a property list. The integer represents the number of a character that is 373 present in the font; the property list of a character is defined below. 374 The default is an empty property list. 375 376 @ Numeric property list values can be given in various forms identified by 377 a prefixed letter. 378 379 \yskip\hang\.C denotes an ASCII character, which should be a standard visible 380 character that is not a parenthesis. The numeric value will therefore be 381 between @'41 and @'176 but not @'50 or @'51. 382 383 \yskip\hang\.D denotes an unsigned decimal integer, which must be 384 less than $2^{32}$, i.e., at most `\.{D 4294967295}'. 385 386 \yskip\hang\.F denotes a three-letter Xerox face code; the admissible codes 387 are \.{MRR}, \.{MIR}, \.{BRR}, \.{BIR}, \.{LRR}, \.{LIR}, \.{MRC}, \.{MIC}, 388 \.{BRC}, \.{BIC}, \.{LRC}, \.{LIC}, \.{MRE}, \.{MIE}, \.{BRE}, \.{BIE}, 389 \.{LRE}, and \.{LIE}, denoting the integers 0 to 17, respectively. 390 391 \yskip\hang\.O denotes an unsigned octal integer, which must be less than 392 $2^{32}$, i.e., at most `\.{O 37777777777}'. 393 394 \yskip\hang\.H denotes an unsigned hexadecimal integer, which must be less than 395 $2^{32}$, i.e., at most `\.{H FFFFFFFF}'. 396 397 \yskip\hang\.R denotes a real number in decimal notation, optionally preceded 398 by a `\.+' or `\.-' sign, and optionally including a decimal point. The 399 absolute value must be less than 2048. 400 401 @ The property names allowed in a \.{FONTDIMEN} property list correspond to 402 various \TeX\ parameters, each of which has a (real) numeric value. All 403 of the parameters except \.{SLANT} are in design units. The admissible 404 names are \.{SLANT}, \.{SPACE}, \.{STRETCH}, \.{SHRINK}, \.{XHEIGHT}, 405 \.{QUAD}, \.{EXTRASPACE}, \.{NUM1}, \.{NUM2}, \.{NUM3}, \.{DENOM1}, 406 \.{DENOM2}, \.{SUP1}, \.{SUP2}, \.{SUP3}, \.{SUB1}, \.{SUB2}, \.{SUPDROP}, 407 \.{SUBDROP}, \.{DELIM1}, \.{DELIM2}, and \.{AXISHEIGHT}, for parameters 408 1~to~22. The alternate names \.{DEFAULTRULETHICKNESS}, 409 \.{BIGOPSPACING1}, \.{BIGOPSPACING2}, \.{BIGOPSPACING3}, 410 \.{BIGOPSPACING4}, and \.{BIGOPSPACING5}, may also be used for parameters 411 8 to 13. 412 413 The notation `\.{PARAMETER} $n$' provides another way to specify the 414 $n$th parameter; for example, `\.{(PARAMETER} \.{D 1 R -.25)}' is another way 415 to specify that the \.{SLANT} is $-0.25$. The value of $n$ must be positive 416 and less than |max_param_words|. 417 418 @ The elements of a \.{CHARACTER} property list can be of six different types. 419 420 \yskip\hang\.{CHARWD} (real value) denotes the character's width in 421 design units. 422 423 \yskip\hang\.{CHARHT} (real value) denotes the character's height in 424 design units. 425 426 \yskip\hang\.{CHARDP} (real value) denotes the character's depth in 427 design units. 428 429 \yskip\hang\.{CHARIC} (real value) denotes the character's italic correction in 430 design units. 431 432 \yskip\hang\.{NEXTLARGER} (one-byte value), specifies the character that 433 follows the present one in a ``charlist.'' The value must be the number of a 434 character in the font, and there must be no infinite cycles of supposedly 435 larger and larger characters. 436 437 \yskip\hang\.{VARCHAR} (property list value), specifies an extensible character. 438 This option and \.{NEXTLARGER} are mutually exclusive; i.e., they cannot 439 both be used within the same \.{CHARACTER} list. 440 441 \yskip\noindent 442 The elements of a \.{VARCHAR} property list are either \.{TOP}, \.{MID}, 443 \.{BOT}, or \.{REP}; the values are integers, which must be zero or the number 444 of a character in the font. A zero value for \.{TOP}, \.{MID}, or \.{BOT} means 445 that the corresponding piece of the extensible character is absent. A nonzero 446 value, or a \.{REP} value of zero, denotes the character code used to make 447 up the top, middle, bottom, or replicated piece of an extensible character. 448 449 @ A \.{LIGTABLE} property list contains elements of four kinds, specifying a 450 program in a simple command language that \TeX\ uses for ligatures and kerns. 451 If several \.{LIGTABLE} lists appear, they are effectively concatenated into 452 a single list. 453 454 \yskip\hang\.{LABEL} (one-byte value) means that the program for the 455 stated character value starts here. The integer must be the number of a 456 character in the font; its \.{CHARACTER} property list must not have a 457 \.{NEXTLARGER} or \.{VARCHAR} field. At least one \.{LIG} or \.{KRN} step 458 must follow. 459 460 \yskip\hang\.{LABEL} \.{BOUNDARYCHAR} means that the program for 461 beginning-of-word ligatures starts here. 462 463 \yskip\hang\.{LIG} (two one-byte values). The instruction `\.{(LIG} $c$ $r$\.)' 464 means, ``If the next character is $c$, then insert character~$r$ and 465 possibly delete the current character and/or~$c$; 466 otherwise go on to the next instruction.'' 467 Characters $r$ and $c$ must be present in the font. \.{LIG} may be immediately 468 preceded or followed by a slash, and then immediately followed by \.> 469 characters not exceeding the number of slashes. Thus there are eight 470 possible forms: 471 $$\hbox to .8\hsize{\.{LIG}\hfil\.{/LIG}\hfil\.{/LIG>}\hfil 472 \.{LIG/}\hfil\.{LIG/>}\hfil\.{/LIG/}\hfil\.{/LIG/>}\hfil\.{/LIG/>>}}$$ 473 The slashes specify retention of the left or right original character; the 474 \.> signs specify passing over the result without further ligature processing. 475 476 \yskip\hang\.{KRN} (a one-byte value and a real value). The instruction 477 `\.{(KRN} $c$ $r$\.)' means, ``If the next character is $c$, then insert 478 a blank space of width $r$ between the current character and $c$; 479 otherwise go on to the next instruction.'' The value of $r$, which is in 480 design units, is often negative. Character code $c$ must exist 481 in the font. 482 483 \yskip\hang\.{STOP} (no value). This instruction ends a ligature/kern program. 484 It must follow either a \.{LIG} or \.{KRN} instruction, not a \.{LABEL} 485 or \.{STOP} or \.{SKIP}. 486 487 \yskip\hang\.{SKIP} (value in the range |0..127|). This instruction specifies 488 continuation of a ligature/kern program after the specified number of \.{LIG} 489 or \.{KRN} steps has been skipped over. The number of subsequent \.{LIG} and 490 \.{KRN} instructions must therefore exceed this specified amount. 491 492 @ In addition to all these possibilities, the property name \.{COMMENT} is 493 allowed in any property list. Such comments are ignored. 494 495 @ So that is what \.{PL} files hold. In a \.{VPL} file additional 496 properties are recognized; two of these are valid on the outermost level: 497 498 \yskip\hang\.{VTITLE} (string value, default is empty). The value will be 499 reproduced at the beginning of the \.{VF} file (and printed on the terminal 500 by \.{VFtoVP} when it examines that file). 501 502 \yskip\hang\.{MAPFONT}. The value is a nonnegative integer followed by 503 a property list. The integer represents an identifying number for fonts 504 used in \.{MAP} attributes. The property list, which identifies the font and 505 relative size, is defined below. 506 507 \yskip\noindent 508 And one additional ``virtual property'' is valid within a \.{CHARACTER}: 509 510 \yskip\hang\.{MAP}. The value is a property list consisting of typesetting 511 commands. Default is the single command \.{SETCHAR}~$c$, where $c$ is 512 the current character number. 513 514 @ The elements of a \.{MAPFONT} property list can be of the following types. 515 516 \yskip\hang\.{FONTNAME} (string value, default is \.{NULL}). 517 This is the font's identifying name. 518 519 \yskip\hang\.{FONTAREA} (string value, default is empty). If the font appears 520 in a nonstandard directory, according to local conventions, the directory 521 name is given here. (This is system dependent, just as in \.{DVI} files.) 522 523 \yskip\hang\.{FONTCHECKSUM} (four-byte value, default is zero). This value, 524 which should be a nonnegative integer less than $2^{32}$, can be used to 525 check that the font being referred to matches the intended font. If nonzero, 526 it should equal the \.{CHECKSUM} parameter in that font. 527 528 \yskip\hang\.{FONTAT} (numeric value, default is the \.{DESIGNUNITS} of the 529 present virtual font). This value is relative to the design units of 530 the present virtual font, hence it will be scaled when the virtual 531 font is magnified or reduced. It represents the value that will 532 effectively replace the design size of the font being referred to, 533 so that all characters will be scaled appropriately. 534 535 \yskip\hang\.{FONTDSIZE} (numeric value, default is 10). This value is 536 absolute, in units of printer's points. It should equal the \.{DESIGNSIZE} 537 parameter in the font being referred to. 538 539 \yskip\noindent 540 If any of the 541 string values contain parentheses, the parentheses must be balanced. Leading 542 blanks are removed from the strings, but trailing blanks are not. 543 544 @ Finally, the elements of a \.{MAP} property list are an ordered sequence 545 of typesetting commands chosen from among the following: 546 547 \yskip\hang\.{SELECTFONT} (four-byte integer value). The value must be the 548 number of a previously defined \.{MAPFONT}. This font (or more precisely, the 549 final font that is mapped to that code number, if two \.{MAPFONT} properties 550 happen to specify the same code) will be used in subsequent \.{SETCHAR} 551 instructions until overridden by another \.{SELECTFONT}. The first-specified 552 \.{MAPFONT} is implicitly selected before the first \.{SELECTFONT} in every 553 character's map. 554 555 \yskip\hang\.{SETCHAR} (one-byte integer value). There must be a character of 556 this number in the currently selected font. (\.{VPtoVF} doesn't check that 557 the character is valid, but \.{VFtoVP} does.) That character is typeset at the 558 current position, and the typesetter moves right by the \.{CHARWD} in 559 that character's \.{TFM} file. 560 561 \yskip\hang\.{SETRULE} (two real values). The first value specifies height, 562 the second specifies width, in design units. If both height and width are 563 positive, a rule is typeset at the current position. Then the typesetter 564 moves right, by the specified width. 565 566 \yskip\hang\.{MOVERIGHT}, \.{MOVELEFT}, \.{MOVEUP}, \.{MOVEDOWN} (real 567 value). The typesetter moves its current position 568 by the number of design units specified. 569 570 \yskip\hang\.{PUSH}. The current typesetter position is remembered, to 571 be restored on a subsequent \.{POP}. 572 573 \yskip\hang\.{POP}. The current typesetter position is reset to where it 574 was on the most recent unmatched \.{PUSH}. The \.{PUSH} and \.{POP} 575 commands in any \.{MAP} must be properly nested like balanced parentheses. 576 577 \yskip\hang\.{SPECIAL} (string value). The subsequent characters, starting 578 with the first nonblank and ending just before the first `\.)' that has no 579 matching `\.(', are interpreted according to local conventions with the 580 same system-dependent meaning as a `special' (\\{xxx}) command 581 in a \.{DVI} file. 582 583 \yskip\hang\.{SPECIALHEX} (hexadecimal string value). The subsequent 584 nonblank characters before the next `\.)' must consist entirely of 585 hexadecimal digits, and they must contain an even number of such digits. 586 Each pair of hex digits specifies a byte, and this string of bytes is 587 treated just as the value of a \.{SPECIAL}. (This convention permits 588 arbitrary byte strings to be represented in an ordinary text file.) 589 590 @ Virtual font mapping is a recursive process, like macro expansion. 591 Thus, a \.{MAPFONT} might 592 specify another virtual font, whose characters are themselves mapped to 593 other fonts. As an example of this possibility, consider the 594 following curious file called \.{recurse.vpl}, which defines a 595 virtual font that is self-contained and self-referential: 596 $$\vbox{\halign{\.{#}\cr 597 (VTITLE Example of recursion)\cr 598 (MAPFONT D 0 (FONTNAME recurse)(FONTAT D 2))\cr 599 (CHARACTER C A (CHARWD D 1)(CHARHT D 1)(MAP (SETRULE D 1 D 1)))\cr 600 (CHARACTER C B (CHARWD D 2)(CHARHT D 2)(MAP (SETCHAR C A)))\cr 601 (CHARACTER C C (CHARWD D 4)(CHARHT D 4)(MAP (SETCHAR C B)))\cr 602 }}$$ 603 The design size is 10 points (the default), hence the character \.A 604 in font \.{recurse} is a $10\times10$ point black square. Character \.B 605 is typeset as character \.A in \.{recurse} {scaled} {2000}, hence it 606 is a $20\times20$ point black square. And character \.C is typeset as 607 character \.{B} in \.{recurse} {scaled} {2000}, hence its size is 608 $40\times40$. 609 610 Users are responsible for making sure that infinite recursion doesn't happen. 611 612 @ So that is what \.{VPL} files hold. From these rules, 613 you can guess (correctly) that \.{VPtoVF} operates in four main stages. 614 First it assigns the default values to all properties; then it scans 615 through the \.{VPL} file, changing property values as new ones are seen; then 616 it checks the information and corrects any problems; and finally it outputs 617 the \.{VF} and \.{TFM} files. 618 619 @ The next question is, ``What are \.{VF} and 620 \.{TFM} files?'' A complete answer to that question appears in the 621 documentation of the companion programs, \.{VFtoVP} and 622 \.{TFtoPL}, so the details will not 623 be repeated here. Suffice it to say that a \.{VF} or 624 \.{TFM} file stores all of the 625 relevant font information in a sequence of 8-bit bytes. The number of 626 bytes is always a multiple of 4, so we could regard the files 627 as sequences of 32-bit words; but \TeX\ uses the byte interpretation, 628 and so does \.{VPtoVF}. Note that the bytes are considered to be unsigned 629 numbers. 630 631 @<Glob...@>= 632 @!vf_file:packed file of 0..255; 633 @!tfm_file:packed file of 0..255; 634 635 @ On some systems you may have to do something special to write a 636 packed file of bytes. For example, the following code didn't work 637 when it was first tried at Stanford, because packed files have to be 638 opened with a special switch setting on the \PASCAL\ that was used. 639 @^system dependencies@> 640 641 @<Set init...@>= 642 rewrite(vf_file); rewrite(tfm_file); 643 644 @* Basic input routines. 645 For the purposes of this program, a |byte| is an unsigned eight-bit quantity, 646 and an |ASCII_code| is an integer between @'40 and @'177. Such ASCII codes 647 correspond to one-character constants like \.{"A"} in \.{WEB} language. 648 649 @<Types...@>= 650 @!byte=0..255; {unsigned eight-bit quantity} 651 @!ASCII_code=@'40..@'177; {standard ASCII code numbers} 652 653 @ One of the things \.{VPtoVF} has to do is convert characters of strings 654 to ASCII form, since that is the code used for the family name and the 655 coding scheme in a \.{TFM} file. An array |xord| is used to do the 656 conversion from |char|; the method below should work with little or no change 657 on most \PASCAL\ systems. 658 @^system dependencies@> 659 660 @d first_ord=0 {ordinal number of the smallest element of |char|} 661 @d last_ord=127 {ordinal number of the largest element of |char|} 662 663 @<Global...@>= 664 @!xord:array[char] of ASCII_code; {conversion table} 665 666 @ @<Local variables for init...@>= 667 @!k:integer; {all-purpose initialization index} 668 669 @ Characters that should not appear in \.{VPL} files (except in comments) 670 are mapped into @'177. 671 672 @d invalid_code=@'177 {code deserving an error message} 673 674 @<Set init...@>= 675 for k:=first_ord to last_ord do xord[chr(k)]:=invalid_code; 676 xord[' ']:=" "; xord['!']:="!"; xord['"']:=""""; xord['#']:="#"; 677 xord['$']:="$"; xord['%']:="%"; xord['&']:="&"; xord['''']:="'"; 678 xord['(']:="("; xord[')']:=")"; xord['*']:="*"; xord['+']:="+"; xord[',']:=","; 679 xord['-']:="-"; xord['.']:="."; xord['/']:="/"; xord['0']:="0"; xord['1']:="1"; 680 xord['2']:="2"; xord['3']:="3"; xord['4']:="4"; xord['5']:="5"; xord['6']:="6"; 681 xord['7']:="7"; xord['8']:="8"; xord['9']:="9"; xord[':']:=":"; xord[';']:=";"; 682 xord['<']:="<"; xord['=']:="="; xord['>']:=">"; xord['?']:="?"; 683 xord['@@']:="@@"; xord['A']:="A"; xord['B']:="B"; xord['C']:="C"; 684 xord['D']:="D"; xord['E']:="E"; xord['F']:="F"; xord['G']:="G"; xord['H']:="H"; 685 xord['I']:="I"; xord['J']:="J"; xord['K']:="K"; xord['L']:="L"; xord['M']:="M"; 686 xord['N']:="N"; xord['O']:="O"; xord['P']:="P"; xord['Q']:="Q"; xord['R']:="R"; 687 xord['S']:="S"; xord['T']:="T"; xord['U']:="U"; xord['V']:="V"; xord['W']:="W"; 688 xord['X']:="X"; xord['Y']:="Y"; xord['Z']:="Z"; xord['[']:="["; xord['\']:="\"; 689 xord[']']:="]"; xord['^']:="^"; xord['_']:="_"; xord['`']:="`"; xord['a']:="a"; 690 xord['b']:="b"; xord['c']:="c"; xord['d']:="d"; xord['e']:="e"; xord['f']:="f"; 691 xord['g']:="g"; xord['h']:="h"; xord['i']:="i"; xord['j']:="j"; xord['k']:="k"; 692 xord['l']:="l"; xord['m']:="m"; xord['n']:="n"; xord['o']:="o"; xord['p']:="p"; 693 xord['q']:="q"; xord['r']:="r"; xord['s']:="s"; xord['t']:="t"; xord['u']:="u"; 694 xord['v']:="v"; xord['w']:="w"; xord['x']:="x"; xord['y']:="y"; xord['z']:="z"; 695 xord['{']:="{"; xord['|']:="|"; xord['}']:="}"; xord['~']:="~"; 696 697 @ In order to help catch errors of badly nested parentheses, \.{VPtoVF} 698 assumes that the user will begin each line with a number of blank spaces equal 699 to some constant times the number of open parentheses at the beginning of 700 that line. However, the program doesn't know in advance what the constant 701 is, nor does it want to print an error message on every line for a user 702 who has followed no consistent pattern of indentation. 703 704 Therefore the following strategy is adopted: If the user has been consistent 705 with indentation for ten or more lines, an indentation error will be 706 reported. The constant of indentation is reset on every line that should 707 have nonzero indentation. 708 709 @<Glob...@>= 710 @!line:integer; {the number of the current line} 711 @!good_indent:integer; {the number of lines since the last bad indentation} 712 @!indent: integer; {the number of spaces per open parenthesis, zero if unknown} 713 @!level: integer; {the current number of open parentheses} 714 715 @ @<Set init...@>= 716 line:=0; good_indent:=0; indent:=0; level:=0; 717 718 @ The input need not really be broken into lines of any maximum length, and 719 we could read it character by character without any buffering. But we shall 720 place it into a small buffer so that offending lines can be displayed in error 721 messages. 722 723 @<Glob...@>= 724 @!left_ln,@!right_ln:boolean; {are the left and right ends of the buffer 725 at end-of-line marks?} 726 @!limit:0..buf_size; {position of the last character present in the buffer} 727 @!loc:0..buf_size; {position of the last character read in the buffer} 728 @!buffer:array[1..buf_size] of char; 729 @!input_has_ended:boolean; {there is no more input to read} 730 731 @ @<Set init...@>= 732 limit:=0; loc:=0; left_ln:=true; right_ln:=true; input_has_ended:=false; 733 734 @ Just before each \.{CHARACTER} property list is evaluated, the character 735 code is printed in octal notation. Up to eight such codes appear on a line; 736 so we have a variable to keep track of how many are currently there. 737 738 @<Glob...@>= 739 @!chars_on_line:0..8; {the number of characters printed on the current line} 740 741 @ @<Set init...@>= 742 chars_on_line:=0; 743 744 @ The following routine prints an error message and an indication of 745 where the error was detected. The error message should not include any 746 final punctuation, since this procedure supplies its own. 747 748 @d err_print(#)==begin if chars_on_line>0 then print_ln(' '); 749 print(#); show_error_context; 750 end 751 752 @p procedure show_error_context; {prints the current scanner location} 753 var k:0..buf_size; {an index into |buffer|} 754 begin print_ln(' (line ',line:1,').'); 755 if not left_ln then print('...'); 756 for k:=1 to loc do print(buffer[k]); {print the characters already scanned} 757 print_ln(' '); 758 if not left_ln then print(' '); 759 for k:=1 to loc do print(' '); {space out the second line} 760 for k:=loc+1 to limit do print(buffer[k]); {print the characters yet unseen} 761 if right_ln then print_ln(' ')@+else print_ln('...'); 762 chars_on_line:=0; 763 end; 764 765 @ Here is a procedure that does the right thing when we are done 766 reading the present contents of the buffer. It keeps |buffer[buf_size]| 767 empty, in order to avoid range errors on certain \PASCAL\ compilers. 768 769 An infinite sequence of right parentheses is placed at the end of the 770 file, so that the program is sure to get out of whatever level of nesting 771 it is in. 772 773 On some systems it is desirable to modify this code so that tab marks 774 in the buffer are replaced by blank spaces. (Simply setting 775 |xord[chr(@'11)]:=" "| would not work; for example, two-line 776 error messages would not come out properly aligned.) 777 @^system dependencies@> 778 779 @p procedure fill_buffer; 780 begin left_ln:=right_ln; limit:=0; loc:=0; 781 if left_ln then 782 begin if line>0 then read_ln(vpl_file); 783 incr(line); 784 end; 785 if eof(vpl_file) then 786 begin limit:=1; buffer[1]:=')'; right_ln:=false; input_has_ended:=true; 787 end 788 else begin while (limit<buf_size-2)and(not eoln(vpl_file)) do 789 begin incr(limit); read(vpl_file,buffer[limit]); 790 end; 791 buffer[limit+1]:=' '; right_ln:=eoln(vpl_file); 792 if right_ln then begin incr(limit); buffer[limit+1]:=' '; 793 end; 794 if left_ln then @<Set |loc| to the number of leading blanks in 795 the buffer, and check the indentation@>; 796 end; 797 end; 798 799 @ The interesting part about |fill_buffer| is the part that learns what 800 indentation conventions the user is following, if any. 801 802 @d bad_indent(#)==begin if good_indent>=10 then err_print(#); 803 good_indent:=0; indent:=0; 804 end 805 806 @<Set |loc|...@>= 807 begin while (loc<limit)and(buffer[loc+1]=' ') do incr(loc); 808 if loc<limit then 809 begin if level=0 then 810 if loc=0 then incr(good_indent) 811 else bad_indent('Warning: Indented line occurred at level zero') 812 @.Warning: Indented line...@> 813 else if indent=0 then 814 if loc mod level=0 then 815 begin indent:=loc div level; good_indent:=1; 816 end 817 else good_indent:=0 818 else if indent*level=loc then incr(good_indent) 819 else bad_indent('Warning: Inconsistent indentation; ', 820 @.Warning: Inconsistent indentation...@> 821 'you are at parenthesis level ',level:1); 822 end; 823 end 824 825 @* Basic scanning routines. 826 The global variable |cur_char| holds the ASCII code corresponding to the 827 character most recently read from the input buffer, or to a character that 828 has been substituted for the real one. 829 830 @<Global...@>= 831 @!cur_char:ASCII_code; {we have just read this} 832 833 @ Here is a procedure that sets |cur_char| to an ASCII code for the 834 next character of input, if that character is a letter or digit or slash 835 or \.>. Otherwise 836 it sets |cur_char:=" "|, and the input system will be poised to reread the 837 character that was rejected, whether or not it was a space. 838 Lower case letters are converted to upper case. 839 840 @p procedure get_keyword_char; 841 begin while (loc=limit)and(not right_ln) do fill_buffer; 842 if loc=limit then cur_char:=" " {end-of-line counts as a delimiter} 843 else begin cur_char:=xord[buffer[loc+1]]; 844 if cur_char>="a" then cur_char:=cur_char-@'40; 845 if ((cur_char>="0")and(cur_char<="9")) then incr(loc) 846 else if ((cur_char>="A")and(cur_char<="Z")) then incr(loc) 847 else if cur_char="/" then incr(loc) 848 else if cur_char=">" then incr(loc) 849 else cur_char:=" "; 850 end; 851 end; 852 853 @ The following procedure sets |cur_char| to the next character code, 854 and converts lower case to upper case. If the character is a left or 855 right parenthesis, it will not be ``digested''; the character will 856 be read again and again, until the calling routine does something 857 like `|incr(loc)|' to get past it. Such special treatment of parentheses 858 insures that the structural information they contain won't be lost in 859 the midst of other error recovery operations. 860 861 @d backup==begin if (cur_char>")")or(cur_char<"(") then decr(loc); 862 end {undoes the effect of |get_next|} 863 864 @p procedure get_next; {sets |cur_char| to next, balks at parentheses} 865 begin while loc=limit do fill_buffer; 866 incr(loc); cur_char:=xord[buffer[loc]]; 867 if cur_char>="a" then 868 if cur_char<="z" then cur_char:=cur_char-@'40 {uppercasify} 869 else begin if cur_char=invalid_code then 870 begin err_print('Illegal character in the file'); 871 @.Illegal character...@> 872 cur_char:="?"; 873 end; 874 end 875 else if (cur_char<=")")and(cur_char>="(") then decr(loc); 876 end; 877 878 @ Here's a procedure that scans a hexadecimal digit or a right parenthesis. 879 880 @p function get_hex:byte; 881 var @!a:integer; {partial result} 882 begin repeat get_next; 883 until cur_char<>" "; 884 a:=cur_char-")"; 885 if a>0 then 886 begin a:=cur_char-"0"; 887 if cur_char>"9" then 888 if cur_char<"A" then a:=-1 else a:=cur_char-"A"+10; 889 end; 890 if (a<0)or(a>15) then 891 begin err_print('Illegal hexadecimal digit'); get_hex:=0; 892 @.Illegal hexadecimal digit@> 893 end 894 else get_hex:=a; 895 end; 896 897 @ The next procedure is used to ignore the text of a comment, or to pass over 898 erroneous material. As such, it has the privilege of passing parentheses. 899 It stops after the first right parenthesis that drops the level below 900 the level in force when the procedure was called. 901 902 @p procedure skip_to_end_of_item; 903 var l:integer; {initial value of |level|} 904 begin l:=level; 905 while level>=l do 906 begin while loc=limit do fill_buffer; 907 incr(loc); 908 if buffer[loc]=')' then decr(level) 909 else if buffer[loc]='(' then incr(level); 910 end; 911 if input_has_ended then err_print('File ended unexpectedly: No closing ")"'); 912 @.File ended unexpectedly...@> 913 cur_char:=" "; {now the right parenthesis has been read and digested} 914 end; 915 916 @ A similar procedure copies the bytes remaining in an item. The copied bytes 917 go into an array |vf| that we'll declare later. Leading blanks are ignored. 918 919 @d vf_store(#)== 920 begin vf[vf_ptr]:=#; 921 if vf_ptr=vf_size then err_print('I''m out of memory---increase my vfsize!') 922 @.I'm out of memory...@> 923 else incr(vf_ptr); 924 end 925 926 @p procedure copy_to_end_of_item; 927 label 30; 928 var l:integer; {initial value of |level|} 929 @!nonblank_found:boolean; {have we seen a nonblank character yet?} 930 begin l:=level; nonblank_found:=false; 931 while true do 932 begin while loc=limit do fill_buffer; 933 if buffer[loc+1]=')' then 934 if level=l then goto 30@+else decr(level); 935 incr(loc); 936 if buffer[loc]='(' then incr(level); 937 if buffer[loc]<>' ' then nonblank_found:=true; 938 if nonblank_found then 939 if xord[buffer[loc]]=invalid_code then 940 begin err_print('Illegal character in the file'); 941 @.Illegal character...@> 942 vf_store("?"); 943 end 944 else vf_store(xord[buffer[loc]]); 945 end; 946 30:end; 947 948 @ Sometimes we merely want to skip past characters in the input until we 949 reach a left or a right parenthesis. For example, we do this whenever we 950 have finished scanning a property value and we hope that a right parenthesis 951 is next (except for possible blank spaces). 952 953 @d skip_to_paren==repeat get_next@;@+ until (cur_char="(")or(cur_char=")") 954 @d skip_error(#)==begin err_print(#); skip_to_paren; 955 end {this gets to the right parenthesis if something goes wrong} 956 @d flush_error(#)==begin err_print(#); skip_to_end_of_item; 957 end {this gets past the right parenthesis if something goes wrong} 958 959 @ After a property value has been scanned, we want to move just past the 960 right parenthesis that should come next in the input (except for possible 961 blank spaces). 962 963 @p procedure finish_the_property; {do this when the value has been scanned} 964 begin while cur_char=" " do get_next; 965 if cur_char<>")" then err_print('Junk after property value will be ignored'); 966 @.Junk after property value...@> 967 skip_to_end_of_item; 968 end; 969 970 @* Scanning property names. 971 We have to figure out the meaning of names that appear in the \.{VPL} file, 972 by looking them up in a dictionary of known keywords. Keyword number $n$ 973 appears in locations |start[n]| through |start[n+1]-1| of an array called 974 |dictionary|. 975 976 @d max_name_index=100 {upper bound on the number of keywords} 977 @d max_letters=666 {upper bound on the total length of all keywords} 978 979 @<Global...@>= 980 @!start:array[1..max_name_index] of 0..max_letters; 981 @!dictionary:array[0..max_letters] of ASCII_code; 982 @!start_ptr:0..max_name_index; {the first available place in |start|} 983 @!dict_ptr:0..max_letters; {the first available place in |dictionary|} 984 985 @ @<Set init...@>= 986 start_ptr:=1; start[1]:=0; dict_ptr:=0; 987 988 @ When we are looking for a name, we put it into the |cur_name| array. 989 When we have found it, the corresponding |start| index will go into 990 the global variable |name_ptr|. 991 992 @d longest_name=20 {length of \.{DEFAULTRULETHICKNESS}} 993 994 @<Glob...@>= 995 @!cur_name:array[1..longest_name] of ASCII_code; {a name to look up} 996 @!name_length:0..longest_name; {its length} 997 @!name_ptr:0..max_name_index; {its ordinal number in the dictionary} 998 999 @ A conventional hash table with linear probing (cf.\ Algorithm 6.4L 1000 in {\sl The Art of Computer Pro\-gram\-ming\/}) is used for the dictionary 1001 operations. If |nhash[h]=0|, the table position is empty, otherwise |nhash[h]| 1002 points into the |start| array. 1003 1004 @d hash_prime=141 {size of the hash table} 1005 1006 @<Glob...@>= 1007 @!nhash:array[0..hash_prime-1] of 0..max_name_index; 1008 @!cur_hash:0..hash_prime-1; {current position in the hash table} 1009 1010 @ @<Local...@>= 1011 @!h:0..hash_prime-1; {runs through the hash table} 1012 1013 @ @<Set init...@>= 1014 for h:=0 to hash_prime-1 do nhash[h]:=0; 1015 1016 @ Since there is no chance of the hash table overflowing, the procedure 1017 is very simple. After |lookup| has done its work, |cur_hash| will point 1018 to the place where the given name was found, or where it should be inserted. 1019 1020 @p procedure lookup; {finds |cur_name| in the dictionary} 1021 var k:0..longest_name; {index into |cur_name|} 1022 @!j:0..max_letters; {index into |dictionary|} 1023 @!not_found:boolean; {clumsy thing necessary to avoid |goto| statement} 1024 begin @<Compute the hash code, |cur_hash|, for |cur_name|@>; 1025 not_found:=true; 1026 while not_found do 1027 begin if cur_hash=0 then cur_hash:=hash_prime-1@+else decr(cur_hash); 1028 if nhash[cur_hash]=0 then not_found:=false 1029 else begin j:=start[nhash[cur_hash]]; 1030 if start[nhash[cur_hash]+1]=j+name_length then 1031 begin not_found:=false; 1032 for k:=1 to name_length do 1033 if dictionary[j+k-1]<>cur_name[k] then not_found:=true; 1034 end; 1035 end; 1036 end; 1037 name_ptr:=nhash[cur_hash]; 1038 end; 1039 1040 @ @<Compute the hash...@>= 1041 cur_hash:=cur_name[1]; 1042 for k:=2 to name_length do 1043 cur_hash:=(cur_hash+cur_hash+cur_name[k]) mod hash_prime 1044 1045 @ The ``meaning'' of the keyword that begins at |start[k]| in the 1046 dictionary is kept in |equiv[k]|. The numeric |equiv| codes are given 1047 symbolic meanings by the following definitions. 1048 1049 @d comment_code=0 1050 @d check_sum_code=1 1051 @d design_size_code=2 1052 @d design_units_code=3 1053 @d coding_scheme_code=4 1054 @d family_code=5 1055 @d face_code=6 1056 @d seven_bit_safe_flag_code=7 1057 @d header_code= 8 1058 @d font_dimen_code=9 1059 @d lig_table_code=10 1060 @d boundary_char_code=11 1061 @d virtual_title_code=12 1062 @d map_font_code=13 1063 @d character_code=14 1064 @d font_name_code=20 1065 @d font_area_code=21 1066 @d font_checksum_code=22 1067 @d font_at_code=23 1068 @d font_dsize_code=24 1069 @d parameter_code=30 1070 @d char_info_code=60 1071 @d width=1 1072 @d height=2 1073 @d depth=3 1074 @d italic=4 1075 @d char_wd_code=char_info_code+width 1076 @d char_ht_code=char_info_code+height 1077 @d char_dp_code=char_info_code+depth 1078 @d char_ic_code=char_info_code+italic 1079 @d next_larger_code=65 1080 @d map_code=66 1081 @d var_char_code=67 1082 @d select_font_code=80 1083 @d set_char_code=81 1084 @d set_rule_code=82 1085 @d move_right_code=83 1086 @d move_down_code=85 1087 @d push_code=87 1088 @d pop_code=88 1089 @d special_code=89 1090 @d special_hex_code=90 1091 @d label_code=100 1092 @d stop_code=101 1093 @d skip_code=102 1094 @d krn_code=103 1095 @d lig_code=104 1096 1097 @<Glo...@>= 1098 @!equiv:array[0..max_name_index] of byte; 1099 @!cur_code:byte; {equivalent most recently found in |equiv|} 1100 1101 @ We have to get the keywords into the hash table and into the dictionary in 1102 the first place (sigh). The procedure that does this has the desired 1103 |equiv| code as a parameter. In order to facilitate \.{WEB} macro writing 1104 for the initialization, the keyword being initialized is placed into the 1105 last positions of |cur_name|, instead of the first positions. 1106 1107 @p procedure enter_name(v:byte); {|cur_name| goes into the dictionary} 1108 var k:0..longest_name; 1109 begin for k:=1 to name_length do 1110 cur_name[k]:=cur_name[k+longest_name-name_length]; 1111 {now the name has been shifted into the correct position} 1112 lookup; {this sets |cur_hash| to the proper insertion place} 1113 nhash[cur_hash]:=start_ptr; equiv[start_ptr]:=v; 1114 for k:=1 to name_length do 1115 begin dictionary[dict_ptr]:=cur_name[k]; incr(dict_ptr); 1116 end; 1117 incr(start_ptr); start[start_ptr]:=dict_ptr; 1118 end; 1119 1120 @ Here are the macros to load a name of up to 20 letters into the 1121 dictionary. For example, the macro |load5| is used for five-letter keywords. 1122 1123 @d tail(#)==enter_name(#) 1124 @d t20(#)==cur_name[20]:=#;tail 1125 @d t19(#)==cur_name[19]:=#;t20 1126 @d t18(#)==cur_name[18]:=#;t19 1127 @d t17(#)==cur_name[17]:=#;t18 1128 @d t16(#)==cur_name[16]:=#;t17 1129 @d t15(#)==cur_name[15]:=#;t16 1130 @d t14(#)==cur_name[14]:=#;t15 1131 @d t13(#)==cur_name[13]:=#;t14 1132 @d t12(#)==cur_name[12]:=#;t13 1133 @d t11(#)==cur_name[11]:=#;t12 1134 @d t10(#)==cur_name[10]:=#;t11 1135 @d t9(#)==cur_name[9]:=#;t10 1136 @d t8(#)==cur_name[8]:=#;t9 1137 @d t7(#)==cur_name[7]:=#;t8 1138 @d t6(#)==cur_name[6]:=#;t7 1139 @d t5(#)==cur_name[5]:=#;t6 1140 @d t4(#)==cur_name[4]:=#;t5 1141 @d t3(#)==cur_name[3]:=#;t4 1142 @d t2(#)==cur_name[2]:=#;t3 1143 @d t1(#)==cur_name[1]:=#;t2 1144 @d load3==name_length:=3;t18 1145 @d load4==name_length:=4;t17 1146 @d load5==name_length:=5;t16 1147 @d load6==name_length:=6;t15 1148 @d load7==name_length:=7;t14 1149 @d load8==name_length:=8;t13 1150 @d load9==name_length:=9;t12 1151 @d load10==name_length:=10;t11 1152 @d load11==name_length:=11;t10 1153 @d load12==name_length:=12;t9 1154 @d load13==name_length:=13;t8 1155 @d load14==name_length:=14;t7 1156 @d load15==name_length:=15;t6 1157 @d load16==name_length:=16;t5 1158 @d load17==name_length:=17;t4 1159 @d load18==name_length:=18;t3 1160 @d load19==name_length:=19;t2 1161 @d load20==name_length:=20;t1 1162 1163 @ (Thank goodness for keyboard macros in the text editor used to create this 1164 \.{WEB} file.) 1165 1166 @<Enter all the \.{PL} names and their equivalents, 1167 except the parameter names@>= 1168 equiv[0]:=comment_code; {this is used after unknown keywords} 1169 load8("C")("H")("E")("C")("K")("S")("U")("M")(check_sum_code);@/ 1170 load10("D")("E")("S")("I")("G")("N")("S")("I")("Z")("E")(design_size_code);@/ 1171 load11("D")("E")("S")("I")("G")("N") 1172 ("U")("N")("I")("T")("S")(design_units_code);@/ 1173 load12("C")("O")("D")("I")("N")("G") 1174 ("S")("C")("H")("E")("M")("E")(coding_scheme_code);@/ 1175 load6("F")("A")("M")("I")("L")("Y")(family_code);@/ 1176 load4("F")("A")("C")("E")(face_code);@/ 1177 load16("S")("E")("V")("E")("N")("B")("I")("T")@/@t\hskip2em@> 1178 ("S")("A")("F")("E")("F")("L")("A")("G")(seven_bit_safe_flag_code);@/ 1179 load6("H")("E")("A")("D")("E")("R")(header_code);@/ 1180 load9("F")("O")("N")("T")("D")("I")("M")("E")("N")(font_dimen_code);@/ 1181 load8("L")("I")("G")("T")("A")("B")("L")("E")(lig_table_code);@/ 1182 load12("B")("O")("U")("N")("D")("A")("R")("Y")("C")("H")("A")("R") 1183 (boundary_char_code);@/ 1184 load9("C")("H")("A")("R")("A")("C")("T")("E")("R")(character_code);@/ 1185 load9("P")("A")("R")("A")("M")("E")("T")("E")("R")(parameter_code);@/ 1186 load6("C")("H")("A")("R")("W")("D")(char_wd_code);@/ 1187 load6("C")("H")("A")("R")("H")("T")(char_ht_code);@/ 1188 load6("C")("H")("A")("R")("D")("P")(char_dp_code);@/ 1189 load6("C")("H")("A")("R")("I")("C")(char_ic_code);@/ 1190 load10("N")("E")("X")("T")("L")("A")("R")("G")("E")("R")(next_larger_code);@/ 1191 load7("V")("A")("R")("C")("H")("A")("R")(var_char_code);@/ 1192 load3("T")("O")("P")(var_char_code+1);@/ 1193 load3("M")("I")("D")(var_char_code+2);@/ 1194 load3("B")("O")("T")(var_char_code+3);@/ 1195 load3("R")("E")("P")(var_char_code+4);@/ 1196 load3("E")("X")("T")(var_char_code+4); {compatibility with older \.{PL} format} 1197 load7("C")("O")("M")("M")("E")("N")("T")(comment_code);@/ 1198 load5("L")("A")("B")("E")("L")(label_code);@/ 1199 load4("S")("T")("O")("P")(stop_code);@/ 1200 load4("S")("K")("I")("P")(skip_code);@/ 1201 load3("K")("R")("N")(krn_code);@/ 1202 load3("L")("I")("G")(lig_code);@/ 1203 load4("/")("L")("I")("G")(lig_code+2);@/ 1204 load5("/")("L")("I")("G")(">")(lig_code+6);@/ 1205 load4("L")("I")("G")("/")(lig_code+1);@/ 1206 load5("L")("I")("G")("/")(">")(lig_code+5);@/ 1207 load5("/")("L")("I")("G")("/")(lig_code+3);@/ 1208 load6("/")("L")("I")("G")("/")(">")(lig_code+7);@/ 1209 load7("/")("L")("I")("G")("/")(">")(">")(lig_code+11);@/ 1210 1211 @ \.{VPL} files may contain the following in addition to the \.{PL} names. 1212 1213 @<Enter all the \.{VPL} names@>= 1214 load6("V")("T")("I")("T")("L")("E")(virtual_title_code);@/ 1215 load7("M")("A")("P")("F")("O")("N")("T")(map_font_code);@/ 1216 load3("M")("A")("P")(map_code);@/ 1217 load8("F")("O")("N")("T")("N")("A")("M")("E")(font_name_code);@/ 1218 load8("F")("O")("N")("T")("A")("R")("E")("A")(font_area_code);@/ 1219 load12("F")("O")("N")("T") 1220 ("C")("H")("E")("C")("K")("S")("U")("M")(font_checksum_code);@/ 1221 load6("F")("O")("N")("T")("A")("T")(font_at_code);@/ 1222 load9("F")("O")("N")("T")("D")("S")("I")("Z")("E")(font_dsize_code);@/ 1223 load10("S")("E")("L")("E")("C")("T")("F")("O")("N")("T")(select_font_code);@/ 1224 load7("S")("E")("T")("C")("H")("A")("R")(set_char_code);@/ 1225 load7("S")("E")("T")("R")("U")("L")("E")(set_rule_code);@/ 1226 load9("M")("O")("V")("E")("R")("I")("G")("H")("T")(move_right_code);@/ 1227 load8("M")("O")("V")("E")("L")("E")("F")("T")(move_right_code+1);@/ 1228 load8("M")("O")("V")("E")("D")("O")("W")("N")(move_down_code);@/ 1229 load6("M")("O")("V")("E")("U")("P")(move_down_code+1);@/ 1230 load4("P")("U")("S")("H")(push_code);@/ 1231 load3("P")("O")("P")(pop_code);@/ 1232 load7("S")("P")("E")("C")("I")("A")("L")(special_code);@/ 1233 load10("S")("P")("E")("C")("I")("A")("L")("H")("E")("X")(special_hex_code);@/ 1234 1235 @ @<Enter the parameter names@>= 1236 load5("S")("L")("A")("N")("T")(parameter_code+1);@/ 1237 load5("S")("P")("A")("C")("E")(parameter_code+2);@/ 1238 load7("S")("T")("R")("E")("T")("C")("H")(parameter_code+3);@/ 1239 load6("S")("H")("R")("I")("N")("K")(parameter_code+4);@/ 1240 load7("X")("H")("E")("I")("G")("H")("T")(parameter_code+5);@/ 1241 load4("Q")("U")("A")("D")(parameter_code+6);@/ 1242 load10("E")("X")("T")("R")("A")("S")("P")("A")("C")("E")(parameter_code+7);@/ 1243 load4("N")("U")("M")("1")(parameter_code+8);@/ 1244 load4("N")("U")("M")("2")(parameter_code+9);@/ 1245 load4("N")("U")("M")("3")(parameter_code+10);@/ 1246 load6("D")("E")("N")("O")("M")("1")(parameter_code+11);@/ 1247 load6("D")("E")("N")("O")("M")("2")(parameter_code+12);@/ 1248 load4("S")("U")("P")("1")(parameter_code+13);@/ 1249 load4("S")("U")("P")("2")(parameter_code+14);@/ 1250 load4("S")("U")("P")("3")(parameter_code+15);@/ 1251 load4("S")("U")("B")("1")(parameter_code+16);@/ 1252 load4("S")("U")("B")("2")(parameter_code+17);@/ 1253 load7("S")("U")("P")("D")("R")("O")("P")(parameter_code+18);@/ 1254 load7("S")("U")("B")("D")("R")("O")("P")(parameter_code+19);@/ 1255 load6("D")("E")("L")("I")("M")("1")(parameter_code+20);@/ 1256 load6("D")("E")("L")("I")("M")("2")(parameter_code+21);@/ 1257 load10("A")("X")("I")("S")("H")("E")("I")("G")("H")("T")(parameter_code+22);@/ 1258 load20("D")("E")("F")("A")("U")("L")("T")("R")("U")("L")("E")@/@t\hskip2em@> 1259 ("T")("H")("I")("C")("K")("N")("E")("S")("S")(parameter_code+8);@/ 1260 load13("B")("I")("G")("O")("P") 1261 ("S")("P")("A")("C")("I")("N")("G")("1")(parameter_code+9);@/ 1262 load13("B")("I")("G")("O")("P") 1263 ("S")("P")("A")("C")("I")("N")("G")("2")(parameter_code+10);@/ 1264 load13("B")("I")("G")("O")("P") 1265 ("S")("P")("A")("C")("I")("N")("G")("3")(parameter_code+11);@/ 1266 load13("B")("I")("G")("O")("P") 1267 ("S")("P")("A")("C")("I")("N")("G")("4")(parameter_code+12);@/ 1268 load13("B")("I")("G")("O")("P") 1269 ("S")("P")("A")("C")("I")("N")("G")("5")(parameter_code+13);@/ 1270 1271 @ When a left parenthesis has been scanned, the following routine 1272 is used to interpret the keyword that follows, and to store the 1273 equivalent value in |cur_code|. 1274 1275 @p procedure get_name; 1276 begin incr(loc); incr(level); {pass the left parenthesis} 1277 cur_char:=" "; 1278 while cur_char=" " do get_next; 1279 if (cur_char>")")or(cur_char<"(") then decr(loc); {back up one character} 1280 name_length:=0; get_keyword_char; {prepare to scan the name} 1281 while cur_char<>" " do 1282 begin if name_length=longest_name then cur_name[1]:="X" {force error} 1283 else incr(name_length); 1284 cur_name[name_length]:=cur_char; 1285 get_keyword_char; 1286 end; 1287 lookup; 1288 if name_ptr=0 then err_print('Sorry, I don''t know that property name'); 1289 @.Sorry, I don't know...@> 1290 cur_code:=equiv[name_ptr]; 1291 end; 1292 1293 @* Scanning numeric data. 1294 The next thing we need is a trio of subroutines to read the one-byte, 1295 four-byte, and real numbers that may appear as property values. 1296 These subroutines are careful to stick to numbers between $-2^{31}$ 1297 and $2^{31}-1$, inclusive, so that a computer with two's complement 1298 32-bit arithmetic will not be interrupted by overflow. 1299 1300 @ The first number scanner, which returns a one-byte value, surely has 1301 no problems of arithmetic overflow. 1302 1303 @p function get_byte:byte; {scans a one-byte property value} 1304 var acc:integer; {an accumulator} 1305 @!t:ASCII_code; {the type of value to be scanned} 1306 begin repeat get_next; 1307 until cur_char<>" "; {skip the blanks before the type code} 1308 t:=cur_char; acc:=0; 1309 repeat get_next; 1310 until cur_char<>" "; {skip the blanks after the type code} 1311 if t="C" then @<Scan an ASCII character code@> 1312 else if t="D" then @<Scan a small decimal number@> 1313 else if t="O" then @<Scan a small octal number@> 1314 else if t="H" then @<Scan a small hexadecimal number@> 1315 else if t="F" then @<Scan a face code@> 1316 else skip_error('You need "C" or "D" or "O" or "H" or "F" here'); 1317 @.You need "C" or "D" ...here@> 1318 cur_char:=" "; get_byte:=acc; 1319 end; 1320 1321 @ The |get_next| routine converts lower case to upper case, but it leaves 1322 the character in the buffer, so we can unconvert it. 1323 1324 @<Scan an ASCII...@>= 1325 if (cur_char>=@'41)and(cur_char<=@'176)and 1326 ((cur_char<"(")or(cur_char>")")) then 1327 acc:=xord[buffer[loc]] 1328 else skip_error('"C" value must be standard ASCII and not a paren') 1329 @:C value}\.{"C" value must be...@> 1330 1331 @ @<Scan a small dec...@>= 1332 begin while (cur_char>="0")and(cur_char<="9") do 1333 begin acc:=acc*10+cur_char-"0"; 1334 if acc>255 then 1335 begin skip_error('This value shouldn''t exceed 255'); 1336 @.This value shouldn't...@> 1337 acc:=0; cur_char:=" "; 1338 end 1339 else get_next; 1340 end; 1341 backup; 1342 end 1343 1344 @ @<Scan a small oct...@>= 1345 begin while (cur_char>="0")and(cur_char<="7") do 1346 begin acc:=acc*8+cur_char-"0"; 1347 if acc>255 then 1348 begin skip_error('This value shouldn''t exceed ''377'); 1349 @.This value shouldn't...@> 1350 acc:=0; cur_char:=" "; 1351 end 1352 else get_next; 1353 end; 1354 backup; 1355 end 1356 1357 @ @<Scan a small hex...@>= 1358 begin while ((cur_char>="0")and(cur_char<="9"))or 1359 ((cur_char>="A")and(cur_char<="F")) do 1360 begin if cur_char>="A" then cur_char:=cur_char+"0"+10-"A"; 1361 acc:=acc*16+cur_char-"0"; 1362 if acc>255 then 1363 begin skip_error('This value shouldn''t exceed "FF'); 1364 @.This value shouldn't...@> 1365 acc:=0; cur_char:=" "; 1366 end 1367 else get_next; 1368 end; 1369 backup; 1370 end 1371 1372 @ @<Scan a face...@>= 1373 begin if cur_char="B" then acc:=2 1374 else if cur_char="L" then acc:=4 1375 else if cur_char<>"M" then acc:=18; 1376 get_next; 1377 if cur_char="I" then incr(acc) 1378 else if cur_char<>"R" then acc:=18; 1379 get_next; 1380 if cur_char="C" then acc:=acc+6 1381 else if cur_char="E" then acc:=acc+12 1382 else if cur_char<>"R" then acc:=18; 1383 if acc>=18 then 1384 begin skip_error('Illegal face code, I changed it to MRR'); 1385 @.Illegal face code...@> 1386 acc:=0; 1387 end; 1388 end 1389 1390 @ The routine that scans a four-byte value puts its output into |cur_bytes|, 1391 which is a record containing (yes, you guessed it) four bytes. 1392 1393 @<Types...@>= 1394 @!four_bytes=record @!b0:byte;@+@!b1:byte;@+@!b2:byte;@+@!b3:byte;@+end; 1395 1396 @ @d c0==cur_bytes.b0 1397 @d c1==cur_bytes.b1 1398 @d c2==cur_bytes.b2 1399 @d c3==cur_bytes.b3 1400 1401 @<Glob...@>= 1402 @!cur_bytes:four_bytes; {a four-byte accumulator} 1403 @!zero_bytes:four_bytes; {four bytes all zero} 1404 1405 @ @<Set init...@>= 1406 zero_bytes.b0:=0; zero_bytes.b1:=0; zero_bytes.b2:=0; zero_bytes.b3:=0; 1407 1408 @ Since the |get_four_bytes| routine is used very infrequently, no attempt 1409 has been made to make it fast; we only want it to work. 1410 1411 @p procedure get_four_bytes; {scans an unsigned constant and sets |four_bytes|} 1412 var c:integer; {local two-byte accumulator} 1413 @!r:integer; {radix} 1414 begin repeat get_next; 1415 until cur_char<>" "; {skip the blanks before the type code} 1416 r:=0; cur_bytes:=zero_bytes; {start with the accumulator zero} 1417 if cur_char="H" then r:=16 1418 else if cur_char="O" then r:=8 1419 else if cur_char="D" then r:=10 1420 else skip_error('Decimal ("D"), octal ("O"), or hex ("H") value needed here'); 1421 @.Decimal ("D"), octal ("O"), or hex...@> 1422 if r>0 then 1423 begin repeat get_next; 1424 until cur_char<>" "; {skip the blanks after the type code} 1425 while ((cur_char>="0")and(cur_char<="9"))or@| 1426 ((cur_char>="A")and(cur_char<="F")) do 1427 @<Multiply by |r|, add |cur_char-"0"|, and |get_next|@>; 1428 end; 1429 end; 1430 1431 @ @<Multiply by |r|...@>= 1432 begin if cur_char>="A" then cur_char:=cur_char+"0"+10-"A"; 1433 if cur_char>="0"+r then skip_error('Illegal digit') 1434 @.Illegal digit@> 1435 else begin c:=c3*r+cur_char-"0"; c3:=c mod 256;@/ 1436 c:=c2*r+c div 256; c2:=c mod 256;@/ 1437 c:=c1*r+c div 256; c1:=c mod 256;@/ 1438 c:=c0*r+c div 256; 1439 if c<256 then c0:=c 1440 else begin cur_bytes:=zero_bytes; 1441 if r=8 then 1442 skip_error('Sorry, the maximum octal value is O 37777777777') 1443 @.Sorry, the maximum...@> 1444 else if r=10 then 1445 skip_error('Sorry, the maximum decimal value is D 4294967295') 1446 else skip_error('Sorry, the maximum hex value is H FFFFFFFF'); 1447 end; 1448 get_next; 1449 end; 1450 end 1451 1452 @ The remaining scanning routine is the most interesting. It scans a real 1453 constant and returns the nearest |fix_word| approximation to that constant. 1454 A |fix_word| is a 32-bit integer that represents a real value that 1455 has been multiplied by $2^{20}$. Since \.{VPtoVF} restricts the magnitude 1456 of reals to 2048, the |fix_word| will have a magnitude less than $2^{31}$. 1457 1458 @d unity==@'4000000 {$2^{20}$, the |fix_word| 1.0} 1459 1460 @<Types...@>= 1461 @!fix_word=integer; {a scaled real value with 20 bits of fraction} 1462 1463 @ When a real value is desired, we might as well treat `\.D' and `\.R' 1464 formats as if they were identical. 1465 1466 @p function get_fix:fix_word; {scans a real property value} 1467 var negative:boolean; {was there a minus sign?} 1468 @!acc:integer; {an accumulator} 1469 @!int_part:integer; {the integer part} 1470 @!j:0..7; {the number of decimal places stored} 1471 begin repeat get_next; 1472 until cur_char<>" "; {skip the blanks before the type code} 1473 negative:=false; acc:=0; {start with the accumulators zero} 1474 if (cur_char<>"R")and(cur_char<>"D") then 1475 skip_error('An "R" or "D" value is needed here') 1476 @.An "R" or "D" ... needed here@> 1477 else begin @<Scan the blanks and/or signs after the type code@>; 1478 while (cur_char>="0") and (cur_char<="9") do 1479 @<Multiply by 10, add |cur_char-"0"|, and |get_next|@>; 1480 int_part:=acc; acc:=0; 1481 if cur_char="." then @<Scan the fraction part and put it in |acc|@>; 1482 if (acc>=unity)and(int_part=2047) then 1483 skip_error('Real constants must be less than 2048') 1484 @.Real constants must be...@> 1485 else acc:=int_part*unity+acc; 1486 end; 1487 if negative then get_fix:=-acc@+else get_fix:=acc; 1488 end; 1489 1490 @ @<Scan the blanks...@>= 1491 repeat get_next; 1492 if cur_char="-" then 1493 begin cur_char:=" "; negative:=not negative; 1494 end 1495 else if cur_char="+" then cur_char:=" "; 1496 until cur_char<>" " 1497 1498 @ @<Multiply by 10...@>= 1499 begin acc:=acc*10+cur_char-"0"; 1500 if acc>=2048 then 1501 begin skip_error('Real constants must be less than 2048'); 1502 @.Real constants must be...@> 1503 acc:=0; cur_char:=" "; 1504 end 1505 else get_next; 1506 end 1507 1508 @ To scan the fraction $.d_1d_2\ldots\,$, we keep track of up to seven 1509 of the digits $d_j$. A correct result is obtained if we first compute 1510 $f^\prime=\lfloor 2^{21}(d_1\ldots d_j)/10^j\rfloor$, after which 1511 $f=\lfloor(f^\prime+1)/2\rfloor$. It is possible to have $f=1.0$. 1512 1513 @<Glob...@>= 1514 @!fraction_digits:array[1..7] of integer; {$2^{21}$ times $d_j$} 1515 1516 @ @<Scan the frac...@>= 1517 begin j:=0; get_next; 1518 while (cur_char>="0")and(cur_char<="9") do 1519 begin if j<7 then 1520 begin incr(j); fraction_digits[j]:=@'10000000*(cur_char-"0"); 1521 end; 1522 get_next; 1523 end; 1524 acc:=0; 1525 while j>0 do 1526 begin acc:=fraction_digits[j]+(acc div 10); decr(j); 1527 end; 1528 acc:=(acc+10) div 20; 1529 end 1530 1531 @* Storing the property values. 1532 When property values have been found, they are squirreled away in a bunch 1533 of arrays. The header information is unpacked into bytes in an array 1534 called |header_bytes|. The ligature/kerning program is stored in an array 1535 of type |four_bytes|. 1536 Another |four_bytes| array holds the specifications of extensible characters. 1537 The kerns and parameters are stored in separate arrays of |fix_word| values. 1538 Virtual font data goes into an array |vf| of single-byte values. 1539 1540 We maintain information about at most 256 local fonts. (If this is inadequate, 1541 several arrays need to be made longer and we need to output font definitions 1542 that go beyond |fnt1| and |fnt_def1| in the \.{VF} file.) 1543 1544 Instead of storing the design size in the header array, we will keep it 1545 in a |fix_word| variable until the last minute. The number of units in the 1546 design size is also kept in a |fix_word|. 1547 1548 @<Glob...@>= 1549 @!header_bytes:array[header_index] of byte; {the header block} 1550 @!header_ptr:header_index; {the number of header bytes in use} 1551 @!design_size:fix_word; {the design size} 1552 @!design_units:fix_word; {reciprocal of the scaling factor} 1553 @!frozen_du:boolean; {have we used |design_units| irrevocably?} 1554 @!seven_bit_safe_flag:boolean; {does the file claim to be seven-bit-safe?} 1555 @!lig_kern:array[0..max_lig_steps] of four_bytes; {the ligature program} 1556 @!nl:0..32767; {the number of ligature/kern instructions so far} 1557 @!min_nl:0..32767; {the final value of |nl| must be at least this} 1558 @!kern:array[0..max_kerns] of fix_word; {the distinct kerning amounts} 1559 @!nk:0..max_kerns; {the number of entries of |kern|} 1560 @!exten:array[0..255] of four_bytes; {extensible character specs} 1561 @!ne:0..256; {the number of extensible characters} 1562 @!param:array[1..max_param_words] of fix_word; {\.{FONTDIMEN} parameters} 1563 @!np:0..max_param_words; {the largest parameter set nonzero} 1564 @!check_sum_specified:boolean; {did the user name the check sum?} 1565 @!bchar:0..256; {the right boundary character, or 256 if unspecified} 1566 @!vf:array[0..vf_size] of byte; {stored bytes for \.{VF} file} 1567 @!vf_ptr:0..vf_size; {first unused location in |vf|} 1568 @!vtitle_start:0..vf_size; {starting location of \.{VTITLE} string} 1569 @!vtitle_length:byte; {length of \.{VTITLE} string} 1570 @!packet_start:array[byte] of 0..vf_size; 1571 {beginning location of character packet} 1572 @!packet_length:array[byte] of integer; {length of character packet} 1573 @!font_ptr:0..256; {number of distinct local fonts seen} 1574 @!cur_font:0..256; {number of the current local font} 1575 @!fname_start:array[byte] of 0..vf_size; {beginning of local font name} 1576 @!fname_length:array[byte] of byte; {length of local font name} 1577 @!farea_start:array[byte] of 0..vf_size; {beginning of local font area} 1578 @!farea_length:array[byte] of byte; {length of local font area} 1579 @!font_checksum:array[byte] of four_bytes; {local font checksum} 1580 @!font_number:array[0..256] of four_bytes; {local font id number} 1581 @!font_at:array[byte] of fix_word; {local font ``at size''} 1582 @!font_dsize:array[byte] of fix_word; {local font design size} 1583 1584 @ @<Types...@>= 1585 @!header_index=0..max_header_bytes; 1586 @!indx=0..@'77777; 1587 1588 @ @<Local...@>= 1589 @!d:header_index; {an index into |header_bytes|} 1590 1591 @ We start by setting up the default values. 1592 1593 @d check_sum_loc=0 1594 @d design_size_loc=4 1595 @d coding_scheme_loc=8 1596 @d family_loc=coding_scheme_loc+40 1597 @d seven_flag_loc=family_loc+20 1598 @d face_loc=seven_flag_loc+3 1599 1600 @<Set init...@>= 1601 for d:=0 to 18*4-1 do header_bytes[d]:=0; 1602 header_bytes[8]:=11; header_bytes[9]:="U"; 1603 header_bytes[10]:="N"; 1604 header_bytes[11]:="S"; 1605 header_bytes[12]:="P"; 1606 header_bytes[13]:="E"; 1607 header_bytes[14]:="C"; 1608 header_bytes[15]:="I"; 1609 header_bytes[16]:="F"; 1610 header_bytes[17]:="I"; 1611 header_bytes[18]:="E"; 1612 header_bytes[19]:="D"; 1613 @.UNSPECIFIED@> 1614 for d:=family_loc to family_loc+11 do header_bytes[d]:=header_bytes[d-40]; 1615 design_size:=10*unity; design_units:=unity; frozen_du:=false; 1616 seven_bit_safe_flag:=false;@/ 1617 header_ptr:=18*4; nl:=0; min_nl:=0; nk:=0; ne:=0; np:=0;@/ 1618 check_sum_specified:=false; bchar:=256;@/ 1619 vf_ptr:=0; vtitle_start:=0; vtitle_length:=0; font_ptr:=0; 1620 for k:=0 to 255 do packet_start[k]:=vf_size; 1621 for k:=0 to 127 do packet_length[k]:=1; 1622 for k:=128 to 255 do packet_length[k]:=2; 1623 1624 @ Most of the dimensions, however, go into the |memory| array. There are 1625 at most 257 widths, 257 heights, 257 depths, and 257 italic corrections, 1626 since the value 0 is required but it need not be used. So |memory| has room 1627 for 1028 entries, each of which is a |fix_word|. An auxiliary table called 1628 |link| is used to link these words together in linear lists, so that 1629 sorting and other operations can be done conveniently. 1630 1631 We also add four ``list head'' words to the |memory| and |link| arrays; 1632 these are in locations |width| through |italic|, i.e., 1 through 4. 1633 For example, |link[height]| points to the smallest element in 1634 the sorted list of distinct heights that have appeared so far, and 1635 |memory[height]| is the number of distinct heights. 1636 1637 @d mem_size=1028+4 {number of nonzero memory addresses} 1638 1639 @<Types...@>= 1640 @!pointer=0..mem_size; {an index into memory} 1641 1642 @ The arrays |char_wd|, |char_ht|, |char_dp|, and |char_ic| contain 1643 pointers to the |memory| array entries where the corresponding dimensions 1644 appear. Two other arrays, |char_tag| and |char_remainder|, hold 1645 the other information that \.{TFM} files pack into a |char_info_word|. 1646 1647 @d no_tag=0 {vanilla character} 1648 @d lig_tag=1 {character has a ligature/kerning program} 1649 @d list_tag=2 {character has a successor in a charlist} 1650 @d ext_tag=3 {character is extensible} 1651 @d bchar_label==char_remainder[256] 1652 {beginning of ligature program for left boundary} 1653 1654 @<Glob...@>= 1655 @!memory:array[pointer] of fix_word; {character dimensions and kerns} 1656 @!mem_ptr:pointer; {largest |memory| word in use} 1657 @!link:array[pointer] of pointer; {to make lists of |memory| items} 1658 @!char_wd:array[byte] of pointer; {pointers to the widths} 1659 @!char_ht:array[byte] of pointer; {pointers to the heights} 1660 @!char_dp:array[byte] of pointer; {pointers to the depths} 1661 @!char_ic:array[byte] of pointer; {pointers to italic corrections} 1662 @!char_tag:array[byte] of no_tag..ext_tag; {character tags} 1663 @!char_remainder:array[0..256] of 0..65535; {pointers to ligature labels, 1664 next larger characters, or extensible characters} 1665 1666 @ @<Local...@>= 1667 @!c:byte; {runs through all character codes} 1668 1669 @ @<Set init...@>= 1670 bchar_label:=@'77777; 1671 for c:=0 to 255 do 1672 begin char_wd[c]:=0; char_ht[c]:=0; char_dp[c]:=0; char_ic[c]:=0;@/ 1673 char_tag[c]:=no_tag; char_remainder[c]:=0; 1674 end; 1675 memory[0]:=@'17777777777; {an ``infinite'' element at the end of the lists} 1676 memory[width]:=0; link[width]:=0; {width list is empty} 1677 memory[height]:=0; link[height]:=0; {height list is empty} 1678 memory[depth]:=0; link[depth]:=0; {depth list is empty} 1679 memory[italic]:=0; link[italic]:=0; {italic list is empty} 1680 mem_ptr:=italic; 1681 1682 @ As an example of these data structures, let us consider the simple 1683 routine that inserts a potentially new element into one of the dimension 1684 lists. The first parameter indicates the list head (i.e., |h=width| for 1685 the width list, etc.); the second parameter is the value that is to be 1686 inserted into the list if it is not already present. The procedure 1687 returns the value of the location where the dimension appears in |memory|. 1688 The fact that |memory[0]| is larger than any legal dimension makes the 1689 algorithm particularly short. 1690 1691 We do have to handle two somewhat subtle situations. A width of zero must be 1692 put into the list, so that a zero-width character in the font will not appear 1693 to be nonexistent (i.e., so that its |char_wd| index will not be zero), but 1694 this does not need to be done for heights, depths, or italic corrections. 1695 Furthermore, it is necessary to test for memory overflow even though we 1696 have provided room for the maximum number of different dimensions in any 1697 legal font, since the \.{VPL} file might foolishly give any number of 1698 different sizes to the same character. 1699 1700 @p function sort_in(@!h:pointer;@!d:fix_word):pointer; {inserts into list} 1701 var p:pointer; {the current node of interest} 1702 begin if (d=0)and(h<>width) then sort_in:=0 1703 else begin p:=h; 1704 while d>=memory[link[p]] do p:=link[p]; 1705 if (d=memory[p])and(p<>h) then sort_in:=p 1706 else if mem_ptr=mem_size then 1707 begin err_print('Memory overflow: more than 1028 widths, etc'); 1708 @.Memory overflow...@> 1709 print_ln('Congratulations! It''s hard to make this error.'); 1710 sort_in:=p; 1711 end 1712 else begin incr(mem_ptr); memory[mem_ptr]:=d; 1713 link[mem_ptr]:=link[p]; link[p]:=mem_ptr; incr(memory[h]); 1714 sort_in:=mem_ptr; 1715 end; 1716 end; 1717 end; 1718 1719 @ When these lists of dimensions are eventually written to the \.{TFM} 1720 file, we may have to do some rounding of values, because the \.{TFM} file 1721 allows at most 256 widths, 16 heights, 16 depths, and 64 italic 1722 corrections. The following procedure takes a given list head |h| and a 1723 given dimension |d|, and returns the minimum $m$ such that the elements of 1724 the list can be covered by $m$ intervals of width $d$. It also sets 1725 |next_d| to the smallest value $d^\prime>d$ such that the covering found 1726 by this procedure would be different. In particular, if $d=0$ it computes 1727 the number of elements of the list, and sets |next_d| to the smallest 1728 distance between two list elements. (The covering by intervals of width 1729 |next_d| is not guaranteed to have fewer than $m$ elements, but in practice 1730 this seems to happen most of the time.) 1731 1732 @<Glob...@>= 1733 @!next_d:fix_word; {the next larger interval that is worth trying} 1734 1735 @ Once again we can make good use of the fact that |memory[0]| is ``infinite.'' 1736 1737 @p function min_cover(@!h:pointer;@!d:fix_word):integer; 1738 var p:pointer; {the current node of interest} 1739 @!l:fix_word; {the least element covered by the current interval} 1740 @!m:integer; {the current size of the cover being generated} 1741 begin m:=0; p:=link[h]; next_d:=memory[0]; 1742 while p<>0 do 1743 begin incr(m); l:=memory[p]; 1744 while memory[link[p]]<=l+d do p:=link[p]; 1745 p:=link[p]; 1746 if memory[p]-l<next_d then next_d:=memory[p]-l; 1747 end; 1748 min_cover:=m; 1749 end; 1750 1751 @ The following procedure uses |min_cover| to determine the smallest $d$ 1752 such that a given list can be covered with at most a given number of 1753 intervals. 1754 1755 @p function shorten(@!h:pointer;m:integer):fix_word; {finds best way to round} 1756 var d:fix_word; {the current trial interval length} 1757 @!k:integer; {the size of a minimum cover} 1758 begin if memory[h]>m then 1759 begin excess:=memory[h]-m; 1760 k:=min_cover(h,0); d:=next_d; {now the answer is at least |d|} 1761 repeat d:=d+d; k:=min_cover(h,d); 1762 until k<=m; {first we ascend rapidly until finding the range} 1763 d:=d div 2; k:=min_cover(h,d); {now we run through the feasible steps} 1764 while k>m do 1765 begin d:=next_d; k:=min_cover(h,d); 1766 end; 1767 shorten:=d; 1768 end 1769 else shorten:=0; 1770 end; 1771 1772 @ When we are nearly ready to output the \.{TFM} file, we will set 1773 |index[p]:=k| if the dimension in |memory[p]| is being rounded to the 1774 |k|th element of its list. 1775 1776 @<Glob...@>= 1777 @!index:array[pointer] of byte; 1778 @!excess:byte; {number of words to remove, if list is being shortened} 1779 1780 @ Here is the procedure that sets the |index| values. It also shortens 1781 the list so that there is only one element per covering interval; 1782 the remaining elements are the midpoints of their clusters. 1783 1784 @p procedure set_indices(@!h:pointer;@!d:fix_word); {reduces and indexes a list} 1785 var p:pointer; {the current node of interest} 1786 @!q:pointer; {trails one step behind |p|} 1787 @!m:byte; {index number of nodes in the current interval} 1788 @!l:fix_word; {least value in the current interval} 1789 begin q:=h; p:=link[q]; m:=0; 1790 while p<>0 do 1791 begin incr(m); l:=memory[p]; index[p]:=m; 1792 while memory[link[p]]<=l+d do 1793 begin p:=link[p]; index[p]:=m; decr(excess); 1794 if excess=0 then d:=0; 1795 end; 1796 link[q]:=p; memory[p]:=l+(memory[p]-l) div 2; q:=p; p:=link[p]; 1797 end; 1798 memory[h]:=m; 1799 end; 1800 1801 @* The input phase. 1802 We're ready now to read and parse the \.{VPL} file, storing property 1803 values as we go. 1804 1805 @<Glob...@>= 1806 @!c:byte; {the current character or byte being processed} 1807 @!x:fix_word; {current dimension of interest} 1808 @!k:integer; {general-purpose index} 1809 1810 @ @<Read all the input@>= 1811 cur_char:=" "; 1812 repeat while cur_char=" " do get_next; 1813 if cur_char="(" then @<Read a font property value@> 1814 else if (cur_char=")")and not input_has_ended then 1815 begin err_print('Extra right parenthesis'); 1816 incr(loc); cur_char:=" "; 1817 end 1818 @.Extra right parenthesis@> 1819 else if not input_has_ended then junk_error; 1820 until input_has_ended 1821 1822 @ The |junk_error| routine just referred to is called when something 1823 appears in the forbidden area between properties of a property list. 1824 1825 @p procedure junk_error; {gets past no man's land} 1826 begin err_print('There''s junk here that is not in parentheses'); 1827 @.There's junk here...@> 1828 skip_to_paren; 1829 end; 1830 1831 @ For each font property, we are supposed to read the data from the 1832 left parenthesis that is the current value of |cur_char| to the right 1833 parenthesis that matches it in the input. The main complication is 1834 to recover with reasonable grace from various error conditions that might arise. 1835 1836 @<Read a font property value@>= 1837 begin get_name; 1838 if cur_code=comment_code then skip_to_end_of_item 1839 else if cur_code>character_code then 1840 flush_error('This property name doesn''t belong on the outer level') 1841 @.This property name doesn't belong...@> 1842 else begin @<Read the font property value specified by |cur_code|@>; 1843 finish_the_property; 1844 end; 1845 end 1846 1847 @ @<Read the font property value spec...@>= 1848 case cur_code of 1849 check_sum_code: begin check_sum_specified:=true; read_four_bytes(check_sum_loc); 1850 end; 1851 design_size_code: @<Read the design size@>; 1852 design_units_code: @<Read the design units@>; 1853 coding_scheme_code: read_BCPL(coding_scheme_loc,40); 1854 family_code: read_BCPL(family_loc,20); 1855 face_code:header_bytes[face_loc]:=get_byte; 1856 seven_bit_safe_flag_code: @<Read the seven-bit-safe flag@>; 1857 header_code: @<Read an indexed header word@>; 1858 font_dimen_code: @<Read font parameter list@>; 1859 lig_table_code: read_lig_kern; 1860 boundary_char_code: bchar:=get_byte; 1861 virtual_title_code: begin vtitle_start:=vf_ptr; copy_to_end_of_item; 1862 if vf_ptr>vtitle_start+255 then 1863 begin err_print('VTITLE clipped to 255 characters'); vtitle_length:=255; 1864 @.VTITLE clipped...@> 1865 end 1866 else vtitle_length:=vf_ptr-vtitle_start; 1867 end; 1868 map_font_code:@<Read a local font list@>; 1869 character_code: read_char_info; 1870 end 1871 1872 @ The |case| statement just given makes use of three subroutines that we 1873 haven't defined yet. The first of these puts a 32-bit octal quantity 1874 into four specified bytes of the header block. 1875 1876 @p procedure read_four_bytes(l:header_index); 1877 begin get_four_bytes; 1878 header_bytes[l]:=c0; 1879 header_bytes[l+1]:=c1; 1880 header_bytes[l+2]:=c2; 1881 header_bytes[l+3]:=c3; 1882 end; 1883 1884 @ The second little procedure is used to scan a string and to store it in 1885 the ``{\mc BCPL} format'' required by \.{TFM} files. The string is supposed 1886 to contain at most |n| bytes, including the first byte (which holds the 1887 length of the rest of the string). 1888 1889 @p procedure read_BCPL(l:header_index;n:byte); 1890 var k:header_index; 1891 begin k:=l; 1892 while cur_char=" " do get_next; 1893 while (cur_char<>"(")and(cur_char<>")") do 1894 begin if k<l+n then incr(k); 1895 if k<l+n then header_bytes[k]:=cur_char; 1896 get_next; 1897 end; 1898 if k=l+n then 1899 begin err_print('String is too long; its first ',n-1:1, 1900 @.String is too long...@> 1901 ' characters will be kept'); decr(k); 1902 end; 1903 header_bytes[l]:=k-l; 1904 while k<l+n-1 do {tidy up the remaining bytes by setting them to nulls} 1905 begin incr(k); header_bytes[k]:=0; 1906 end; 1907 end; 1908 1909 @ @<Read the design size@>= 1910 begin next_d:=get_fix; 1911 if next_d<unity then 1912 err_print('The design size must be at least 1') 1913 @.The design size must...@> 1914 else design_size:=next_d; 1915 end 1916 1917 @ @<Read the design units@>= 1918 begin next_d:=get_fix; 1919 if next_d<=0 then 1920 err_print('The number of units per design size must be positive') 1921 @.The number of units...@> 1922 else if frozen_du then 1923 err_print('Sorry, it''s too late to change the design units') 1924 @.Sorry, it's too late...@> 1925 else design_units:=next_d; 1926 end 1927 1928 @ @<Read the seven-bit-safe...@>= 1929 begin while cur_char=" " do get_next; 1930 if cur_char="T" then seven_bit_safe_flag:=true 1931 else if cur_char="F" then seven_bit_safe_flag:=false 1932 else err_print('The flag value should be "TRUE" or "FALSE"'); 1933 @.The flag value should be...@> 1934 skip_to_paren; 1935 end 1936 1937 @ @<Read an indexed header word@>= 1938 begin c:=get_byte; 1939 if c<18 then skip_error('HEADER indices should be 18 or more') 1940 @.HEADER indices...@> 1941 else if 4*c+4>max_header_bytes then 1942 skip_error('This HEADER index is too big for my present table size') 1943 @.This HEADER index is too big...@> 1944 else begin while header_ptr<4*c+4 do 1945 begin header_bytes[header_ptr]:=0; incr(header_ptr); 1946 end; 1947 read_four_bytes(4*c); 1948 end; 1949 end 1950 1951 @ The remaining kinds of font property values that need to be read are 1952 those that involve property lists on higher levels. Each of these has a 1953 loop similar to the one that was used at level zero. Then we put the 1954 right parenthesis back so that `|finish_the_property|' will be happy; 1955 there is probably a more elegant way to do this. 1956 1957 @d finish_inner_property_list==begin decr(loc); incr(level); cur_char:=")"; 1958 end 1959 1960 @<Read font parameter list@>= 1961 begin while level=1 do 1962 begin while cur_char=" " do get_next; 1963 if cur_char="(" then @<Read a parameter value@> 1964 else if cur_char=")" then skip_to_end_of_item 1965 else junk_error; 1966 end; 1967 finish_inner_property_list; 1968 end 1969 1970 @ @<Read a parameter value@>= 1971 begin get_name; 1972 if cur_code=comment_code then skip_to_end_of_item 1973 else if (cur_code<parameter_code)or(cur_code>=char_wd_code) then 1974 flush_error('This property name doesn''t belong in a FONTDIMEN list') 1975 @.This property name doesn't belong...@> 1976 else begin if cur_code=parameter_code then c:=get_byte 1977 else c:=cur_code-parameter_code; 1978 if c=0 then flush_error('PARAMETER index must not be zero') 1979 @.PARAMETER index must not...@> 1980 else if c>max_param_words then 1981 flush_error('This PARAMETER index is too big for my present table size') 1982 @.This PARAMETER index is too big...@> 1983 else begin while np<c do 1984 begin incr(np); param[np]:=0; 1985 end; 1986 param[c]:=get_fix; 1987 finish_the_property; 1988 end; 1989 end; 1990 end 1991 1992 @ @d numbers_differ==(font_number[cur_font].b3<>font_number[font_ptr].b3)or@| 1993 (font_number[cur_font].b2<>font_number[font_ptr].b2)or@| 1994 (font_number[cur_font].b1<>font_number[font_ptr].b1)or@| 1995 (font_number[cur_font].b0<>font_number[font_ptr].b0) 1996 1997 @<Read a local font list@>= 1998 begin get_four_bytes; font_number[font_ptr]:=cur_bytes; cur_font:=0; 1999 while numbers_differ do incr(cur_font); 2000 if cur_font=font_ptr then {it's a new font number} 2001 if font_ptr<256 then @<Initialize a new local font@> 2002 else err_print('I can handle only 256 different mapfonts'); 2003 @.I can handle only 256...@> 2004 if cur_font=font_ptr then skip_to_end_of_item 2005 else while level=1 do 2006 begin while cur_char=" " do get_next; 2007 if cur_char="(" then @<Read a local font property@> 2008 else if cur_char=")" then skip_to_end_of_item 2009 else junk_error; 2010 end; 2011 finish_inner_property_list; 2012 end 2013 2014 @ @<Initialize a new local font@>= 2015 begin incr(font_ptr); 2016 fname_start[cur_font]:=vf_size; fname_length[cur_font]:=4; {\.{NULL}} 2017 farea_start[cur_font]:=vf_size; farea_length[cur_font]:=0; 2018 font_checksum[cur_font]:=zero_bytes; 2019 font_at[cur_font]:=@'4000000; {denotes design size of this virtual font} 2020 font_dsize[cur_font]:=@'50000000; {the |fix_word| for 10} 2021 end 2022 2023 @ @<Read a local font property@>= 2024 begin get_name; 2025 if cur_code=comment_code then skip_to_end_of_item 2026 else if (cur_code<font_name_code)or(cur_code>font_dsize_code) then 2027 flush_error('This property name doesn''t belong in a MAPFONT list') 2028 @.This property name doesn't belong...@> 2029 else begin case cur_code of 2030 font_name_code:@<Read a local font name@>; 2031 font_area_code:@<Read a local font area@>; 2032 font_checksum_code:begin get_four_bytes; font_checksum[cur_font]:=cur_bytes; 2033 end; 2034 font_at_code: begin frozen_du:=true; 2035 if design_units=unity then font_at[cur_font]:=get_fix 2036 else font_at[cur_font]:=round((get_fix/design_units)*1048576.0); 2037 end; 2038 font_dsize_code:font_dsize[cur_font]:=get_fix; 2039 end; {there are no other cases} 2040 finish_the_property; 2041 end; 2042 end 2043 2044 @ @<Read a local font name@>= 2045 begin fname_start[cur_font]:=vf_ptr; copy_to_end_of_item; 2046 if vf_ptr>fname_start[cur_font]+255 then 2047 begin err_print('FONTNAME clipped to 255 characters'); 2048 @.FONTNAME clipped...@> 2049 fname_length[cur_font]:=255; 2050 end 2051 else fname_length[cur_font]:=vf_ptr-fname_start[cur_font]; 2052 end 2053 2054 @ @<Read a local font area@>= 2055 begin farea_start[cur_font]:=vf_ptr; copy_to_end_of_item; 2056 if vf_ptr>farea_start[cur_font]+255 then 2057 begin err_print('FONTAREA clipped to 255 characters'); 2058 @.FONTAREA clipped...@> 2059 farea_length[cur_font]:=255; 2060 end 2061 else farea_length[cur_font]:=vf_ptr-farea_start[cur_font]; 2062 end 2063 2064 @ @<Read ligature/kern list@>= 2065 begin lk_step_ended:=false; 2066 while level=1 do 2067 begin while cur_char=" " do get_next; 2068 if cur_char="(" then @<Read a ligature/kern command@> 2069 else if cur_char=")" then skip_to_end_of_item 2070 else junk_error; 2071 end; 2072 finish_inner_property_list; 2073 end 2074 2075 @ @<Read a ligature/kern command@>= 2076 begin get_name; 2077 if cur_code=comment_code then skip_to_end_of_item 2078 else if cur_code<label_code then 2079 flush_error('This property name doesn''t belong in a LIGTABLE list') 2080 @.This property name doesn't belong...@> 2081 else begin case cur_code of 2082 label_code:@<Read a label step@>; 2083 stop_code:@<Read a stop step@>; 2084 skip_code:@<Read a skip step@>; 2085 krn_code:@<Read a kerning step@>; 2086 lig_code,lig_code+1,lig_code+2,lig_code+3,lig_code+5,lig_code+6,lig_code+7, 2087 lig_code+11:@<Read a ligature step@>; 2088 end; {there are no other cases |>=label_code|} 2089 finish_the_property; 2090 end; 2091 end 2092 2093 @ When a character is about to be tagged, we call the following 2094 procedure so that an error message is given in case of multiple tags. 2095 2096 @p procedure check_tag(c:byte); {print error if |c| already tagged} 2097 begin case char_tag[c] of 2098 no_tag: do_nothing; 2099 lig_tag: err_print('This character already appeared in a LIGTABLE LABEL'); 2100 @.This character already...@> 2101 list_tag: err_print('This character already has a NEXTLARGER spec'); 2102 ext_tag: err_print('This character already has a VARCHAR spec'); 2103 end; 2104 end; 2105 2106 @ @<Read a label step@>= 2107 begin while cur_char=" " do get_next; 2108 if cur_char="B" then 2109 begin bchar_label:=nl; skip_to_paren; {\.{LABEL BOUNDARYCHAR}} 2110 end 2111 else begin backup; c:=get_byte; 2112 check_tag(c); char_tag[c]:=lig_tag; char_remainder[c]:=nl; 2113 end; 2114 if min_nl<=nl then min_nl:=nl+1; 2115 lk_step_ended:=false; 2116 end 2117 2118 @ @d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program} 2119 @d kern_flag=128 {op code for a kern step} 2120 2121 @<Globals...@>= 2122 @!lk_step_ended:boolean; 2123 {was the last \.{LIGTABLE} property \.{LIG} or \.{KRN}?} 2124 @!krn_ptr:0..max_kerns; {an index into |kern|} 2125 2126 @ @<Read a stop step@>= 2127 if not lk_step_ended then 2128 err_print('STOP must follow LIG or KRN') 2129 @.STOP must follow LIG or KRN@> 2130 else begin lig_kern[nl-1].b0:=stop_flag; lk_step_ended:=false; 2131 end 2132 2133 @ @<Read a skip step@>= 2134 if not lk_step_ended then 2135 err_print('SKIP must follow LIG or KRN') 2136 @.SKIP must follow LIG or KRN@> 2137 else begin c:=get_byte; 2138 if c>=128 then err_print('Maximum SKIP amount is 127') 2139 @.Maximum SKIP amount...@> 2140 else if nl+c>=max_lig_steps then 2141 err_print('Sorry, LIGTABLE too long for me to handle') 2142 @.Sorry, LIGTABLE too long...@> 2143 else begin lig_kern[nl-1].b0:=c; 2144 if min_nl<=nl+c then min_nl:=nl+c+1; 2145 end; 2146 lk_step_ended:=false; 2147 end 2148 2149 @ @<Read a ligature step@>= 2150 begin lig_kern[nl].b0:=0; 2151 lig_kern[nl].b2:=cur_code-lig_code; 2152 lig_kern[nl].b1:=get_byte; 2153 lig_kern[nl].b3:=get_byte; 2154 if nl>=max_lig_steps-1 then 2155 err_print('Sorry, LIGTABLE too long for me to handle') 2156 @.Sorry, LIGTABLE too long...@> 2157 else incr(nl); 2158 lk_step_ended:=true; 2159 end 2160 2161 @ @<Read a kerning step@>= 2162 begin lig_kern[nl].b0:=0; lig_kern[nl].b1:=get_byte; 2163 kern[nk]:=get_fix; krn_ptr:=0; 2164 while kern[krn_ptr]<>kern[nk] do incr(krn_ptr); 2165 if krn_ptr=nk then 2166 begin if nk<max_kerns then incr(nk) 2167 else begin err_print('Sorry, too many different kerns for me to handle'); 2168 @.Sorry, too many different kerns...@> 2169 decr(krn_ptr); 2170 end; 2171 end; 2172 lig_kern[nl].b2:=kern_flag+(krn_ptr div 256); 2173 lig_kern[nl].b3:=krn_ptr mod 256; 2174 if nl>=max_lig_steps-1 then 2175 err_print('Sorry, LIGTABLE too long for me to handle') 2176 @.Sorry, LIGTABLE too long...@> 2177 else incr(nl); 2178 lk_step_ended:=true; 2179 end 2180 2181 @ Finally we come to the part of \.{VPtoVF}'s input mechanism 2182 that is used most, the processing of individual character data. 2183 2184 @<Read character info list@>= 2185 begin c:=get_byte; {read the character code that is being specified} 2186 @<Print |c| in octal notation@>; 2187 while level=1 do 2188 begin while cur_char=" " do get_next; 2189 if cur_char="(" then @<Read a character property@> 2190 else if cur_char=")" then skip_to_end_of_item 2191 else junk_error; 2192 end; 2193 if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|} 2194 finish_inner_property_list; 2195 end 2196 2197 @ @<Read a character prop...@>= 2198 begin get_name; 2199 if cur_code=comment_code then skip_to_end_of_item 2200 else if (cur_code<char_wd_code)or(cur_code>var_char_code) then 2201 flush_error('This property name doesn''t belong in a CHARACTER list') 2202 @.This property name doesn't belong...@> 2203 else begin case cur_code of 2204 char_wd_code:char_wd[c]:=sort_in(width,get_fix); 2205 char_ht_code:char_ht[c]:=sort_in(height,get_fix); 2206 char_dp_code:char_dp[c]:=sort_in(depth,get_fix); 2207 char_ic_code:char_ic[c]:=sort_in(italic,get_fix); 2208 next_larger_code:begin check_tag(c); char_tag[c]:=list_tag; 2209 char_remainder[c]:=get_byte; 2210 end; 2211 map_code:read_packet(c); 2212 var_char_code:@<Read an extensible recipe for |c|@>; 2213 end;@/ 2214 finish_the_property; 2215 end; 2216 end 2217 2218 @ @<Read an extensible r...@>= 2219 begin if ne=256 then 2220 err_print('At most 256 VARCHAR specs are allowed') 2221 @.At most 256 VARCHAR specs...@> 2222 else begin check_tag(c); char_tag[c]:=ext_tag; char_remainder[c]:=ne;@/ 2223 exten[ne]:=zero_bytes; 2224 while level=2 do 2225 begin while cur_char=" " do get_next; 2226 if cur_char="(" then @<Read an extensible piece@> 2227 else if cur_char=")" then skip_to_end_of_item 2228 else junk_error; 2229 end; 2230 incr(ne); 2231 finish_inner_property_list; 2232 end; 2233 end 2234 2235 @ @<Read an extensible p...@>= 2236 begin get_name; 2237 if cur_code=comment_code then skip_to_end_of_item 2238 else if (cur_code<var_char_code+1)or(cur_code>var_char_code+4) then 2239 flush_error('This property name doesn''t belong in a VARCHAR list') 2240 @.This property name doesn't belong...@> 2241 else begin case cur_code-(var_char_code+1) of 2242 0:exten[ne].b0:=get_byte; 2243 1:exten[ne].b1:=get_byte; 2244 2:exten[ne].b2:=get_byte; 2245 3:exten[ne].b3:=get_byte; 2246 end;@/ 2247 finish_the_property; 2248 end; 2249 end 2250 2251 @* Assembling the mappings. 2252 Each \.{MAP} property is a sequence of \.{DVI} instructions, for which 2253 we need to know some of the opcodes. 2254 2255 @d set_char_0=0 {\.{DVI} command to typeset character 0 and move right} 2256 @d set1=128 {typeset a character and move right} 2257 @d set_rule=132 {typeset a rule and move right} 2258 @d push=141 {save the current positions} 2259 @d pop=142 {restore previous positions} 2260 @d right1=143 {move right} 2261 @d w0=147 {move right by |w|} 2262 @d w1=148 {move right and set |w|} 2263 @d x0=152 {move right by |x|} 2264 @d x1=153 {move right and set |x|} 2265 @d down1=157 {move down} 2266 @d y0=161 {move down by |y|} 2267 @d y1=162 {move down and set |y|} 2268 @d z0=166 {move down by |z|} 2269 @d z1=167 {move down and set |z|} 2270 @d fnt_num_0=171 {set current font to 0} 2271 @d fnt1=235 {set current font} 2272 @d xxx1=239 {extension to \.{DVI} primitives} 2273 @d xxx4=242 {potentially long extension to \.{DVI} primitives} 2274 @d fnt_def1=243 {define the meaning of a font number} 2275 @d pre=247 {preamble} 2276 @d post=248 {postamble beginning} 2277 2278 @ We keep stacks of movement values, in order to optimize the \.{DVI} code 2279 in simple cases. 2280 2281 @<Glob...@>= 2282 @!hstack:array[0..max_stack] of 0..2; {number of known horizontal movements} 2283 @!vstack:array[0..max_stack] of 0..2; {number of known vertical movements} 2284 @!wstack,@!xstack,@!ystack,@!zstack:array[0..max_stack] of fix_word; 2285 @!stack_ptr:0..max_stack; 2286 2287 @ The packet is built by straightforward assembly of \.{DVI} instructions. 2288 2289 @p @<Declare the |vf_fix| procedure@>@;@/ 2290 procedure read_packet(@!c:byte); 2291 var @!cc:byte; {character being typeset} 2292 @!x:fix_word; {movement} 2293 @!h,@!v:0..2; {top of |hstack| and |vstack|} 2294 @!special_start:0..vf_size; {location of |xxx1| command} 2295 @!k:0..vf_size; {loop index} 2296 begin packet_start[c]:=vf_ptr; stack_ptr:=0; h:=0; v:=0; 2297 cur_font:=0; 2298 while level=2 do 2299 begin while cur_char=" " do get_next; 2300 if cur_char="(" then @<Read and assemble a list of \.{DVI} commands@> 2301 else if cur_char=")" then skip_to_end_of_item 2302 else junk_error; 2303 end; 2304 while stack_ptr>0 do 2305 begin err_print('Missing POP supplied'); 2306 @.Missing POP supplied@> 2307 vf_store(pop); decr(stack_ptr); 2308 end; 2309 packet_length[c]:=vf_ptr-packet_start[c]; 2310 finish_inner_property_list; 2311 end; 2312 2313 @ @<Read and assemble a list of \.{DVI}...@>= 2314 begin get_name; 2315 if cur_code=comment_code then skip_to_end_of_item 2316 else if (cur_code<select_font_code)or(cur_code>special_hex_code) then 2317 flush_error('This property name doesn''t belong in a MAP list') 2318 @.This property name doesn't belong...@> 2319 else begin case cur_code of 2320 select_font_code:@<Assemble a font selection@>; 2321 set_char_code:@<Assemble a typesetting instruction@>; 2322 set_rule_code:@<Assemble a rulesetting instruction@>; 2323 move_right_code,move_right_code+1:@<Assemble a horizontal movement@>; 2324 move_down_code,move_down_code+1:@<Assemble a vertical movement@>; 2325 push_code:@<Assemble a stack push@>; 2326 pop_code:@<Assemble a stack pop@>; 2327 special_code,special_hex_code:@<Assemble a special command@>; 2328 end;@/ 2329 finish_the_property; 2330 end; 2331 end 2332 2333 @ @<Assemble a font selection@>= 2334 begin get_four_bytes; font_number[font_ptr]:=cur_bytes; 2335 cur_font:=0; 2336 while numbers_differ do incr(cur_font); 2337 if cur_font=font_ptr then err_print('Undefined MAPFONT cannot be selected') 2338 @.Undefined MAPFONT...@> 2339 else if cur_font<64 then vf_store(fnt_num_0+cur_font) 2340 else begin vf_store(fnt1); vf_store(cur_font); 2341 end; 2342 end 2343 2344 @ @<Assemble a typesetting instruction@>= 2345 if cur_font=font_ptr then 2346 err_print('Character cannot be typeset in undefined font') 2347 @.Character cannot be typeset...@> 2348 else begin cc:=get_byte; 2349 if cc>=128 then vf_store(set1); 2350 vf_store(cc); 2351 end 2352 2353 @ Here's a procedure that converts a |fix_word| to a sequence of 2354 \.{DVI} bytes. 2355 2356 @<Declare the |vf_fix|...@>= 2357 procedure vf_fix(@!opcode:byte;@!x:fix_word); 2358 var negative:boolean; 2359 @!k:0..4; {number of bytes to typeset} 2360 @!t:integer; {threshold} 2361 begin frozen_du:=true; 2362 if design_units<>unity then x:=round((x/design_units)*1048576.0); 2363 if x>=0 then negative:=false 2364 else begin negative:=true; x:=-1-x;@+end; 2365 if opcode=0 then 2366 begin k:=4; t:=@'100000000;@+end 2367 else begin t:=127; k:=1; 2368 while x>t do 2369 begin t:=256*t+255; incr(k); 2370 end; 2371 vf_store(opcode+k-1); t:=t div 128 +1; 2372 end; 2373 repeat if negative then 2374 begin vf_store(255-(x div t)); negative:=false; 2375 x:=(x div t)*t+t-1-x; 2376 end 2377 else vf_store((x div t) mod 256); 2378 decr(k); t:=t div 256; 2379 until k=0; 2380 end; 2381 2382 @ @<Assemble a rulesetting instruction@>= 2383 begin vf_store(set_rule); vf_fix(0,get_fix); vf_fix(0,get_fix); 2384 end 2385 2386 @ @<Assemble a horizontal movement@>= 2387 begin if cur_code=move_right_code then x:=get_fix@+else x:=-get_fix; 2388 if h=0 then 2389 begin wstack[stack_ptr]:=x; h:=1; vf_fix(w1,x);@+end 2390 else if x=wstack[stack_ptr] then vf_store(w0) 2391 else if h=1 then 2392 begin xstack[stack_ptr]:=x; h:=2; vf_fix(x1,x);@+end 2393 else if x=xstack[stack_ptr] then vf_store(x0) 2394 else vf_fix(right1,x); 2395 end 2396 2397 @ @<Assemble a vertical movement@>= 2398 begin if cur_code=move_down_code then x:=get_fix@+else x:=-get_fix; 2399 if v=0 then 2400 begin ystack[stack_ptr]:=x; v:=1; vf_fix(y1,x);@+end 2401 else if x=ystack[stack_ptr] then vf_store(y0) 2402 else if v=1 then 2403 begin zstack[stack_ptr]:=x; v:=2; vf_fix(z1,x);@+end 2404 else if x=zstack[stack_ptr] then vf_store(z0) 2405 else vf_fix(down1,x); 2406 end 2407 2408 @ @<Assemble a stack push@>= 2409 if stack_ptr=max_stack then {too pushy} 2410 err_print('Don''t push so much---stack is full!') 2411 @.Don't push so much...@> 2412 else begin vf_store(push); hstack[stack_ptr]:=h; vstack[stack_ptr]:=v; 2413 incr(stack_ptr); h:=0; v:=0; 2414 end 2415 2416 @ @<Assemble a stack pop@>= 2417 if stack_ptr=0 then 2418 err_print('Empty stack cannot be popped') 2419 @.Empty stack...@> 2420 else begin vf_store(pop); decr(stack_ptr); 2421 h:=hstack[stack_ptr]; v:=vstack[stack_ptr]; 2422 end 2423 2424 @ @<Assemble a special command@>= 2425 begin vf_store(xxx1); vf_store(0); {dummy length} 2426 special_start:=vf_ptr; 2427 if cur_code=special_code then copy_to_end_of_item 2428 else begin repeat x:=get_hex; 2429 if cur_char>")" then vf_store(x*16+get_hex); 2430 until cur_char<=")"; 2431 end; 2432 if vf_ptr-special_start>255 then @<Convert |xxx1| command to |xxx4|@> 2433 else vf[special_start-1]:=vf_ptr-special_start; 2434 end 2435 2436 @ @<Convert |xxx1|...@>= 2437 if vf_ptr+3>vf_size then 2438 begin err_print('Special command being clipped---no room left!'); 2439 @.Special command being clipped...@> 2440 vf_ptr:=special_start+255; vf[special_start-1]:=255; 2441 end 2442 else begin for k:=vf_ptr downto special_start do vf[k+3]:=vf[k]; 2443 x:=vf_ptr-special_start; vf_ptr:=vf_ptr+3; 2444 vf[special_start-2]:=xxx4; 2445 vf[special_start-1]:=x div @'100000000; 2446 vf[special_start]:=(x div @'200000) mod 256; 2447 vf[special_start+1]:=(x div @'400) mod 256; 2448 vf[special_start+2]:=x mod 256; 2449 end 2450 2451 @ The input routine is now complete except for the following code, 2452 which prints a progress report as the file is being read. 2453 2454 @p procedure print_octal(c:byte); {prints three octal digits} 2455 begin print('''',(c div 64):1,((c div 8) mod 8):1,(c mod 8):1); 2456 end; 2457 2458 @ @<Print |c| in octal...@>= 2459 begin if chars_on_line=8 then 2460 begin print_ln(' '); chars_on_line:=1; 2461 end 2462 else begin if chars_on_line>0 then print(' '); 2463 incr(chars_on_line); 2464 end; 2465 print_octal(c); {progress report} 2466 end 2467 2468 @* The checking and massaging phase. 2469 Once the whole \.{VPL} file has been read in, we must check it for consistency 2470 and correct any errors. This process consists mainly of running through 2471 the characters that exist and seeing if they refer to characters that 2472 don't exist. We also compute the true value of |seven_unsafe|; we make sure 2473 that the charlists and ligature programs contain no loops; and we 2474 shorten the lists of widths, heights, depths, and italic corrections, 2475 if necessary, to keep from exceeding the required maximum sizes. 2476 2477 @<Glob...@>= 2478 @!seven_unsafe:boolean; {do seven-bit characters generate eight-bit ones?} 2479 2480 @ @<Correct and check the information@>= 2481 if nl>0 then @<Make sure the ligature/kerning program ends appropriately@>; 2482 seven_unsafe:=false; 2483 for c:=0 to 255 do if char_wd[c]<>0 then 2484 @<For all characters |g| generated by |c|, 2485 make sure that |char_wd[g]| is nonzero, and 2486 set |seven_unsafe| if |c<128<=g|@>; 2487 if bchar_label<@'77777 then 2488 begin c:=256; @<Check ligature program of |c|@>; 2489 end; 2490 if seven_bit_safe_flag and seven_unsafe then 2491 print_ln('The font is not really seven-bit-safe!'); 2492 @.The font is not...safe@> 2493 @<Check for infinite ligature loops@>; 2494 @<Doublecheck the lig/kern commands and the extensible recipes@>; 2495 for c:=0 to 255 do 2496 @<Make sure that |c| is not the largest element of a charlist cycle@>; 2497 @<Put the width, height, depth, and italic lists into final form@> 2498 2499 @ The checking that we need in several places is accomplished by three 2500 macros that are only slightly tricky. 2501 2502 @d existence_tail(#)==begin char_wd[g]:=sort_in(width,0); 2503 print(#,' '); print_octal(c); 2504 print_ln(' had no CHARACTER spec.'); 2505 end; 2506 end 2507 @d check_existence_and_safety(#)==begin g:=#; 2508 if (g>=128)and(c<128) then seven_unsafe:=true; 2509 if char_wd[g]=0 then existence_tail 2510 @d check_existence(#)==begin g:=#; 2511 if char_wd[g]=0 then existence_tail 2512 2513 @<For all characters |g| generated by |c|...@>= 2514 case char_tag[c] of 2515 no_tag: do_nothing; 2516 lig_tag: @<Check ligature program of |c|@>; 2517 list_tag: check_existence_and_safety(char_remainder[c]) 2518 ('The character NEXTLARGER than'); 2519 @.The character NEXTLARGER...@> 2520 ext_tag:@<Check the pieces of |exten[c]|@>; 2521 end 2522 2523 @ @<Check the pieces...@>= 2524 begin if exten[char_remainder[c]].b0>0 then 2525 check_existence_and_safety(exten[char_remainder[c]].b0) 2526 ('TOP piece of character'); 2527 @.TOP piece of character...@> 2528 if exten[char_remainder[c]].b1>0 then 2529 check_existence_and_safety(exten[char_remainder[c]].b1) 2530 ('MID piece of character'); 2531 @.MID piece of character...@> 2532 if exten[char_remainder[c]].b2>0 then 2533 check_existence_and_safety(exten[char_remainder[c]].b2) 2534 ('BOT piece of character'); 2535 @.BOT piece of character...@> 2536 check_existence_and_safety(exten[char_remainder[c]].b3) 2537 ('REP piece of character'); 2538 @.REP piece of character...@> 2539 end 2540 2541 @ @<Make sure that |c| is not the largest element of a charlist cycle@>= 2542 if char_tag[c]=list_tag then 2543 begin g:=char_remainder[c]; 2544 while (g<c)and(char_tag[g]=list_tag) do g:=char_remainder[g]; 2545 if g=c then 2546 begin char_tag[c]:=no_tag; 2547 print('A cycle of NEXTLARGER characters has been broken at '); 2548 @.A cycle of NEXTLARGER...@> 2549 print_octal(c); print_ln('.'); 2550 end; 2551 end 2552 2553 @ @<Glob...@>= 2554 @!delta:fix_word; {size of the intervals needed for rounding} 2555 2556 @ @d round_message(#)==if delta>0 then print_ln('I had to round some ', 2557 @.I had to round...@> 2558 #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.') 2559 2560 @<Put the width, height, depth, and italic lists into final form@>= 2561 delta:=shorten(width,255); set_indices(width,delta); round_message('width');@/ 2562 delta:=shorten(height,15); set_indices(height,delta); round_message('height');@/ 2563 delta:=shorten(depth,15); set_indices(depth,delta); round_message('depth');@/ 2564 delta:=shorten(italic,63); set_indices(italic,delta); 2565 round_message('italic correction'); 2566 2567 @ @d clear_lig_kern_entry== {make an unconditional \.{STOP}} 2568 lig_kern[nl].b0:=255; lig_kern[nl].b1:=0; 2569 lig_kern[nl].b2:=0; lig_kern[nl].b3:=0 2570 2571 @<Make sure the ligature/kerning program ends...@>= 2572 begin if bchar_label<@'77777 then {make room for it} 2573 begin clear_lig_kern_entry; incr(nl); 2574 end; {|bchar_label| will be stored later} 2575 while min_nl>nl do 2576 begin clear_lig_kern_entry; incr(nl); 2577 end; 2578 if lig_kern[nl-1].b0=0 then lig_kern[nl-1].b0:=stop_flag; 2579 end 2580 2581 @ It's not trivial to check for infinite loops generated by repeated 2582 insertion of ligature characters. But fortunately there is a nice 2583 algorithm for such testing, copied here from the program \.{TFtoPL} 2584 where it is explained further. 2585 2586 @d simple=0 {$f(x,y)=z$} 2587 @d left_z=1 {$f(x,y)=f(z,y)$} 2588 @d right_z=2 {$f(x,y)=f(x,z)$} 2589 @d both_z=3 {$f(x,y)=f(f(x,z),y)$} 2590 @d pending=4 {$f(x,y)$ is being evaluated} 2591 2592 2593 @ @<Glo...@>= 2594 @!lig_ptr:0..max_lig_steps; {an index into |lig_kern|} 2595 @!hash:array[0..hash_size] of 0..66048; {$256x+y+1$ for $x\le257$ and $y\le255$} 2596 @!class:array[0..hash_size] of simple..pending; 2597 @!lig_z:array[0..hash_size] of 0..257; 2598 @!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|} 2599 @!hash_list:array[0..hash_size] of 0..hash_size; {list of those nonzero entries} 2600 @!h,@!hh:0..hash_size; {indices into the hash table} 2601 @!tt:indx; {temporary register} 2602 @!x_lig_cycle,@!y_lig_cycle:0..256; {problematic ligature pair} 2603 2604 @ @<Set init...@>= 2605 hash_ptr:=0; y_lig_cycle:=256; 2606 for k:=0 to hash_size do hash[k]:=0; 2607 2608 @ @d lig_exam==lig_kern[lig_ptr].b1 2609 @d lig_gen==lig_kern[lig_ptr].b3 2610 2611 @<Check lig...@>= 2612 begin lig_ptr:=char_remainder[c]; 2613 repeat if hash_input(lig_ptr,c) then 2614 begin if lig_kern[lig_ptr].b2<kern_flag then 2615 begin if lig_exam<>bchar then 2616 check_existence(lig_exam)('LIG character examined by'); 2617 @.LIG character examined...@> 2618 check_existence(lig_gen)('LIG character generated by'); 2619 @.LIG character generated...@> 2620 if lig_gen>=128 then if(c<128)or(c=256) then 2621 if(lig_exam<128)or(lig_exam=bchar) then seven_unsafe:=true; 2622 end 2623 else if lig_exam<>bchar then 2624 check_existence(lig_exam)('KRN character examined by'); 2625 @.KRN character examined...@> 2626 end; 2627 if lig_kern[lig_ptr].b0>=stop_flag then lig_ptr:=nl 2628 else lig_ptr:=lig_ptr+1+lig_kern[lig_ptr].b0; 2629 until lig_ptr>=nl; 2630 end 2631 2632 @ The |hash_input| procedure is copied from \.{TFtoPL}, but it is made 2633 into a boolean function that returns |false| if the ligature command 2634 was masked by a previous one. 2635 2636 @p function hash_input(@!p,@!c:indx):boolean; 2637 {enter data for character |c| and command in location |p|, unless it isn't new} 2638 label 30; {go here for a quick exit} 2639 var @!cc:simple..both_z; {class of data being entered} 2640 @!zz:0..255; {function value or ligature character being entered} 2641 @!y:0..255; {the character after the cursor} 2642 @!key:integer; {value to be stored in |hash|} 2643 @!t:integer; {temporary register for swapping} 2644 begin if hash_ptr=hash_size then 2645 begin hash_input:=false; goto 30;@+end; 2646 @<Compute the command parameters |y|, |cc|, and |zz|@>; 2647 key:=256*c+y+1; h:=(1009*key) mod hash_size; 2648 while hash[h]>0 do 2649 begin if hash[h]<=key then 2650 begin if hash[h]=key then 2651 begin hash_input:=false; goto 30; {unused ligature command} 2652 end; 2653 t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion} 2654 t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap} 2655 t:=lig_z[h]; lig_z[h]:=zz; zz:=t; 2656 end; 2657 if h>0 then decr(h)@+else h:=hash_size; 2658 end; 2659 hash[h]:=key; class[h]:=cc; lig_z[h]:=zz; 2660 incr(hash_ptr); hash_list[hash_ptr]:=h; 2661 hash_input:=true; 2662 30:end; 2663 2664 @ @<Compute the command param...@>= 2665 y:=lig_kern[p].b1; t:=lig_kern[p].b2; cc:=simple; 2666 zz:=lig_kern[p].b3; 2667 if t>=kern_flag then zz:=y 2668 else begin case t of 2669 0,6:do_nothing; {\.{LIG},\.{/LIG>}} 2670 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}} 2671 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}} 2672 2:cc:=right_z; {\.{/LIG}} 2673 3:cc:=both_z; {\.{/LIG/}} 2674 end; {there are no other cases} 2675 end 2676 2677 @ (More good stuff from \.{TFtoPL}.) 2678 2679 @p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@> 2680 {compute $f$ for arguments known to be in |hash[h]|} 2681 function eval(@!x,@!y:indx):indx; {compute $f(x,y)$ with hashtable lookup} 2682 var @!key:integer; {value sought in hash table} 2683 begin key:=256*x+y+1; h:=(1009*key) mod hash_size; 2684 while hash[h]>key do 2685 if h>0 then decr(h)@+else h:=hash_size; 2686 if hash[h]<key then eval:=y {not in ordered hash table} 2687 else eval:=f(h,x,y); 2688 end; 2689 2690 @ Pascal's beastly convention for |forward| declarations prevents us from 2691 saying |function f(h,x,y:indx):indx| here. 2692 2693 @p function f; 2694 begin case class[h] of 2695 simple: do_nothing; 2696 left_z: begin class[h]:=pending; lig_z[h]:=eval(lig_z[h],y); class[h]:=simple; 2697 end; 2698 right_z: begin class[h]:=pending; lig_z[h]:=eval(x,lig_z[h]); class[h]:=simple; 2699 end; 2700 both_z: begin class[h]:=pending; lig_z[h]:=eval(eval(x,lig_z[h]),y); 2701 class[h]:=simple; 2702 end; 2703 pending: begin x_lig_cycle:=x; y_lig_cycle:=y; lig_z[h]:=257; class[h]:=simple; 2704 end; {the value 257 will break all cycles, since it's not in |hash|} 2705 end; {there are no other cases} 2706 f:=lig_z[h]; 2707 end; 2708 2709 @ @<Check for infinite...@>= 2710 if hash_ptr<hash_size then for hh:=1 to hash_ptr do 2711 begin tt:=hash_list[hh]; 2712 if class[tt]>simple then {make sure $f$ is well defined} 2713 tt:=f(tt,(hash[tt]-1)div 256,(hash[tt]-1)mod 256); 2714 end; 2715 if(hash_ptr=hash_size)or(y_lig_cycle<256) then 2716 begin if hash_ptr<hash_size then 2717 begin print('Infinite ligature loop starting with '); 2718 @.Infinite ligature loop...@> 2719 if x_lig_cycle=256 then print('boundary')@+else print_octal(x_lig_cycle); 2720 print(' and '); print_octal(y_lig_cycle); print_ln('!'); 2721 end 2722 else print_ln('Sorry, I haven''t room for so many ligature/kern pairs!'); 2723 @.Sorry, I haven't room...@> 2724 print_ln('All ligatures will be cleared.'); 2725 for c:=0 to 255 do if char_tag[c]=lig_tag then 2726 begin char_tag[c]:=no_tag; char_remainder[c]:=0; 2727 end; 2728 nl:=0; bchar:=256; bchar_label:=@'77777; 2729 end 2730 2731 @ The lig/kern program may still contain references to nonexistent characters, 2732 if parts of that program are never used. Similarly, there may be extensible 2733 characters that are never used, because they were overridden by 2734 \.{NEXTLARGER}, say. This would produce an invalid \.{TFM} file; so we 2735 must fix such errors. 2736 2737 @d double_check_tail(#)==@t\1@>if char_wd[0]=0 2738 then char_wd[0]:=sort_in(width,0); 2739 print('Unused ',#,' refers to nonexistent character '); 2740 print_octal(c); print_ln('!'); 2741 end; 2742 end 2743 @d double_check_lig(#)==begin c:=lig_kern[lig_ptr].#; 2744 if char_wd[c]=0 then if c<>bchar then 2745 begin lig_kern[lig_ptr].#:=0; double_check_tail 2746 @d double_check_ext(#)==begin c:=exten[g].#; 2747 if c>0 then if char_wd[c]=0 then 2748 begin exten[g].#:=0; double_check_tail 2749 @d double_check_rep(#)==begin c:=exten[g].#; 2750 if char_wd[c]=0 then 2751 begin exten[g].#:=0; double_check_tail 2752 2753 @<Doublecheck...@>= 2754 if nl>0 then for lig_ptr:=0 to nl-1 do 2755 if lig_kern[lig_ptr].b2<kern_flag then 2756 begin if lig_kern[lig_ptr].b0<255 then 2757 begin double_check_lig(b1)('LIG step'); double_check_lig(b3)('LIG step'); 2758 end; 2759 end 2760 else double_check_lig(b1)('KRN step'); 2761 @.Unused LIG step...@> 2762 @.Unused KRN step...@> 2763 if ne>0 then for g:=0 to ne-1 do 2764 begin double_check_ext(b0)('VARCHAR TOP'); 2765 double_check_ext(b1)('VARCHAR MID'); 2766 double_check_ext(b2)('VARCHAR BOT'); 2767 double_check_rep(b3)('VARCHAR REP'); 2768 @.Unused VARCHAR...@> 2769 end 2770 2771 @* The TFM output phase. 2772 Now that we know how to get all of the font data correctly stored in 2773 \.{VPtoVF}'s memory, it only remains to write the answers out. 2774 2775 First of all, it is convenient to have an abbreviation for output to the 2776 \.{TFM} file: 2777 2778 @d out(#)==write(tfm_file,#) 2779 2780 @ The general plan for producing \.{TFM} files is long but simple: 2781 2782 @<Do the \.{TFM} output@>= 2783 @<Compute the twelve subfile sizes@>; 2784 @<Output the twelve subfile sizes@>; 2785 @<Output the header block@>; 2786 @<Output the character info@>; 2787 @<Output the dimensions themselves@>; 2788 @<Output the ligature/kern program@>; 2789 @<Output the extensible character recipes@>; 2790 @<Output the parameters@> 2791 2792 @ A \.{TFM} file begins with 12 numbers that tell how big its subfiles are. 2793 We already know most of these numbers; for example, the number of distinct 2794 widths is |memory[width]+1|, where the $+1$ accounts for the zero width that 2795 is always supposed to be present. But we still should compute the beginning 2796 and ending character codes (|bc| and |ec|), the number of header words (|lh|), 2797 and the total number of words in the \.{TFM} file (|lf|). 2798 2799 @<Gl...@>= 2800 @!bc:byte; {the smallest character code in the font} 2801 @!ec:byte; {the largest character code in the font} 2802 @!lh:byte; {the number of words in the header block} 2803 @!lf:0..32767; {the number of words in the entire \.{TFM} file} 2804 @!not_found:boolean; {has a font character been found?} 2805 @!temp_width:fix_word; {width being used to compute a check sum} 2806 2807 @ It might turn out that no characters exist at all. But \.{VPtoVF} keeps 2808 going and writes the \.{TFM} anyway. In this case |ec| will be~0 and |bc| 2809 will be~1. 2810 2811 @<Compute the twelve...@>= 2812 lh:=header_ptr div 4;@/ 2813 not_found:=true; bc:=0; 2814 while not_found do 2815 if (char_wd[bc]>0)or(bc=255) then not_found:=false 2816 else incr(bc); 2817 not_found:=true; ec:=255; 2818 while not_found do 2819 if (char_wd[ec]>0)or(ec=0) then not_found:=false 2820 else decr(ec); 2821 if bc>ec then bc:=1; 2822 incr(memory[width]); incr(memory[height]); incr(memory[depth]); 2823 incr(memory[italic]);@/ 2824 @<Compute the ligature/kern program offset@>; 2825 lf:=6+lh+(ec-bc+1)+memory[width]+memory[height]+memory[depth]+ 2826 memory[italic]+nl+lk_offset+nk+ne+np; 2827 2828 @ @d out_size(#)==out((#) div 256); out((#) mod 256) 2829 2830 @<Output the twelve subfile sizes@>= 2831 out_size(lf); out_size(lh); out_size(bc); out_size(ec); 2832 out_size(memory[width]); out_size(memory[height]); 2833 out_size(memory[depth]); out_size(memory[italic]); 2834 out_size(nl+lk_offset); out_size(nk); out_size(ne); out_size(np); 2835 2836 @ The routines that follow need a few temporary variables of different types. 2837 2838 @<Gl...@>= 2839 @!j:0..max_header_bytes; {index into |header_bytes|} 2840 @!p:pointer; {index into |memory|} 2841 @!q:width..italic; {runs through the list heads for dimensions} 2842 @!par_ptr:0..max_param_words; {runs through the parameters} 2843 2844 @ The header block follows the subfile sizes. The necessary information all 2845 appears in |header_bytes|, except that the design size and the seven-bit-safe 2846 flag must still be set. 2847 2848 @<Output the header block@>= 2849 if not check_sum_specified then @<Compute the check sum@>; 2850 header_bytes[design_size_loc]:=design_size div @'100000000; 2851 {this works since |design_size>0|} 2852 header_bytes[design_size_loc+1]:=(design_size div @'200000) mod 256; 2853 header_bytes[design_size_loc+2]:=(design_size div 256) mod 256; 2854 header_bytes[design_size_loc+3]:=design_size mod 256; 2855 if not seven_unsafe then header_bytes[seven_flag_loc]:=128; 2856 for j:=0 to header_ptr-1 do out(header_bytes[j]); 2857 2858 @ @<Compute the check sum@>= 2859 begin c0:=bc; c1:=ec; c2:=bc; c3:=ec; 2860 for c:=bc to ec do if char_wd[c]>0 then 2861 begin temp_width:=memory[char_wd[c]]; 2862 if design_units<>unity then 2863 temp_width:=round((temp_width/design_units)*1048576.0); 2864 temp_width:=temp_width + (c+4)*@'20000000; {this should be positive} 2865 c0:=(c0+c0+temp_width) mod 255; 2866 c1:=(c1+c1+temp_width) mod 253; 2867 c2:=(c2+c2+temp_width) mod 251; 2868 c3:=(c3+c3+temp_width) mod 247; 2869 end; 2870 header_bytes[check_sum_loc]:=c0; 2871 header_bytes[check_sum_loc+1]:=c1; 2872 header_bytes[check_sum_loc+2]:=c2; 2873 header_bytes[check_sum_loc+3]:=c3; 2874 end 2875 2876 @ The next block contains packed |char_info|. 2877 2878 @<Output the character info@>= 2879 index[0]:=0; 2880 for c:=bc to ec do 2881 begin out(index[char_wd[c]]); 2882 out(index[char_ht[c]]*16+index[char_dp[c]]); 2883 out(index[char_ic[c]]*4+char_tag[c]); 2884 out(char_remainder[c]); 2885 end 2886 2887 @ When a scaled quantity is output, we may need to divide it by |design_units|. 2888 The following subroutine takes care of this, using floating point arithmetic 2889 only if |design_units<>1.0|. 2890 2891 @p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|} 2892 var @!n:byte; {the first byte after the sign} 2893 @!m:0..65535; {the two least significant bytes} 2894 begin if abs(x/design_units)>=16.0 then 2895 begin print_ln('The relative dimension ',x/@'4000000:1:3, 2896 ' is too large.'); 2897 @.The relative dimension...@> 2898 print(' (Must be less than 16*designsize'); 2899 if design_units<>unity then print(' =',design_units/@'200000:1:3, 2900 ' designunits'); 2901 print_ln(')'); x:=0; 2902 end; 2903 if design_units<>unity then x:=round((x/design_units)*1048576.0); 2904 if x<0 then 2905 begin out(255); x:=x+@'100000000; 2906 if x<=0 then x:=1; 2907 end 2908 else begin out(0); 2909 if x>=@'100000000 then x:=@'77777777; 2910 end; 2911 n:=x div @'200000; m:=x mod @'200000; 2912 out(n); out(m div 256); out(m mod 256); 2913 end; 2914 2915 @ We have output the packed indices for individual characters. 2916 The scaled widths, heights, depths, and italic corrections are next. 2917 2918 @<Output the dimensions themselves@>= 2919 for q:=width to italic do 2920 begin out(0); out(0); out(0); out(0); {output the zero word} 2921 p:=link[q]; {head of list} 2922 while p>0 do 2923 begin out_scaled(memory[p]); 2924 p:=link[p]; 2925 end; 2926 end; 2927 2928 @ One embarrassing problem remains: The ligature/kern program might be very 2929 long, but the starting addresses in |char_remainder| can be at most~255. 2930 Therefore we need to output some indirect address information; we want to 2931 compute |lk_offset| so that addition of |lk_offset| to all remainders makes 2932 all but |lk_offset| distinct remainders less than~256. 2933 2934 For this we need a sorted table of all relevant remainders. 2935 2936 @<Glob...@>= 2937 @!label_table:array[0..256] of record 2938 @!rr: -1..@'77777; {sorted label values} 2939 @!cc: byte; {associated characters} 2940 end; 2941 @!label_ptr:0..256; {index of highest entry in |label_table|} 2942 @!sort_ptr:0..256; {index into |label_table|} 2943 @!lk_offset:0..256; {smallest offset value that might work} 2944 @!t:0..@'77777; {label value that is being redirected} 2945 @!extra_loc_needed:boolean; {do we need a special word for |bchar|?} 2946 2947 @ @<Compute the ligature/kern program offset@>= 2948 @<Insert all labels into |label_table|@>; 2949 if bchar<256 then 2950 begin extra_loc_needed:=true; lk_offset:=1; 2951 end 2952 else begin extra_loc_needed:=false; lk_offset:=0; 2953 end; 2954 @<Find the minimum |lk_offset| and adjust all remainders@>; 2955 if bchar_label<@'77777 then 2956 begin lig_kern[nl-1].b2:=(bchar_label+lk_offset)div 256; 2957 lig_kern[nl-1].b3:=(bchar_label+lk_offset)mod 256; 2958 end 2959 2960 @ @<Insert all labels...@>= 2961 label_ptr:=0; label_table[0].rr:=-1; {sentinel} 2962 for c:=bc to ec do if char_tag[c]=lig_tag then 2963 begin sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|} 2964 while label_table[sort_ptr].rr>char_remainder[c] do 2965 begin label_table[sort_ptr+1]:=label_table[sort_ptr]; 2966 decr(sort_ptr); {move the hole} 2967 end; 2968 label_table[sort_ptr+1].cc:=c; 2969 label_table[sort_ptr+1].rr:=char_remainder[c]; 2970 incr(label_ptr); 2971 end 2972 2973 @ @<Find the minimum |lk_offset| and adjust all remainders@>= 2974 begin sort_ptr:=label_ptr; {the largest unallocated label} 2975 if label_table[sort_ptr].rr+lk_offset > 255 then 2976 begin lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty} 2977 repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset; 2978 while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do 2979 begin decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset; 2980 end; 2981 incr(lk_offset); decr(sort_ptr); 2982 until lk_offset+label_table[sort_ptr].rr<256; 2983 {N.B.: |lk_offset=256| satisfies this when |sort_ptr=0|} 2984 end; 2985 if lk_offset>0 then while sort_ptr>0 do 2986 begin char_remainder[label_table[sort_ptr].cc]:= 2987 char_remainder[label_table[sort_ptr].cc]+lk_offset; 2988 decr(sort_ptr); 2989 end; 2990 end 2991 2992 @ @<Output the ligature/kern program@>= 2993 if extra_loc_needed then {|lk_offset=1|} 2994 begin out(255); out(bchar); out(0); out(0); 2995 end 2996 else for sort_ptr:=1 to lk_offset do {output the redirection specs} 2997 begin t:=label_table[label_ptr].rr; 2998 if bchar<256 then 2999 begin out(255); out(bchar); 3000 end 3001 else begin out(254); out(0); 3002 end; 3003 out_size(t+lk_offset); 3004 repeat decr(label_ptr); until label_table[label_ptr].rr<t; 3005 end; 3006 if nl>0 then for lig_ptr:=0 to nl-1 do 3007 begin out(lig_kern[lig_ptr].b0); 3008 out(lig_kern[lig_ptr].b1); 3009 out(lig_kern[lig_ptr].b2); 3010 out(lig_kern[lig_ptr].b3); 3011 end; 3012 if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr]) 3013 3014 @ @<Output the extensible character recipes@>= 3015 if ne>0 then for c:=0 to ne-1 do 3016 begin out(exten[c].b0); 3017 out(exten[c].b1); 3018 out(exten[c].b2); 3019 out(exten[c].b3); 3020 end; 3021 3022 @ For our grand finale, we wind everything up by outputting the parameters. 3023 3024 @<Output the parameters@>= 3025 for par_ptr:=1 to np do 3026 begin if par_ptr=1 then 3027 @<Output the slant (|param[1]|) without scaling@> 3028 else out_scaled(param[par_ptr]); 3029 end 3030 3031 @ @<Output the slant...@>= 3032 begin if param[1]<0 then 3033 begin param[1]:=param[1]+@'10000000000; 3034 out((param[1] div @'100000000)+256-64); 3035 end 3036 else out(param[1] div @'100000000); 3037 out((param[1] div @'200000) mod 256); 3038 out((param[1] div 256) mod 256); 3039 out(param[1] mod 256); 3040 end 3041 3042 @* The VF output phase. 3043 Output to |vf_file| is considerably simpler. 3044 3045 @d id_byte=202 {current version of \.{VF} format} 3046 @d vout(#)==write(vf_file,#) 3047 3048 @<Glob...@>= 3049 @!vcount:integer; {number of bytes written to |vf_file|} 3050 3051 @ We need a routine to output integers as four bytes. Negative values 3052 will never be less than $-2^{24}$. 3053 3054 @p procedure vout_int(@!x:integer); 3055 begin if x>=0 then vout(x div @'100000000) 3056 else begin vout(255); x:=x+@'100000000; 3057 end; 3058 vout((x div @'200000) mod 256); 3059 vout((x div @'400) mod 256); vout(x mod 256); 3060 end; 3061 3062 @ @<Do the \.{VF} output@>= 3063 vout(pre); vout(id_byte); vout(vtitle_length); 3064 for k:=0 to vtitle_length-1 do vout(vf[vtitle_start+k]); 3065 for k:=check_sum_loc to design_size_loc+3 do vout(header_bytes[k]); 3066 vcount:=vtitle_length+11; 3067 for cur_font:=0 to font_ptr-1 do @<Output a local font definition@>; 3068 for c:=bc to ec do if char_wd[c]>0 then 3069 @<Output a packet for character |c|@>; 3070 repeat vout(post); incr(vcount); 3071 until vcount mod 4 = 0 3072 3073 @ @<Output a local font definition@>= 3074 begin vout(fnt_def1); vout(cur_font);@/ 3075 vout(font_checksum[cur_font].b0); 3076 vout(font_checksum[cur_font].b1); 3077 vout(font_checksum[cur_font].b2); 3078 vout(font_checksum[cur_font].b3); 3079 vout_int(font_at[cur_font]); 3080 vout_int(font_dsize[cur_font]); 3081 vout(farea_length[cur_font]); 3082 vout(fname_length[cur_font]); 3083 for k:=0 to farea_length[cur_font]-1 do vout(vf[farea_start[cur_font]+k]); 3084 if fname_start[cur_font]=vf_size then 3085 begin vout("N"); vout("U"); vout("L"); vout("L"); 3086 end 3087 else for k:=0 to fname_length[cur_font]-1 do vout(vf[fname_start[cur_font]+k]); 3088 vcount:=vcount+12+farea_length[cur_font]+fname_length[cur_font]; 3089 end 3090 3091 @ @<Output a packet for character |c|@>= 3092 begin x:=memory[char_wd[c]]; 3093 if design_units<>unity then x:=round((x/design_units)*1048576.0); 3094 if (packet_length[c]>241)or(x<0)or(x>=@'100000000) then 3095 begin vout(242); vout_int(packet_length[c]); vout_int(c); vout_int(x); 3096 vcount:=vcount+13+packet_length[c]; 3097 end 3098 else begin vout(packet_length[c]); vout(c); vout(x div @'200000); 3099 vout((x div @'400) mod 256); vout(x mod 256); 3100 vcount:=vcount+5+packet_length[c]; 3101 end; 3102 if packet_start[c]=vf_size then 3103 begin if c>=128 then vout(set1); 3104 vout(c); 3105 end 3106 else for k:=0 to packet_length[c]-1 do vout(vf[packet_start[c]+k]); 3107 end 3108 3109 @* The main program. 3110 The routines sketched out so far need to be packaged into separate procedures, 3111 on some systems, since some \PASCAL\ compilers place a strict limit on the 3112 size of a routine. The packaging is done here in an attempt to avoid some 3113 system-dependent changes. 3114 3115 @p procedure param_enter; 3116 begin @<Enter the parameter names@>; 3117 end; 3118 @# 3119 procedure vpl_enter; 3120 begin @<Enter all the \.{VPL} names@>; 3121 end; 3122 @# 3123 procedure name_enter; {enter all names and their equivalents} 3124 begin @<Enter all the \.{PL} names...@>; 3125 vpl_enter; param_enter; 3126 end; 3127 @# 3128 procedure read_lig_kern; 3129 var @!krn_ptr:0..max_kerns; {an index into |kern|} 3130 @!c:byte; {runs through all character codes} 3131 begin @<Read ligature/kern list@>; 3132 end; 3133 @# 3134 procedure read_char_info; 3135 var @!c:byte; {the char} 3136 begin @<Read character info list@>; 3137 end; 3138 @# 3139 procedure read_input; 3140 var @!c:byte; {header or parameter index} 3141 begin @<Read all the input@>; 3142 end; 3143 @# 3144 procedure corr_and_check; 3145 var @!c:0..256; {runs through all character codes} 3146 @!hh:0..hash_size; {an index into |hash_list|} 3147 @!lig_ptr:0..max_lig_steps; {an index into |lig_kern|} 3148 @!g:byte; {a character generated by the current character |c|} 3149 begin @<Correct and check the information@> 3150 end; 3151 @# 3152 procedure vf_output; 3153 var @!c:byte; {runs through all character codes} 3154 @!cur_font:0..256; {runs through all local fonts} 3155 @!k:integer; {loop index} 3156 begin @<Do the \.{VF} output@>; 3157 end; 3158 3159 @ Here is where \.{VPtoVF} begins and ends. 3160 3161 @p begin initialize;@/ 3162 name_enter;@/ 3163 read_input; print_ln('.');@/ 3164 corr_and_check;@/ 3165 @<Do the \.{TFM} output@>; 3166 vf_output; 3167 end. 3168 3169 @* System-dependent changes. 3170 This section should be replaced, if necessary, by changes to the program 3171 that are necessary to make \.{VPtoVF} work at a particular installation. 3172 It is usually best to design your change file so that all changes to 3173 previous sections preserve the section numbering; then everybody's version 3174 will be consistent with the printed program. More extensive changes, 3175 which introduce new sections, can be inserted here; then only the index 3176 itself will get a new section number. 3177 @^system dependencies@> 3178 3179 @* Index. 3180 Pointers to error messages appear here together with the section numbers 3181 where each ident\-i\-fier is used.