From 487ca4806cc046076293cf6cc5fbba0db282bac7 Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Tue, 17 Jan 2006 21:41:51 +0000 Subject: texk 1 git-svn-id: svn://tug.org/texlive/trunk@1485 c570f23f-e606-0410-a88d-b1316a301751 --- Build/source/texk/web2c/omegaware/opl2ofm.web | 4363 +++++++++++++++++++++++++ 1 file changed, 4363 insertions(+) create mode 100644 Build/source/texk/web2c/omegaware/opl2ofm.web (limited to 'Build/source/texk/web2c/omegaware/opl2ofm.web') diff --git a/Build/source/texk/web2c/omegaware/opl2ofm.web b/Build/source/texk/web2c/omegaware/opl2ofm.web new file mode 100644 index 00000000000..df91a25dfee --- /dev/null +++ b/Build/source/texk/web2c/omegaware/opl2ofm.web @@ -0,0 +1,4363 @@ +% +% This file is part of the Omega project, which +% is based in the web2c distribution of TeX. +% +% Copyright (c) 1994--2000 John Plaice and Yannis Haralambous +% applies only to the changes to the original pltotf.web +% +% This program by D. E. Knuth is not copyrighted and can be used freely. +% Version 0 was implemented in January 1982. +% In February 1982 a new restriction on ligature steps was added. +% In June 1982 the routines were divided into smaller pieces for IBM people. +% Hex was added in September 1982, and the result became "Version 1". +% Version 1.1 fixed a bug in section 28 (since eoln is undefined after eof). +% Slight changes were made in October, 1982, for version 0.6 of TeX. +% Version 1.2 fixed a bug in section 115 (TOP, MID, and BOT can be zero) +% Version 1.3 (April 1983) blanked out unused BCPL header bytes +% Version 2 (July 1983) was released with TeX version 0.999. +% Version 2.1 (September 1983) changed TEXINFO to FONTDIMEN. +% Version 2.2 (May 1985) added checksum computation to match METAFONT. +% Version 2.3 (August 1985) introduced `backup' to fix a minor bug. +% Version 3 (October 1989) introduced extended ligature features. +% Version 3.1 (November 1989) fixed two bugs (notably min_nl:=0). +% Version 3.2 (December 1989) improved `shorten', increased max_letters. +% Version 3.3 (September 1990) fixed `nonexistent char 0' (John Gourlay). +% Version 3.4 (March 1991) has more robust `out_scaled' (Wayne Sullivan). +% Version 3.5 (March 1995) initialized lk_step_ended (Armin K\"ollner). + +% Version 1.0 of OPL2OFM (March 1997) allows one to read OPL files +% and generate OFM files. + +% Here is TeX material that gets inserted after \input webmac +\def\hang{\hangindent 3em\indent\ignorespaces} +\font\ninerm=cmr9 +\let\mc=\ninerm % medium caps for names like SAIL +\def\PASCAL{Pascal} +\font\logo=logo10 % for the METAFONT logo +\def\MF{{\logo METAFONT}} + +\def\(#1){} % this is used to make section names sort themselves better +\def\9#1{} % this is used for sort keys in the index + +\def\title{OPL2OFM} +\def\contentspagenumber{301} +\def\topofcontents{\null + \def\titlepage{F} % include headline on the contents page + \def\rheader{\mainfont\hfil \contentspagenumber} + \vfill + \centerline{\titlefont The {\ttitlefont OPL2OFM} processor} + \vskip 15pt + \centerline{(Version 1.11, February 2000)} + \vfill} +\def\botofcontents{\vfill + \centerline{\hsize 5in\baselineskip9pt + \vbox{\ninerm\noindent + The preparation of the original report + was supported in part by the National Science + Foundation under grants IST-8201926 and MCS-8300984, + and by the System Development Foundation. `\TeX' is a + trademark of the American Mathematical Society.}}} +\pageno=\contentspagenumber \advance\pageno by 1 + +@* Introduction. +The \.{OPL2OFM} utility program converts property-list (``\.{PL}'' +and (``\.{OPL}'') files into equivalent \TeX\ and $\Omega$ font metric +(``\.{TFM}'' and ``\.{OFM}) files. It also makes a thorough check of +the given \.{PL} or \.{OPL} file, so that the \.{TFM} or \.{OFM} file +should be acceptable to \TeX\ or $\Omega$. + +The first \.{PLtoTF} program was designed by Leo Guibas in the summer of +1978. Contributions by Frank Liang, Doug Wyatt, and Lyle Ramshaw +also had a significant effect on the evolution of the present code. + +Extensions for an enhanced ligature mechanism were added by D. E. Knuth +in 1989. + +Extensions to handle extended font metric files (``\.{OFM}'') were +added by John Plaice in December 1995 and January 1996, resulting in the +new program \.{OPLtoOFM}. In the following documentation, all unchanged +references to the \.{PLtoTF} program and to \.{TFM} and \.{PL} files also +apply to the \.{OPLtoOFM} program and to \.{OFM} and \.{OPL} files. + +The |banner| string defined here should be changed whenever \.{OPLtoOFM} +gets modified. + +@d banner=='This is OPL2OFM, Version 1.11' + +@ This program is written entirely in standard \PASCAL, except that +it has to do some slightly system-dependent character code conversion +on input. Furthermore, lower case letters are used in error messages; +they could be converted to upper case if necessary. The input is read +from |pl_file|, and the output is written on |tfm_file|; error messages and +other remarks are written on the |output| file, which the user may +choose to assign to the terminal if the system permits it. +@^system dependencies@> + +The term |print| is used instead of |write| when this program writes on +the |output| file, so that all such output can be easily deflected. + +@d print(#)==write(#) +@d print_ln(#)==write_ln(#) + +@p program OPL2OFM(@!pl_file,@!tfm_file,@!output); +const @@/ +type @@/ +var @@/ +procedure initialize; {this procedure gets things started properly} + var @@/ + begin print_ln(banner);@/ + @@/ + end; + +@ The following parameters can be changed at compile time to extend or +reduce \.{PLtoTF}'s capacity. + +@= +@!buf_size=60; {length of lines displayed in error messages} +@!max_header_bytes=100; {four times the maximum number of words allowed in + the \.{TFM} file header block, must be 1024 or less} +@!max_param_words=100; {the maximum number of \.{fontdimen} parameters allowed} +@!max_lig_steps=800000; + {maximum length of ligature program, must be at most $32767-257=32510$} +@!xmax_label=800001; +@!max_kerns=50000; {the maximum number of distinct kern values} +@!hash_size=130003; {preferably a prime number, a bit larger than the number + of character pairs in lig/kern steps} +@!hash_mult=16007; {another prime} +@!tfm_size=2000000; {maximum length of |tfm| data, in bytes} +@!lig_size=800000; {maximum length of |lig_kern| program, in words} +@!max_char=65535; {the largest character number in a font} +@!xmax_char=65536; {|max_char|+1} +@!xxmax_char=65537;{|max_char|+2} +@!xxxmax_char=65538;{|max_char|+3} +@!mem_size=262144; {|max_char|*4+8} +@!max_width=65535; {the largest character width number} +@!max_height=255; {the largest character height number} +@!max_depth=255; {the largest character depth number} +@!max_italic=255; {the largest character italic correction number} + +@ Here are some macros for common programming idioms. + +@d incr(#) == #:=#+1 {increase a variable by unity} +@d decr(#) == #:=#-1 {decrease a variable by unity} +@d do_nothing == {empty statement} + +@* Property list description of font metric data. +The idea behind \.{PL} files is that precise details about fonts, i.e., the +facts that are needed by typesetting routines like \TeX, sometimes have to +be supplied by hand. The nested property-list format provides a reasonably +convenient way to do this. + +A good deal of computation is necessary to parse and process a +\.{PL} file, so it would be inappropriate for \TeX\ itself to do this +every time it loads a font. \TeX\ deals only with the compact descriptions +of font metric data that appear in \.{TFM} files. Such data is so compact, +however, it is almost impossible for anybody but a computer to read it. +The purpose of \.{PLtoTF} is to convert from a human-oriented file of text +to a computer-oriented file of binary numbers. + +@= +@!pl_file:text; + +@ @= +reset(pl_file); + +@ A \.{PL} file is a list of entries of the form +$$\.{(PROPERTYNAME VALUE)}$$ +where the property name is one of a finite set of names understood by +this program, and the value may itself in turn be a property list. +The idea is best understood by looking at an example, so let's consider +a fragment of the \.{PL} file for a hypothetical font. +$$\vbox{\halign{\.{#}\hfil\cr +(FAMILY NOVA)\cr +(FACE F MIE)\cr +(CODINGSCHEME ASCII)\cr +(DESIGNSIZE D 10)\cr +(DESIGNUNITS D 18)\cr +(COMMENT A COMMENT IS IGNORED)\cr +(COMMENT (EXCEPT THIS ONE ISN'T))\cr +(COMMENT (ACTUALLY IT IS, EVEN THOUGH\cr +\qquad\qquad IT SAYS IT ISN'T))\cr +(FONTDIMEN\cr +\qquad (SLANT R -.25)\cr +\qquad (SPACE D 6)\cr +\qquad (SHRINK D 2)\cr +\qquad (STRETCH D 3)\cr +\qquad (XHEIGHT R 10.55)\cr +\qquad (QUAD D 18)\cr +\qquad )\cr +(LIGTABLE\cr +\qquad (LABEL C f)\cr +\qquad (LIG C f O 200)\cr +\qquad (SKIP D 1)\cr +\qquad (LABEL O 200)\cr +\qquad (LIG C i O 201)\cr +\qquad (KRN O 51 R 1.5)\cr +\qquad (/LIG C ? C f)\cr +\qquad (STOP)\cr +\qquad )\cr +(CHARACTER C f\cr +\qquad (CHARWD D 6)\cr +\qquad (CHARHT R 13.5)\cr +\qquad (CHARIC R 1.5)\cr +\qquad )\cr}}$$ +This example says that the font whose metric information is being described +belongs to the hypothetical +\.{NOVA} family; its face code is medium italic extended; +and the characters appear in ASCII code positions. The design size is 10 points, +and all other sizes in this \.{PL} file are given in units such that 18 units +equals the design size. The font is slanted with a slope of $-.25$ (hence the +letters actually slant backward---perhaps that is why the family name is +\.{NOVA}). The normal space between words is 6 units (i.e., one third of +the 18-unit design size), with glue that shrinks by 2 units or stretches by 3. +The letters for which accents don't need to be raised or lowered are 10.55 +units high, and one em equals 18 units. + +The example ligature table is a bit trickier. It specifies that the +letter \.f followed by another \.f is changed to code @'200, while +code @'200 followed by \.i is changed to @'201; presumably codes @'200 +and @'201 represent the ligatures `ff' and `ffi'. Moreover, in both cases +\.f and @'200, if the following character is the code @'51 (which is a +right parenthesis), an additional 1.5 units of space should be inserted +before the @'51. (The `\.{SKIP}~\.D~\.1' skips over one \.{LIG} or +\.{KRN} command, which in this case is the second \.{LIG}; in this way +two different ligature/kern programs can come together.) +Finally, if either \.f or @'200 is followed by a question mark, +the question mark is replaced by \.f and the ligature program is +started over. (Thus, the character pair `\.{f?}' would actually become +the ligature `ff', and `\.{ff?}' or `\.{f?f}' would become `fff'. To +avoid this restart procedure, the \.{/LIG} command could be replaced +by \.{/LIG>}; then `\.{f?} would become `f\kern0ptf' and `\.{f?f}' +would become `f\kern0ptff'.) + +Character \.f itself is 6 units wide and 13.5 units tall, in this example. +Its depth is zero (since \.{CHARDP} is not given), and its italic correction +is 1.5 units. + +@ The example above illustrates most of the features found in \.{PL} files. +Note that some property names, like \.{FAMILY} or \.{COMMENT}, take a +string as their value; this string continues until the first unmatched +right parenthesis. But most property names, like \.{DESIGNSIZE} and \.{SLANT} +and \.{LABEL}, take a number as their value. This number can be expressed in +a variety of ways, indicated by a prefixed code; \.D stands for decimal, +\.H for hexadecimal, \.O for octal, \.R for real, \.C for character, and +\.F for ``face.'' Other property names, like \.{LIG}, take two numbers as +their value. And still other names, like \.{FONTDIMEN} and \.{LIGTABLE} and +\.{CHARACTER}, have more complicated values that involve property lists. + +A property name is supposed to be used only in an appropriate property +list. For example, \.{CHARWD} shouldn't occur on the outer level or +within \.{FONTDIMEN}. + +The individual property-and-value pairs in a property list can appear in +any order. For instance, `\.{SHRINK}' precedes `\.{STRETCH}' in the above +example, although the \.{TFM} file always puts the stretch parameter first. +One could even give the information about characters like `\.f' before +specifying the number of units in the design size, or before specifying the +ligature and kerning table. However, the \.{LIGTABLE} itself is an exception +to this rule; the individual elements of the \.{LIGTABLE} property list +can be reordered only to a certain extent without changing the meaning +of that table. + +If property-and-value pairs are omitted, a default value is used. For example, +we have already noted that the default for \.{CHARDP} is zero. The default +for {\sl every\/} numeric value is, in fact, zero, unless otherwise stated +below. + +If the same property name is used more than once, \.{PLtoTF} will not notice +the discrepancy; it simply uses the final value given. Once again, however, the +\.{LIGTABLE} is an exception to this rule; \.{PLtoTF} will complain if there +is more than one label for some character. And of course many of the +entries in the \.{LIGTABLE} property list have the same property name. + +From these rules, you can guess (correctly) that \.{PLtoTF} operates in four +main steps. First it assigns the default values to all properties; then it scans +through the \.{PL} file, changing property values as new ones are seen; then +it checks the information and corrects any problems; and finally it outputs +the \.{TFM} file. + +@ Instead of relying on a hypothetical example, let's consider a complete +grammar for \.{PL} files. At the outer level, the following property names +are valid: + +\yskip\hang\.{CHECKSUM} (four-byte value). The value, which should be a +nonnegative integer less than $2^{32}$, is used to identify a particular +version of a font; it should match the check sum value stored with the font +itself. An explicit check sum of zero is used to bypass +check sum testing. If no checksum is specified in the \.{PL} file, +\.{PLtoTF} will compute the checksum that \MF\ would compute from the +same data. + +\yskip\hang\.{DESIGNSIZE} (numeric value, default is 10). The value, which +should be a real number in the range |1.0<=x<2048|, represents the default +amount by which all quantities will be scaled if the font is not loaded +with an `\.{at}' specification. For example, if one says +`\.{\\font\\A=cmr10 at 15pt}' in \TeX\ language, the design size in the \.{TFM} +file is ignored and effectively replaced by 15 points; but if one simply +says `\.{\\font\\A=cmr10}' the stated design size is used. This quantity is +always in units of printer's points. + +\yskip\hang\.{DESIGNUNITS} (numeric value, default is 1). The value +should be a positive real number; it says how many units equals the design +size (or the eventual `\.{at}' size, if the font is being scaled). For +example, suppose you have a font that has been digitized with 600 pixels per +em, and the design size is one em; then you could say `\.{(DESIGNUNITS R 600)}' +if you wanted to give all of your measurements in units of pixels. + +\yskip\hang\.{CODINGSCHEME} (string value, default is `\.{UNSPECIFIED}'). +The string should not contain parentheses, and its length must be less than 40. +It identifies the correspondence between the numeric codes and font characters. +(\TeX\ ignores this information, but other software programs make use of it.) + +\yskip\hang\.{FAMILY} (string value, default is `\.{UNSPECIFIED}'). +The string should not contain parentheses, and its length must be less than 20. +It identifies the name of the family to which this font belongs, e.g., +`\.{HELVETICA}'. (\TeX\ ignores this information; but it is needed, for +example, when converting \.{DVI} files to \.{PRESS} files for Xerox +equipment.) + +\yskip\hang\.{FACE} (one-byte value). This number, which must lie between +0 and 255 inclusive, is a subsidiary ident\-ifi\-ca\-tion of the font within its +family. For example, bold italic condensed fonts might have the same family name +as light roman extended fonts, differing only in their face byte. (\TeX\ +ignores this information; but it is needed, for example, when converting +\.{DVI} files to \.{PRESS} files for Xerox equipment.) + +\yskip\hang\.{SEVENBITSAFEFLAG} (string value, default is `\.{FALSE}'). The +value should start with either `\.T' (true) or `\.F' (false). If true, character +codes less than 128 cannot lead to codes of 128 or more via ligatures or +charlists or extensible characters. (\TeX82 ignores this flag, but older +versions of \TeX\ would only accept \.{TFM} files that were seven-bit safe.) +\.{PLtoTF} computes the correct value of this flag and gives an error message +only if a claimed ``true'' value is incorrect. + +\yskip\hang\.{HEADER} (a one-byte value followed by a four-byte value). +The one-byte value should be between 18 and a maximum limit that can be +raised or lowered depending on the compile-time setting of |max_header_bytes|. +The four-byte value goes into the header word whose index is the one-byte +value; for example, to set |header[18]:=1|, one may write +`\.{(HEADER D 18 O 1)}'. This notation is used for header information that +is presently unnamed. (\TeX\ ignores it.) + +\yskip\hang\.{FONTDIMEN} (property list value). See below for the names +allowed in this property list. + +\yskip\hang\.{LIGTABLE} (property list value). See below for the rules +about this special kind of property list. + +\yskip\hang\.{BOUNDARYCHAR} (integer value). If this character appears in +a \.{LIGTABLE} command, it matches ``end of word'' as well as itself. +If no boundary character is given and no \.{LABEL} \.{BOUNDARYCHAR} occurs +within \.{LIGTABLE}, word boundaries will not affect ligatures or kerning. + +\yskip\hang\.{CHARACTER}. The value is an integer followed by +a property list. The integer represents the number of a character that is +present in the font; the property list of a character is defined below. +The default is an empty property list. + +@ Numeric property list values can be given in various forms identified by +a prefixed letter. + +\yskip\hang\.C denotes an ASCII character, which should be a standard visible +character that is not a parenthesis. The numeric value will therefore be +between @'41 and @'176 but not @'50 or @'51. + +\yskip\hang\.D denotes a decimal integer, which must be nonnegative and +less than 256. (Use \.R for larger values or for negative values.) + +\yskip\hang\.F denotes a three-letter Xerox face code; the admissible codes +are \.{MRR}, \.{MIR}, \.{BRR}, \.{BIR}, \.{LRR}, \.{LIR}, \.{MRC}, \.{MIC}, +\.{BRC}, \.{BIC}, \.{LRC}, \.{LIC}, \.{MRE}, \.{MIE}, \.{BRE}, \.{BIE}, +\.{LRE}, and \.{LIE}, denoting the integers 0 to 17, respectively. + +\yskip\hang\.O denotes an unsigned octal integer, which must be less than +$2^{32}$, i.e., at most `\.{O 37777777777}'. + +\yskip\hang\.H denotes an unsigned hexadecimal integer, which must be less than +$2^{32}$, i.e., at most `\.{H FFFFFFFF}'. + +\yskip\hang\.R denotes a real number in decimal notation, optionally preceded +by a `\.+' or `\.-' sign, and optionally including a decimal point. The +absolute value must be less than 2048. + +@ The property names allowed in a \.{FONTDIMEN} property list correspond to +various \TeX\ parameters, each of which has a (real) numeric value. All +of the parameters except \.{SLANT} are in design units. The admissible +names are \.{SLANT}, \.{SPACE}, \.{STRETCH}, \.{SHRINK}, \.{XHEIGHT}, +\.{QUAD}, \.{EXTRASPACE}, \.{NUM1}, \.{NUM2}, \.{NUM3}, \.{DENOM1}, +\.{DENOM2}, \.{SUP1}, \.{SUP2}, \.{SUP3}, \.{SUB1}, \.{SUB2}, \.{SUPDROP}, +\.{SUBDROP}, \.{DELIM1}, \.{DELIM2}, and \.{AXISHEIGHT}, for parameters +1~to~22. The alternate names \.{DEFAULTRULETHICKNESS}, +\.{BIGOPSPACING1}, \.{BIGOPSPACING2}, \.{BIGOPSPACING3}, +\.{BIGOPSPACING4}, and \.{BIGOPSPACING5}, may also be used for parameters +8 to 13. + +The notation `\.{PARAMETER} $n$' provides another way to specify the +$n$th parameter; for example, `\.{(PARAMETER} \.{D 1 R -.25)}' is another way +to specify that the \.{SLANT} is $-0.25$. The value of $n$ must be positive +and less than |max_param_words|. + +@ The elements of a \.{CHARACTER} property list can be of six different types. + +\yskip\hang\.{CHARWD} (real value) denotes the character's width in +design units. + +\yskip\hang\.{CHARHT} (real value) denotes the character's height in +design units. + +\yskip\hang\.{CHARDP} (real value) denotes the character's depth in +design units. + +\yskip\hang\.{CHARIC} (real value) denotes the character's italic correction in +design units. + +\yskip\hang\.{NEXTLARGER} (integer value), specifies the character that +follows the present one in a ``charlist.'' The value must be the number of a +character in the font, and there must be no infinite cycles of supposedly +larger and larger characters. + +\yskip\hang\.{VARCHAR} (property list value), specifies an extensible character. +This option and \.{NEXTLARGER} are mutually exclusive; i.e., they cannot +both be used within the same \.{CHARACTER} list. + +\yskip\noindent +The elements of a \.{VARCHAR} property list are either \.{TOP}, \.{MID}, +\.{BOT} or \.{REP}; the values are integers, which must be zero or the number +of a character in the font. A zero value for \.{TOP}, \.{MID}, or \.{BOT} means +that the corresponding piece of the extensible character is absent. A nonzero +value, or a \.{REP} value of zero, denotes the character code used to make +up the top, middle, bottom, or replicated piece of an extensible character. + +@ A \.{LIGTABLE} property list contains elements of four kinds, specifying a +program in a simple command language that \TeX\ uses for ligatures and kerns. +If several \.{LIGTABLE} lists appear, they are effectively concatenated into +a single list. + +\yskip\hang\.{LABEL} (integer value) means that the program for the +stated character value starts here. The integer must be the number of a +character in the font; its \.{CHARACTER} property list must not have a +\.{NEXTLARGER} or \.{VARCHAR} field. At least one \.{LIG} or \.{KRN} step +must follow. + +\yskip\hang\.{LABEL} \.{BOUNDARYCHAR} means that the program for +beginning-of-word ligatures starts here. + +\yskip\hang\.{LIG} (two integer values). The instruction `\.{(LIG} $c$ $r$\.)' +means, ``If the next character is $c$, then insert character~$r$ and +possibly delete the current character and/or~$c$; +otherwise go on to the next instruction.'' +Characters $r$ and $c$ must be present in the font. \.{LIG} may be immediately +preceded or followed by a slash, and then immediately followed by \.> +characters not exceeding the number of slashes. Thus there are eight +possible forms: +$$\hbox to .8\hsize{\.{LIG}\hfil\.{/LIG}\hfil\.{/LIG>}\hfil +\.{LIG/}\hfil\.{LIG/>}\hfil\.{/LIG/}\hfil\.{/LIG/>}\hfil\.{/LIG/>>}}$$ +The slashes specify retention of the left or right original character; the +\.> signs specify passing over the result without further ligature processing. + +\yskip\hang\.{KRN} (an integer value and a real value). The instruction +`\.{(KRN} $c$ $r$\.)' means, ``If the next character is $c$, then insert +a blank space of width $r$ between the current character character and $c$; +otherwise go on to the next intruction.'' The value of $r$, which is in +units of the design size, is often negative. Character code $c$ must exist +in the font. + +\yskip\hang\.{STOP} (no value). This instruction ends a ligature/kern program. +It must follow either a \.{LIG} or \.{KRN} instruction, not a \.{LABEL} +or \.{STOP} or \.{SKIP}. + +\yskip\hang\.{SKIP} (value in the range |0..127|). This instruction specifies +continuation of a ligature/kern program after the specified number of \.{LIG} +or \.{KRN} has been skipped over. The number of subsequent \.{LIG} and \.{KRN} +instructions must therefore exceed this specified amount. + +@ In addition to all these possibilities, the property name \.{COMMENT} is +allowed in any property list. Such comments are ignored. + +@ So that is what \.{PL} files hold. The next question is, ``What about +\.{TFM} files?'' A complete answer to that question appears in the +documentation of the companion program, \.{TFtoPL}, so it will not +be repeated here. Suffice it to say that a \.{TFM} file stores all of the +relevant font information in a sequence of 8-bit bytes. The number of +bytes is always a multiple of 4, so we could regard the \.{TFM} file +as a sequence of 32-bit words; but \TeX\ uses the byte interpretation, +and so does \.{PLtoTF}. Note that the bytes are considered to be unsigned +numbers. + +@= +@!tfm_file:packed file of 0..255; + +@ On some systems you may have to do something special to write a +packed file of bytes. For example, the following code didn't work +when it was first tried at Stanford, because packed files have to be +opened with a special switch setting on the \PASCAL\ that was used. +@^system dependencies@> + +@= +rewrite(tfm_file); + +@* Basic input routines. +For the purposes of this program, a |byte| is an unsigned 16-bit quantity, +and an |ASCII_code| is an integer between @'40 and @'177. Such ASCII codes +correspond to one-character constants like \.{"A"} in \.{WEB} language. + +@= +@!byte=0..65535; {unsigned sixteen-bit quantity} +@!ASCII_code=@'40..@'177; {standard ASCII code numbers} + +@ One of the things \.{PLtoTF} has to do is convert characters of strings +to ASCII form, since that is the code used for the family name and the +coding scheme in a \.{TFM} file. An array |xord| is used to do the +conversion from |char|; the method below should work with little or no change +on most \PASCAL\ systems. +@^system dependencies@> + +@d first_ord=0 {ordinal number of the smallest element of |char|} +@d last_ord=127 {ordinal number of the largest element of |char|} + +@= +@!xord:array[char] of ASCII_code; {conversion table} + +@ @= +@!k:integer; {all-purpose initialization index} + +@ Characters that should not appear in \.{PL} files (except in comments) +are mapped into @'177. + +@d invalid_code=@'177 {code deserving an error message} + +@= +for k:=first_ord to last_ord do xord[chr(k)]:=invalid_code; +xord[' ']:=" "; xord['!']:="!"; xord['"']:=""""; xord['#']:="#"; +xord['$']:="$"; xord['%']:="%"; xord['&']:="&"; xord['''']:="'"; +xord['(']:="("; xord[')']:=")"; xord['*']:="*"; xord['+']:="+"; xord[',']:=","; +xord['-']:="-"; xord['.']:="."; xord['/']:="/"; xord['0']:="0"; xord['1']:="1"; +xord['2']:="2"; xord['3']:="3"; xord['4']:="4"; xord['5']:="5"; xord['6']:="6"; +xord['7']:="7"; xord['8']:="8"; xord['9']:="9"; xord[':']:=":"; xord[';']:=";"; +xord['<']:="<"; xord['=']:="="; xord['>']:=">"; xord['?']:="?"; +xord['@@']:="@@"; xord['A']:="A"; xord['B']:="B"; xord['C']:="C"; +xord['D']:="D"; xord['E']:="E"; xord['F']:="F"; xord['G']:="G"; xord['H']:="H"; +xord['I']:="I"; xord['J']:="J"; xord['K']:="K"; xord['L']:="L"; xord['M']:="M"; +xord['N']:="N"; xord['O']:="O"; xord['P']:="P"; xord['Q']:="Q"; xord['R']:="R"; +xord['S']:="S"; xord['T']:="T"; xord['U']:="U"; xord['V']:="V"; xord['W']:="W"; +xord['X']:="X"; xord['Y']:="Y"; xord['Z']:="Z"; xord['[']:="["; xord['\']:="\"; +xord[']']:="]"; xord['^']:="^"; xord['_']:="_"; xord['`']:="`"; xord['a']:="a"; +xord['b']:="b"; xord['c']:="c"; xord['d']:="d"; xord['e']:="e"; xord['f']:="f"; +xord['g']:="g"; xord['h']:="h"; xord['i']:="i"; xord['j']:="j"; xord['k']:="k"; +xord['l']:="l"; xord['m']:="m"; xord['n']:="n"; xord['o']:="o"; xord['p']:="p"; +xord['q']:="q"; xord['r']:="r"; xord['s']:="s"; xord['t']:="t"; xord['u']:="u"; +xord['v']:="v"; xord['w']:="w"; xord['x']:="x"; xord['y']:="y"; xord['z']:="z"; +xord['{']:="{"; xord['|']:="|"; xord['}']:="}"; xord['~']:="~"; + +@ In order to help catch errors of badly nested parentheses, \.{PLtoTF} +assumes that the user will begin each line with a number of blank spaces equal +to some constant times the number of open parentheses at the beginning of +that line. However, the program doesn't know in advance what the constant +is, nor does it want to print an error message on every line for a user +who has followed no consistent pattern of indentation. + +Therefore the following strategy is adopted: If the user has been consistent +with indentation for ten or more lines, an indentation error will be +reported. The constant of indentation is reset on every line that should +have nonzero indentation. + +@= +@!line:integer; {the number of the current line} +@!good_indent:integer; {the number of lines since the last bad indentation} +@!indent: integer; {the number of spaces per open parenthesis, zero if unknown} +@!level: integer; {the current number of open parentheses} + +@ @= +line:=0; good_indent:=0; indent:=0; level:=0; + +@ The input need not really be broken into lines of any maximum length, and +we could read it character by character without any buffering. But we shall +place it into a small buffer so that offending lines can be displayed in error +messages. + +@= +@!left_ln,@!right_ln:boolean; {are the left and right ends of the buffer + at end-of-line marks?} +@!limit:0..buf_size; {position of the last character present in the buffer} +@!loc:0..buf_size; {position of the last character read in the buffer} +@!buffer:array[1..buf_size] of char; +@!input_has_ended:boolean; {there is no more input to read} + +@ @= +limit:=0; loc:=0; left_ln:=true; right_ln:=true; input_has_ended:=false; + +@ Just before each \.{CHARACTER} property list is evaluated, the character +code is printed in octal notation. Up to eight such codes appear on a line; +so we have a variable to keep track of how many are currently there. + +@= +@!chars_on_line:0..8; {the number of characters printed on the current line} + +@ @= +chars_on_line:=0; + +@ The following routine prints an error message and an indication of +where the error was detected. The error message should not include any +final punctuation, since this procedure supplies its own. + +@d err_print(#)==begin if chars_on_line>0 then print_ln(' '); + print(#); show_error_context; + end + +@p procedure show_error_context; {prints the current scanner location} +var k:0..buf_size; {an index into |buffer|} +begin print_ln(' (line ',line:1,').'); +if not left_ln then print('...'); +for k:=1 to loc do print(buffer[k]); {print the characters already scanned} +print_ln(' '); +if not left_ln then print(' '); +for k:=1 to loc do print(' '); {space out the second line} +for k:=loc+1 to limit do print(buffer[k]); {print the characters yet unseen} +if right_ln then print_ln(' ')@+else print_ln('...'); +chars_on_line:=0; +end; + +@ Here is a procedure that does the right thing when we are done +reading the present contents of the buffer. It keeps |buffer[buf_size]| +empty, in order to avoid range errors on certain \PASCAL\ compilers. + +An infinite sequence of right parentheses is placed at the end of the +file, so that the program is sure to get out of whatever level of nesting +it is in. + +On some systems it is desirable to modify this code so that tab marks +in the buffer are replaced by blank spaces. (Simply setting +|xord[chr(@'11)]:=" "| would not work; for example, two-line +error messages would not come out properly aligned.) +@^system dependencies@> + +@p procedure fill_buffer; +begin left_ln:=right_ln; limit:=0; loc:=0; +if left_ln then begin + if line>0 then read_ln(pl_file); + incr(line); + end; +if eof(pl_file) then begin + limit:=1; buffer[1]:=')'; right_ln:=false; input_has_ended:=true; + end +else begin + while (limit; + end; +end; + +@ The interesting part about |fill_buffer| is the part that learns what +indentation conventions the user is following, if any. + +@d bad_indent(#)==begin if good_indent>=10 then err_print(#); + good_indent:=0; indent:=0; + end + +@= +begin while (loc + else if indent=0 then + if loc mod level=0 then begin + indent:=loc div level; good_indent:=1; + end + else good_indent:=0 + else if indent*level=loc then incr(good_indent) + else bad_indent('Warning: Inconsistent indentation; ', +@.Warning: Inconsistent indentation...@> + 'you are at parenthesis level ',level:1); + end; +end + +@* Basic scanning routines. +The global variable |cur_char| holds the ASCII code corresponding to the +character most recently read from the input buffer, or to a character that +has been substituted for the real one. + +@= +@!cur_char:ASCII_code; {we have just read this} + +@ Here is a procedure that sets |cur_char| to an ASCII code for the +next character of input, if that character is a letter or digit or slash +or \.>. Otherwise +it sets |cur_char:=" "|, and the input system will be poised to reread the +character that was rejected, whether or not it was a space. +Lower case letters are converted to upper case. + +@p procedure get_keyword_char; +begin while (loc=limit)and(not right_ln) do fill_buffer; +if loc=limit then cur_char:=" " {end-of-line counts as a delimiter} +else begin + cur_char:=xord[buffer[loc+1]]; + if cur_char>="a" then cur_char:=cur_char-@'40; + if ((cur_char>="0")and(cur_char<="9")) then incr(loc) + else if ((cur_char>="A")and(cur_char<="Z")) then incr(loc) + else if cur_char="/" then incr(loc) + else if cur_char=">" then incr(loc) + else cur_char:=" "; + end; +end; + +@ The following procedure sets |cur_char| to the next character code, +and converts lower case to upper case. If the character is a left or +right parenthesis, it will not be ``digested''; the character will +be read again and again, until the calling routine does something +like `|incr(loc)|' to get past it. Such special treatment of parentheses +insures that the structural information they contain won't be lost in +the midst of other error recovery operations. + +@d backup==begin if (cur_char>")")or(cur_char<"(") then decr(loc); + end {undoes the effect of |get_next|} + +@p procedure get_next; {sets |cur_char| to next, balks at parentheses} +begin while loc=limit do fill_buffer; +incr(loc); cur_char:=xord[buffer[loc]]; +if cur_char>="a" then + if cur_char<="z" then cur_char:=cur_char-@'40 {uppercasify} + else begin + if cur_char=invalid_code then begin + err_print('Illegal character in the file'); +@.Illegal character...@> + cur_char:="?"; + end; + end +else if (cur_char<=")")and(cur_char>="(") then decr(loc); +end; + +@ The next procedure is used to ignore the text of a comment, or to pass over +erroneous material. As such, it has the privilege of passing parentheses. +It stops after the first right parenthesis that drops the level below +the level in force when the procedure was called. + +@p procedure skip_to_end_of_item; +var l:integer; {initial value of |level|} +begin l:=level; +while level>=l do begin + while loc=limit do fill_buffer; + incr(loc); + if buffer[loc]=')' then decr(level) + else if buffer[loc]='(' then incr(level); + end; +if input_has_ended then err_print('File ended unexpectedly: No closing ")"'); +@.File ended unexpectedly...@> +cur_char:=" "; {now the right parenthesis has been read and digested} +end; + +@ Sometimes we merely want to skip past characters in the input until we +reach a left or a right parenthesis. For example, we do this whenever we +have finished scanning a property value and we hope that a right parenthesis +is next (except for possible blank spaces). + +@d skip_to_paren==repeat get_next@;@+ until (cur_char="(")or(cur_char=")") +@d skip_error(#)==begin err_print(#); skip_to_paren; + end {this gets to the right parenthesis if something goes wrong} +@d flush_error(#)==begin err_print(#); skip_to_end_of_item; + end {this gets past the right parenthesis if something goes wrong} + +@ After a property value has been scanned, we want to move just past the +right parenthesis that should come next in the input (except for possible +blank spaces). + +@p procedure finish_the_property; {do this when the value has been scanned} +begin while cur_char=" " do get_next; +if cur_char<>")" then err_print('Junk after property value will be ignored'); +@.Junk after property value...@> +skip_to_end_of_item; +end; + +@* Scanning property names. +We have to figure out the meaning of names that appear in the \.{PL} file, +by looking them up in a dictionary of known keywords. Keyword number $n$ +appears in locations |start[n]| through |start[n+1]-1| of an array called +|dictionary|. + +@d max_name_index=300 {upper bound on the number of keywords} +@d max_letters=3000 {upper bound on the total length of all keywords} + +@= +@!start:array[1..max_name_index] of 0..max_letters; +@!dictionary:array[0..max_letters] of ASCII_code; +@!start_ptr:0..max_name_index; {the first available place in |start|} +@!dict_ptr:0..max_letters; {the first available place in |dictionary|} + +@ @= +start_ptr:=1; start[1]:=0; dict_ptr:=0; + +@ When we are looking for a name, we put it into the |cur_name| array. +When we have found it, the corresponding |start| index will go into +the global variable |name_ptr|. + +@d longest_name=20 {length of \.{DEFAULTRULETHICKNESS}} + +@= +@!cur_name:array[1..longest_name] of ASCII_code; {a name to look up} +@!name_length:0..longest_name; {its length} +@!name_ptr:0..max_name_index; {its ordinal number in the dictionary} + +@ A conventional hash table with linear probing (cf.\ Algorithm 6.4L +in {\sl The Art of Computer Pro\-gram\-ming\/}) is used for the dictionary +operations. If |nhash[h]=0|, the table position is empty, otherwise |nhash[h]| +points into the |start| array. + +@d hash_prime=307 {size of the hash table} + +@= +@!nhash:array[0..hash_prime-1] of 0..max_name_index; +@!cur_hash:0..hash_prime-1; {current position in the hash table} + +@ @= +@!h:0..hash_prime-1; {runs through the hash table} + +@ @= +for h:=0 to hash_prime-1 do nhash[h]:=0; + +@ Since there is no chance of the hash table overflowing, the procedure +is very simple. After |lookup| has done its work, |cur_hash| will point +to the place where the given name was found, or where it should be inserted. + +@p procedure lookup; {finds |cur_name| in the dictionary} +var k:0..longest_name; {index into |cur_name|} +@!j:0..max_letters; {index into |dictionary|} +@!not_found:boolean; {clumsy thing necessary to avoid |goto| statement} +@!cur_hash_reset:boolean; +begin @; +not_found:=true; +cur_hash_reset:=false; +while not_found do begin + if (cur_hash=0) and (cur_hash_reset) then + not_found:=false + else begin + if cur_hash=0 then begin + cur_hash:=hash_prime-1; + cur_hash_reset:=true + end + else decr(cur_hash); + if nhash[cur_hash]=0 then not_found:=false + else begin + j:=start[nhash[cur_hash]]; + if start[nhash[cur_hash]+1]=j+name_length then begin + not_found:=false; + for k:=1 to name_length do + if dictionary[j+k-1]<>cur_name[k] then not_found:=true; + end + end + end + end; +name_ptr:=nhash[cur_hash]; +end; + +@ @= +cur_hash:=cur_name[1]; +for k:=2 to name_length do + cur_hash:=(cur_hash+cur_hash+cur_name[k]) mod hash_prime + +@ The ``meaning'' of the keyword that begins at |start[k]| in the +dictionary is kept in |equiv[k]|. The numeric |equiv| codes are given +symbolic meanings by the following definitions. + +@d comment_code=0 +@d check_sum_code=1 +@d design_size_code=2 +@d design_units_code=3 +@d coding_scheme_code=4 +@d family_code=5 +@d face_code=6 +@d seven_bit_safe_flag_code=7 +@d header_code= 8 +@d font_dimen_code=9 +@d lig_table_code=10 +@d boundary_char_code=11 +@d font_dir_code=14 +@d n_font_dir_code=15 +@d character_code=16 +@d parameter_code=30 +@d char_info_code=70 +@d width=1 +@d height=2 +@d depth=3 +@d italic=4 +@d sec_width=5 +@d sec_height=6 +@d sec_depth=7 +@d sec_italic=8 +@d accent=9 +@d prim_top_axis=10 +@d prim_top_axis_bis=11 +@d prim_bot_axis=12 +@d prim_bot_axis_bis=13 +@d prim_mid_hor=14 +@d prim_mid_vert=15 +@d prim_base_slant=16 +@d sec_top_axis=17 +@d sec_top_axis_bis=18 +@d sec_bot_axis=19 +@d sec_bot_axis_bis=20 +@d sec_mid_hor=21 +@d sec_mid_vert=22 +@d sec_base_slant=23 +@d char_wd_code=char_info_code+width +@d char_ht_code=char_info_code+height +@d char_dp_code=char_info_code+depth +@d char_ic_code=char_info_code+italic +@d sec_width_code=char_info_code+sec_width +@d sec_height_code=char_info_code+sec_height +@d sec_depth_code=char_info_code+sec_depth +@d sec_italic_code=char_info_code+sec_italic +@d accent_code=char_info_code+accent +@d prim_top_axis_code=char_info_code+prim_top_axis +@d prim_top_axis_bis_code=char_info_code+prim_top_axis_bis +@d prim_bot_axis_code=char_info_code+prim_bot_axis +@d prim_bot_axis_bis_code=char_info_code+prim_bot_axis_bis +@d prim_mid_hor_code=char_info_code+prim_mid_hor +@d prim_mid_vert_code=char_info_code+prim_mid_vert +@d prim_base_slant_code=char_info_code+prim_base_slant +@d sec_top_axis_code=char_info_code+sec_top_axis +@d sec_top_axis_bis_code=char_info_code+sec_top_axis_bis +@d sec_bot_axis_code=char_info_code+sec_bot_axis +@d sec_bot_axis_bis_code=char_info_code+sec_bot_axis_bis +@d sec_mid_hor_code=char_info_code+sec_mid_hor +@d sec_mid_vert_code=char_info_code+sec_mid_vert +@d sec_base_slant_code=char_info_code+sec_base_slant +@d next_larger_code=100 +@d var_char_code=102 +@d label_code=130 +@d stop_code=131 +@d skip_code=132 +@d krn_code=133 +@d lig_code=134 +@d ofm_level_code=140 +@d char_repeat_code=150 +@d char_ivalue_code=151 +@d char_fvalue_code=152 +@d char_mvalue_code=153 +@d char_rule_code=154 +@d char_glue_code=155 +@d char_penalty_code=156 +@d font_rule_code=160 +@d rule_code=161 +@d rule_width_code=162 +@d rule_height_code=163 +@d rule_depth_code=164 +@d font_glue_code=170 +@d glue_code=171 +@d glue_type_code=172 +@d glue_stretch_order_code=173 +@d glue_shrink_order_code=174 +@d glue_width_code=175 +@d glue_stretch_code=176 +@d glue_shrink_code=177 +@d glue_char_code=178 +@d glue_rule_code=179 +@d order_unit_code=181 +@d order_fi_code=182 +@d order_fil_code=183 +@d order_fill_code=184 +@d order_filll_code=185 +@d type_normal_code=186 +@d type_aleaders_code=187 +@d type_cleaders_code=188 +@d type_xleaders_code=189 +@d font_penalty_code=190 +@d penalty_code=191 +@d penalty_val_code=192 +@d font_mvalue_code=200 +@d mvalue_code=201 +@d mvalue_val_code=202 +@d font_fvalue_code=210 +@d fvalue_code=211 +@d fvalue_val_code=212 +@d font_ivalue_code=220 +@d ivalue_code=221 +@d ivalue_val_code=222 +@d clabel_code=231 +@d cpen_code=232 +@d cglue_code=233 +@d cpenglue_code=234 +@d ckrn_code=235 +@d TL_dir_code=240 +@d LT_dir_code=241 +@d TR_dir_code=242 +@d LB_dir_code=243 +@d BL_dir_code=244 +@d RT_dir_code=245 +@d BR_dir_code=246 +@d RB_dir_code=247 + + +@= +@!equiv:array[0..max_name_index] of byte; +@!cur_code:byte; {equivalent most recently found in |equiv|} + +@ We have to get the keywords into the hash table and into the dictionary in +the first place (sigh). The procedure that does this has the desired +|equiv| code as a parameter. In order to facilitate \.{WEB} macro writing +for the initialization, the keyword being initialized is placed into the +last positions of |cur_name|, instead of the first positions. + +@p procedure enter_name(v:byte); {|cur_name| goes into the dictionary} +var k:0..longest_name; +begin for k:=1 to name_length do + cur_name[k]:=cur_name[k+longest_name-name_length]; +{now the name has been shifted into the correct position} +lookup; {this sets |cur_hash| to the proper insertion place} +nhash[cur_hash]:=start_ptr; equiv[start_ptr]:=v; +for k:=1 to name_length do + begin dictionary[dict_ptr]:=cur_name[k]; incr(dict_ptr); + end; +incr(start_ptr); start[start_ptr]:=dict_ptr; +end; + +@ Here are the macros to load a name of up to 20 letters into the +dictionary. For example, the macro |load5| is used for five-letter keywords. + +@d tail(#)==enter_name(#) +@d t20(#)==cur_name[20]:=#;tail +@d t19(#)==cur_name[19]:=#;t20 +@d t18(#)==cur_name[18]:=#;t19 +@d t17(#)==cur_name[17]:=#;t18 +@d t16(#)==cur_name[16]:=#;t17 +@d t15(#)==cur_name[15]:=#;t16 +@d t14(#)==cur_name[14]:=#;t15 +@d t13(#)==cur_name[13]:=#;t14 +@d t12(#)==cur_name[12]:=#;t13 +@d t11(#)==cur_name[11]:=#;t12 +@d t10(#)==cur_name[10]:=#;t11 +@d t9(#)==cur_name[9]:=#;t10 +@d t8(#)==cur_name[8]:=#;t9 +@d t7(#)==cur_name[7]:=#;t8 +@d t6(#)==cur_name[6]:=#;t7 +@d t5(#)==cur_name[5]:=#;t6 +@d t4(#)==cur_name[4]:=#;t5 +@d t3(#)==cur_name[3]:=#;t4 +@d t2(#)==cur_name[2]:=#;t3 +@d t1(#)==cur_name[1]:=#;t2 +@d load2==name_length:=2;t19 +@d load3==name_length:=3;t18 +@d load4==name_length:=4;t17 +@d load5==name_length:=5;t16 +@d load6==name_length:=6;t15 +@d load7==name_length:=7;t14 +@d load8==name_length:=8;t13 +@d load9==name_length:=9;t12 +@d load10==name_length:=10;t11 +@d load11==name_length:=11;t10 +@d load12==name_length:=12;t9 +@d load13==name_length:=13;t8 +@d load14==name_length:=14;t7 +@d load15==name_length:=15;t6 +@d load16==name_length:=16;t5 +@d load17==name_length:=17;t4 +@d load18==name_length:=18;t3 +@d load19==name_length:=19;t2 +@d load20==name_length:=20;t1 + +@ (Thank goodness for keyboard macros in the text editor used to create this +\.{WEB} file.) + +@= +equiv[0]:=comment_code; {this is used after unknown keywords} +load8("C")("H")("E")("C")("K")("S")("U")("M")(check_sum_code);@/ +load10("D")("E")("S")("I")("G")("N")("S")("I")("Z")("E")(design_size_code);@/ +load11("D")("E")("S")("I")("G")("N") + ("U")("N")("I")("T")("S")(design_units_code);@/ +load12("C")("O")("D")("I")("N")("G") + ("S")("C")("H")("E")("M")("E")(coding_scheme_code);@/ +load6("F")("A")("M")("I")("L")("Y")(family_code);@/ +load4("F")("A")("C")("E")(face_code);@/ +load16("S")("E")("V")("E")("N")("B")("I")("T")@/@t\hskip2em@> + ("S")("A")("F")("E")("F")("L")("A")("G")(seven_bit_safe_flag_code);@/ +load6("H")("E")("A")("D")("E")("R")(header_code);@/ +load9("F")("O")("N")("T")("D")("I")("M")("E")("N")(font_dimen_code);@/ +load8("L")("I")("G")("T")("A")("B")("L")("E")(lig_table_code);@/ +load12("B")("O")("U")("N")("D")("A")("R")("Y")("C")("H")("A")("R") + (boundary_char_code);@/ +load9("C")("H")("A")("R")("A")("C")("T")("E")("R")(character_code);@/ +load9("P")("A")("R")("A")("M")("E")("T")("E")("R")(parameter_code);@/ +load6("C")("H")("A")("R")("W")("D")(char_wd_code);@/ +load6("C")("H")("A")("R")("H")("T")(char_ht_code);@/ +load6("C")("H")("A")("R")("D")("P")(char_dp_code);@/ +load6("C")("H")("A")("R")("I")("C")(char_ic_code);@/ +load5("S")("E")("C")("W")("D")(sec_width_code);@/ +load5("S")("E")("C")("H")("T")(sec_height_code);@/ +load5("S")("E")("C")("D")("P")(sec_depth_code);@/ +load5("S")("E")("C")("I")("C")(sec_italic_code);@/ +load6("A")("C")("C")("E")("N")("T")(accent_code);@/ +load11("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")(prim_top_axis_code);@/ +load14("P")("R")("I")("M")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(prim_top_axis_bis_code);@/ +load11("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")(prim_bot_axis_code);@/ +load14("P")("R")("I")("M")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(prim_bot_axis_bis_code);@/ +load10("P")("R")("I")("M")("M")("I")("D")("H")("O")("R")(prim_mid_hor_code);@/ +load10("P")("R")("I")("M")("M")("I")("D")("V")("E")("R")(prim_mid_vert_code);@/ +load13("P")("R")("I")("M")("B")("A")("S")("E")("S")("L")("A")("N")("T")(prim_base_slant_code);@/ +load10("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")(sec_top_axis_code);@/ +load13("S")("E")("C")("T")("O")("P")("A")("X")("I")("S")("B")("I")("S")(sec_top_axis_bis_code);@/ +load10("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")(sec_bot_axis_code);@/ +load13("S")("E")("C")("B")("O")("T")("A")("X")("I")("S")("B")("I")("S")(sec_bot_axis_bis_code);@/ +load9("S")("E")("C")("M")("I")("D")("H")("O")("R")(sec_mid_hor_code);@/ +load9("S")("E")("C")("M")("I")("D")("V")("E")("R")(sec_mid_vert_code);@/ +load12("S")("E")("C")("B")("A")("S")("E")("S")("L")("A")("N")("T")(sec_base_slant_code);@/ +load10("N")("E")("X")("T")("L")("A")("R")("G")("E")("R")(next_larger_code);@/ +load7("V")("A")("R")("C")("H")("A")("R")(var_char_code);@/ +load3("T")("O")("P")(var_char_code+1);@/ +load3("M")("I")("D")(var_char_code+2);@/ +load3("B")("O")("T")(var_char_code+3);@/ +load3("R")("E")("P")(var_char_code+4);@/ +load3("E")("X")("T")(var_char_code+4); {compatibility with older \.{PL} format} +load7("C")("O")("M")("M")("E")("N")("T")(comment_code);@/ +load5("L")("A")("B")("E")("L")(label_code);@/ +load4("S")("T")("O")("P")(stop_code);@/ +load4("S")("K")("I")("P")(skip_code);@/ +load3("K")("R")("N")(krn_code);@/ +load3("L")("I")("G")(lig_code);@/ +load4("/")("L")("I")("G")(lig_code+2);@/ +load5("/")("L")("I")("G")(">")(lig_code+6);@/ +load4("L")("I")("G")("/")(lig_code+1);@/ +load5("L")("I")("G")("/")(">")(lig_code+5);@/ +load5("/")("L")("I")("G")("/")(lig_code+3);@/ +load6("/")("L")("I")("G")("/")(">")(lig_code+7);@/ +load7("/")("L")("I")("G")("/")(">")(">")(lig_code+11);@/ +load6("C")("L")("A")("B")("E")("L")(clabel_code);@/ +load4("C")("P")("E")("N")(cpen_code);@/ +load5("C")("G")("L")("U")("E")(cglue_code);@/ +load8("C")("P")("E")("N")("G")("L")("U")("E")(cpenglue_code);@/ +load4("C")("K")("R")("N")(ckrn_code);@/ +load8("O")("F")("M")("L")("E")("V")("E")("L")(ofm_level_code);@/ +load7("F")("O")("N")("T")("D")("I")("R")(font_dir_code);@/ +load8("N")("F")("O")("N")("T")("D")("I")("R")(n_font_dir_code);@/ +load10("C")("H")("A")("R")("R")("E")("P")("E")("A")("T")(char_repeat_code);@/ +load10("C")("H")("A")("R")("I")("V")("A")("L")("U")("E")(char_ivalue_code);@/ +load10("C")("H")("A")("R")("F")("V")("A")("L")("U")("E")(char_fvalue_code);@/ +load10("C")("H")("A")("R")("M")("V")("A")("L")("U")("E")(char_mvalue_code);@/ +load8("C")("H")("A")("R")("R")("U")("L")("E")(char_rule_code);@/ +load8("C")("H")("A")("R")("G")("L")("U")("E")(char_glue_code);@/ +load11("C")("H")("A")("R")("P")("E")("N")("A")("L")("T")("Y")(char_penalty_code);@/ +load8("F")("O")("N")("T")("R")("U")("L")("E")(font_rule_code);@/ +load4("R")("U")("L")("E")(rule_code);@/ +load6("R")("U")("L")("E")("W")("D")(rule_width_code);@/ +load6("R")("U")("L")("E")("H")("T")(rule_height_code);@/ +load6("R")("U")("L")("E")("D")("P")(rule_depth_code);@/ +load8("F")("O")("N")("T")("G")("L")("U")("E")(font_glue_code);@/ +load4("G")("L")("U")("E")(glue_code);@/ +load8("G")("L")("U")("E")("T")("Y")("P")("E")(glue_type_code);@/ +load16("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")("O")("R")("D")("E")("R")(glue_stretch_order_code);@/ +load15("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")("O")("R")("D")("E")("R")(glue_shrink_order_code);@/ +load8("G")("L")("U")("E")("R")("U")("L")("E")(glue_rule_code);@/ +load8("G")("L")("U")("E")("C")("H")("A")("R")(glue_char_code);@/ +load6("G")("L")("U")("E")("W")("D")(glue_width_code);@/ +load11("G")("L")("U")("E")("S")("T")("R")("E")("T")("C")("H")(glue_stretch_code);@/ +load10("G")("L")("U")("E")("S")("H")("R")("I")("N")("K")(glue_shrink_code);@/ +load4("U")("N")("I")("T")(order_unit_code);@/ +load2("F")("I")(order_fi_code);@/ +load3("F")("I")("L")(order_fil_code);@/ +load4("F")("I")("L")("L")(order_fill_code);@/ +load5("F")("I")("L")("L")("L")(order_filll_code);@/ +load6("N")("O")("R")("M")("A")("L")(type_normal_code);@/ +load8("A")("L")("E")("A")("D")("E")("R")("S")(type_aleaders_code);@/ +load8("C")("L")("E")("A")("D")("E")("R")("S")(type_cleaders_code);@/ +load8("X")("L")("E")("A")("D")("E")("R")("S")(type_xleaders_code);@/ +load11("F")("O")("N")("T")("P")("E")("N")("A")("L")("T")("Y")(font_penalty_code);@/ +load7("P")("E")("N")("A")("L")("T")("Y")(penalty_code);@/ +load10("P")("E")("N")("A")("L")("T")("Y")("V")("A")("L")(penalty_val_code);@/ +load10("F")("O")("N")("T")("M")("V")("A")("L")("U")("E")(font_mvalue_code);@/ +load6("M")("V")("A")("L")("U")("E")(mvalue_code);@/ +load9("M")("V")("A")("L")("U")("E")("V")("A")("L")(mvalue_val_code);@/ +load10("F")("O")("N")("T")("F")("V")("A")("L")("U")("E")(font_fvalue_code);@/ +load6("F")("V")("A")("L")("U")("E")(fvalue_code);@/ +load9("F")("V")("A")("L")("U")("E")("V")("A")("L")(fvalue_val_code);@/ +load10("F")("O")("N")("T")("I")("V")("A")("L")("U")("E")(font_ivalue_code);@/ +load6("I")("V")("A")("L")("U")("E")(ivalue_code);@/ +load9("I")("V")("A")("L")("U")("E")("V")("A")("L")(ivalue_val_code);@/ +load2("T")("L")(TL_dir_code); +load2("L")("T")(LT_dir_code); +load2("T")("R")(TR_dir_code); +load2("L")("B")(LB_dir_code); +load2("B")("L")(BL_dir_code); +load2("R")("T")(RT_dir_code); +load2("B")("R")(BR_dir_code); +load2("R")("B")(RB_dir_code); + +@ @= +load5("S")("L")("A")("N")("T")(parameter_code+1);@/ +load5("S")("P")("A")("C")("E")(parameter_code+2);@/ +load7("S")("T")("R")("E")("T")("C")("H")(parameter_code+3);@/ +load6("S")("H")("R")("I")("N")("K")(parameter_code+4);@/ +load7("X")("H")("E")("I")("G")("H")("T")(parameter_code+5);@/ +load4("Q")("U")("A")("D")(parameter_code+6);@/ +load10("E")("X")("T")("R")("A")("S")("P")("A")("C")("E")(parameter_code+7);@/ +load4("N")("U")("M")("1")(parameter_code+8);@/ +load4("N")("U")("M")("2")(parameter_code+9);@/ +load4("N")("U")("M")("3")(parameter_code+10);@/ +load6("D")("E")("N")("O")("M")("1")(parameter_code+11);@/ +load6("D")("E")("N")("O")("M")("2")(parameter_code+12);@/ +load4("S")("U")("P")("1")(parameter_code+13);@/ +load4("S")("U")("P")("2")(parameter_code+14);@/ +load4("S")("U")("P")("3")(parameter_code+15);@/ +load4("S")("U")("B")("1")(parameter_code+16);@/ +load4("S")("U")("B")("2")(parameter_code+17);@/ +load7("S")("U")("P")("D")("R")("O")("P")(parameter_code+18);@/ +load7("S")("U")("B")("D")("R")("O")("P")(parameter_code+19);@/ +load6("D")("E")("L")("I")("M")("1")(parameter_code+20);@/ +load6("D")("E")("L")("I")("M")("2")(parameter_code+21);@/ +load10("A")("X")("I")("S")("H")("E")("I")("G")("H")("T")(parameter_code+22);@/ +load20("D")("E")("F")("A")("U")("L")("T")("R")("U")("L")("E")@/@t\hskip2em@> + ("T")("H")("I")("C")("K")("N")("E")("S")("S")(parameter_code+8);@/ +load13("B")("I")("G")("O")("P") + ("S")("P")("A")("C")("I")("N")("G")("1")(parameter_code+9);@/ +load13("B")("I")("G")("O")("P") + ("S")("P")("A")("C")("I")("N")("G")("2")(parameter_code+10);@/ +load13("B")("I")("G")("O")("P") + ("S")("P")("A")("C")("I")("N")("G")("3")(parameter_code+11);@/ +load13("B")("I")("G")("O")("P") + ("S")("P")("A")("C")("I")("N")("G")("4")(parameter_code+12);@/ +load13("B")("I")("G")("O")("P") + ("S")("P")("A")("C")("I")("N")("G")("5")(parameter_code+13);@/ + +@ When a left parenthesis has been scanned, the following routine +is used to interpret the keyword that follows, and to store the +equivalent value in |cur_code|. + +@p procedure get_name; +begin incr(loc); incr(level); {pass the left parenthesis} +cur_char:=" "; +while cur_char=" " do get_next; +if (cur_char>")")or(cur_char<"(") then decr(loc); {back up one character} +name_length:=0; get_keyword_char; {prepare to scan the name} +while cur_char<>" " do begin + if name_length=longest_name then cur_name[1]:="X" {force error} + else incr(name_length); + cur_name[name_length]:=cur_char; + get_keyword_char; + end; +lookup; +if name_ptr=0 then err_print('Sorry, I don''t know that property name'); +@.Sorry, I don't know...@> +cur_code:=equiv[name_ptr]; +end; + +@* Scanning numeric data. +The next thing we need is a trio of subroutines to read the one-byte, +four-byte, and real numbers that may appear as property values. +These subroutines are careful to stick to numbers between $-2^{31}$ +and $2^{31}-1$, inclusive, so that a computer with two's complement +32-bit arithmetic will not be interrupted by overflow. + +@ The first number scanner, which returns a one-byte value, surely has +no problems of arithmetic overflow. + +@p function get_byte:byte; {scans a one-byte property value} +var acc:integer; {an accumulator} +@!t:ASCII_code; {the type of value to be scanned} +begin repeat get_next; +until cur_char<>" "; {skip the blanks before the type code} +t:=cur_char; acc:=0; +repeat get_next; +until cur_char<>" "; {skip the blanks after the type code} +if t="C" then @ +else if t="D" then @ +else if t="O" then @ +else if t="H" then @ +else if t="F" then @ +else skip_error('You need "C" or "D" or "O" or "H" or "F" here'); +@.You need "C" or "D" ...here@> +cur_char:=" "; get_byte:=acc; +end; + +@ The |get_next| routine converts lower case to upper case, but it leaves +the character in the buffer, so we can unconvert it. + +@= +if (cur_char>=@'41)and(cur_char<=@'176)and + ((cur_char<"(")or(cur_char>")")) then + acc:=xord[buffer[loc]] +else skip_error('"C" value must be standard ASCII and not a paren') +@:C value}\.{"C" value must be...@> + +@ @= +begin while (cur_char>="0")and(cur_char<="9") do begin + acc:=acc*10+cur_char-"0"; + if acc>65535 then begin + skip_error('This value shouldn''t exceed 65535'); +@.This value shouldn't...@> + acc:=0; cur_char:=" "; + end + else get_next; + end; +backup; +end + +@ @= +begin while (cur_char>="0")and(cur_char<="7") do + begin acc:=acc*8+cur_char-"0"; + if acc>65535 then begin + skip_error('This value shouldn''t exceed ''177777'); +@.This value shouldn't...@> + acc:=0; cur_char:=" "; + end + else get_next; + end; +backup; +end + +@ @= +begin while ((cur_char>="0")and(cur_char<="9"))or + ((cur_char>="A")and(cur_char<="F")) do begin + if cur_char>="A" then cur_char:=cur_char+"0"+10-"A"; + acc:=acc*16+cur_char-"0"; + if acc>65535 then begin + skip_error('This value shouldn''t exceed "FFFF'); +@.This value shouldn't...@> + acc:=0; cur_char:=" "; + end + else get_next; + end; +backup; +end + +@ @= +begin if cur_char="B" then acc:=2 +else if cur_char="L" then acc:=4 +else if cur_char<>"M" then acc:=18; +get_next; +if cur_char="I" then incr(acc) +else if cur_char<>"R" then acc:=18; +get_next; +if cur_char="C" then acc:=acc+6 +else if cur_char="E" then acc:=acc+12 +else if cur_char<>"R" then acc:=18; +if acc>=18 then begin + skip_error('Illegal face code, I changed it to MRR'); +@.Illegal face code...@> + acc:=0; + end; +end + +@ The routine that scans a four-byte value puts its output into |cur_bytes|, +which is a record containing (yes, you guessed it) four bytes. + +@= +@!four_bytes=record @!b0:byte;@+@!b1:byte;@+@!b2:byte;@+@!b3:byte;@+end; + +@ @d c0==cur_bytes.b0 +@d c1==cur_bytes.b1 +@d c2==cur_bytes.b2 +@d c3==cur_bytes.b3 + +@= +@!cur_bytes:four_bytes; {a four-byte accumulator} +@!zero_bytes:four_bytes; {four bytes all zero} + +@ @= +zero_bytes.b0:=0; zero_bytes.b1:=0; zero_bytes.b2:=0; zero_bytes.b3:=0; + +@ Since the |get_four_bytes| routine is used very infrequently, no attempt +has been made to make it fast; we only want it to work. +This is no longer the case, but we hope that it is not too slow. + +@p procedure get_four_bytes; {scans an unsigned constant and sets |four_bytes|} +var c:integer; {leading byte} +@!r:integer; {radix} +begin repeat get_next; +until cur_char<>" "; {skip the blanks before the type code} +r:=0; cur_bytes:=zero_bytes; {start with the accumulator zero} +if cur_char="H" then r:=16 +else if cur_char="O" then r:=8 +else if cur_char="D" then r:=10 +else skip_error('Decimal ("D"), octal ("O") or hex ("H") value is needed here'); +@.Decimal ("D"), octal ("O") or hex ("H")...@> +if r>0 then begin + repeat get_next; + until cur_char<>" "; {skip the blanks after the type code} + while ((cur_char>="0")and(cur_char<="9"))or@| + ((cur_char>="A")and(cur_char<="F")) do + @; + end; +end; + +function get_integer:integer; {scans an integer property value} +begin get_four_bytes; +get_integer:=(c0*@"1000000)+(c1*@"10000)+(c2*@"100)+c3; +end; + +@ @= +begin if cur_char>="A" then cur_char:=cur_char+"0"+10-"A"; +if cur_char>="0"+r then skip_error('Illegal digit') +@.Illegal digit@> +else begin + c:=c3*r+cur_char-"0"; c3:=c mod 256;@/ + c:=c2*r+c div 256; c2:=c mod 256;@/ + c:=c1*r+c div 256; c1:=c mod 256;@/ + c:=c0*r+c div 256; + if c<256 then c0:=c + else begin + cur_bytes:=zero_bytes; + if r=8 then + skip_error('Sorry, the maximum octal value is O 37777777777') +@.Sorry, the maximum...@> + else if r=10 then + skip_error('Sorry, the maximum decimal value is D 4294967295') + else skip_error('Sorry, the maximum hex value is H FFFFFFFF'); + end; + get_next; + end; +end + +@ The remaining scanning routine is the most interesting. It scans a real +constant and returns the nearest |fix_word| approximation to that constant. +A |fix_word| is a 32-bit integer that represents a real value that +has been multiplied by $2^{20}$. Since \.{PLtoTF} restricts the magnitude +of reals to 2048, the |fix_word| will have a magnitude less than $2^{31}$. + +@d unity==@'4000000 {$2^{20}$, the |fix_word| 1.0} + +@= +@!fix_word=integer; {a scaled real value with 20 bits of fraction} +@!unsigned_integer=integer; + +@ When a real value is desired, we might as well treat `\.D' and `\.R' +formats as if they were identical. + +@p function get_fix:fix_word; {scans a real property value} +var negative:boolean; {was there a minus sign?} +@!acc:integer; {an accumulator} +@!int_part:integer; {the integer part} +@!j:0..7; {the number of decimal places stored} +begin repeat get_next; +until cur_char<>" "; {skip the blanks before the type code} +negative:=false; acc:=0; {start with the accumulators zero} +if (cur_char<>"R")and(cur_char<>"D") then + skip_error('An "R" or "D" value is needed here') +@.An "R" or "D" ... needed here@> +else begin + @; + while (cur_char>="0") and (cur_char<="9") do + @; + int_part:=acc; acc:=0; + if cur_char="." then @; + if (acc>=unity)and(int_part=2047) then + skip_error('Real constants must be less than 2048') +@.Real constants must be...@> + else acc:=int_part*unity+acc; + end; +if negative then get_fix:=-acc@+else get_fix:=acc; +end; + +@ @= +repeat get_next; +if cur_char="-" then begin + cur_char:=" "; negative:=true; + end +else if cur_char="+" then cur_char:=" "; +until cur_char<>" " + +@ @= +begin acc:=acc*10+cur_char-"0"; +if acc>=2048 then begin + skip_error('Real constants must be less than 2048'); +@.Real constants must be...@> + acc:=0; cur_char:=" "; + end +else get_next; +end + +@ To scan the fraction $.d_1d_2\ldots\,$, we keep track of up to seven +of the digits $d_j$. A correct result is obtained if we first compute +$f^\prime=\lfloor 2^{21}(d_1\ldots d_j)/10^j\rfloor$, after which +$f=\lfloor(f^\prime+1)/2\rfloor$. It is possible to have $f=1.0$. + +@= +@!fraction_digits:array[1..7] of integer; {$2^{21}$ times $d_j$} + +@ @= +begin j:=0; get_next; +while (cur_char>="0")and(cur_char<="9") do begin + if j<7 then begin + incr(j); fraction_digits[j]:=@'10000000*(cur_char-"0"); + end; + get_next; + end; +acc:=0; +while j>0 do begin + acc:=fraction_digits[j]+(acc div 10); decr(j); + end; +acc:=(acc+10) div 20; +end + +@* Storing the property values. +When property values have been found, they are squirreled away in a bunch +of arrays. The header information is unpacked into bytes in an array +called |header_bytes|. The ligature/kerning program is stored in an array +of type |four_bytes|. +Another |four_bytes| array holds the specifications of extensible characters. +The kerns and parameters are stored in separate arrays of |fix_word| values. + +Instead of storing the design size in the header array, we will keep it +in a |fix_word| variable until the last minute. The number of units in the +design size is also kept in a |fix_word|. + +@= +@!header_bytes:array[header_index] of byte; {the header block} +@!header_ptr:header_index; {the number of header bytes in use} +@!design_size:fix_word; {the design size} +@!design_units:fix_word; {reciprocal of the scaling factor} +@!seven_bit_safe_flag:boolean; {does the file claim to be seven-bit-safe?} +@!lig_kern:array[0..max_lig_steps] of four_bytes; {the ligature program} +@!nl:unsigned_integer; {the number of ligature/kern instructions so far} +@!min_nl:unsigned_integer; {the final value of |nl| must be at least this} +@!kern:array[0..max_kerns] of fix_word; {the distinct kerning amounts} +@!nk:0..max_kerns; {the number of entries of |kern|} +@!exten:array[char_type] of four_bytes; {extensible character specs} +@!ne:xchar_type; {the number of extensible characters} +@!param:array[1..max_param_words] of fix_word; {\.{FONTDIMEN} parameters} +@!np:0..max_param_words; {the largest parameter set nonzero} +@!check_sum_specified:boolean; {did the user name the check sum?} +@!bchar:xchar_type; {the right boundary character, or 256 if unspecified} +@!font_dir:integer; {font direction} + +@ @= +@!char_type=0..max_char; +@!xchar_type=0..xmax_char; +@!xxchar_type=0..xxmax_char; +@!xxxchar_type=0..xxxmax_char; +@!header_index=0..max_header_bytes; +@!indx=xxchar_type; + +@ @= +@!d:header_index; {an index into |header_bytes|} + +@ We start by setting up the default values. + +@d check_sum_loc=0 +@d design_size_loc=4 +@d coding_scheme_loc=8 +@d family_loc=coding_scheme_loc+40 +@d seven_flag_loc=family_loc+20 +@d face_loc=seven_flag_loc+3 + +@= +for d:=0 to 18*4-1 do header_bytes[d]:=0; +header_bytes[8]:=11; header_bytes[9]:="U"; +header_bytes[10]:="N"; +header_bytes[11]:="S"; +header_bytes[12]:="P"; +header_bytes[13]:="E"; +header_bytes[14]:="C"; +header_bytes[15]:="I"; +header_bytes[16]:="F"; +header_bytes[17]:="I"; +header_bytes[18]:="E"; +header_bytes[19]:="D"; +@.UNSPECIFIED@> +for d:=family_loc to family_loc+11 do header_bytes[d]:=header_bytes[d-40]; +design_size:=10*unity; design_units:=unity; seven_bit_safe_flag:=false;@/ +header_ptr:=18*4; nl:=0; min_nl:=0; nk:=0; ne:=0; np:=0;@/ +check_sum_specified:=false; bchar:=xmax_char; +font_dir:=0; + +@ Most of the dimensions, however, go into the |memory| array. There are +at most |max_char+2| widths, |max_char+2| heights, |max_char+2| depths, +and |max_char+2| italic corrections, since the value 0 is required but +it need not be used. So |memory| has room for |4*max_char+8| entries, +each of which is a |fix_word|. An auxiliary table called |link| is +used to link these words together in linear lists, so that sorting and +other operations can be done conveniently. + +We also add four ``list head'' words to the |memory| and |link| arrays; +these are in locations |width| through |italic|, i.e., 1 through 4. +For example, |link[height]| points to the smallest element in +the sorted list of distinct heights that have appeared so far, and +|memory[height]| is the number of distinct heights. + +@= +@!pointer=0..mem_size; {an index into memory} + +@ The arrays |char_wd|, |char_ht|, |char_dp|, and |char_ic| contain +pointers to the |memory| array entries where the corresponding dimensions +appear. Two other arrays, |char_tag| and |char_remainder|, hold +the other information that \.{TFM} files pack into a |char_info_word|. + +@d no_tag=0 {vanilla character} +@d lig_tag=1 {character has a ligature/kerning program} +@d list_tag=2 {character has a successor in a charlist} +@d ext_tag=3 {character is extensible} +@d bchar_label==char_remainder[xmax_char] + {beginning of ligature program for left boundary} + +@= +@!memory:array[pointer] of fix_word; {character dimensions and kerns} +@!mem_ptr:pointer; {largest |memory| word in use} +@!link:array[pointer] of pointer; {to make lists of |memory| items} +@!char_wd:array[char_type] of pointer; {pointers to the widths} +@!char_ht:array[char_type] of pointer; {pointers to the heights} +@!char_dp:array[char_type] of pointer; {pointers to the depths} +@!char_ic:array[char_type] of pointer; {pointers to italic corrections} +@!char_tag:array[char_type] of no_tag..ext_tag; {character tags} +@!char_remainder:array[xchar_type] of xchar_type; + {pointers to ligature labels, + next larger characters, or extensible characters} +@!top_width,@!top_height,@!top_depth,@!top_italic:integer; + +@ @= +@!c:integer; {runs through all character codes} + +@ @= +bchar_label:=xmax_label; +for c:=0 to max_char do begin + char_wd[c]:=0; char_ht[c]:=0; char_dp[c]:=0; char_ic[c]:=0;@/ + char_tag[c]:=no_tag; char_remainder[c]:=0; + end; +memory[0]:=@'17777777777; {an ``infinite'' element at the end of the lists} +memory[width]:=0; link[width]:=0; {width list is empty} +memory[height]:=0; link[height]:=0; {height list is empty} +memory[depth]:=0; link[depth]:=0; {depth list is empty} +memory[italic]:=0; link[italic]:=0; {italic list is empty} +mem_ptr:=italic; + +@ As an example of these data structures, let us consider the simple +routine that inserts a potentially new element into one of the dimension +lists. The first parameter indicates the list head (i.e., |h=width| for +the width list, etc.); the second parameter is the value that is to be +inserted into the list if it is not already present. The procedure +returns the value of the location where the dimension appears in |memory|. +The fact that |memory[0]| is larger than any legal dimension makes the +algorithm particularly short. + +We do have to handle two somewhat subtle situations. A width of zero must be +put into the list, so that a zero-width character in the font will not appear +to be nonexistent (i.e., so that its |char_wd| index will not be zero), but +this does not need to be done for heights, depths, or italic corrections. +Furthermore, it is necessary to test for memory overflow even though we +have provided room for the maximum number of different dimensions in any +legal font, since the \.{PL} file might foolishly give any number of +different sizes to the same character. + +@p function sort_in(@!h:pointer;@!d:fix_word):pointer; {inserts into list} +var p:pointer; {the current node of interest} +begin if (d=0)and(h<>width) then sort_in:=0 +else begin + p:=h; + while d>=memory[link[p]] do p:=link[p]; + if (d=memory[p])and(p<>h) then sort_in:=p + else if mem_ptr=mem_size then + begin err_print('Memory overflow: too many widths, etc'); +@.Memory overflow...@> + print_ln('Congratulations! It''s hard to make this error.'); + sort_in:=p; + end + else begin + incr(mem_ptr); memory[mem_ptr]:=d; + link[mem_ptr]:=link[p]; link[p]:=mem_ptr; incr(memory[h]); + sort_in:=mem_ptr; + end; + end; +end; + +@ When these lists of dimensions are eventually written to the \.{OFM} +file, we may have to do some rounding of values, because the \.{OFM} file +allows at most 65536 widths, 256 heights, 256 depths, and 256 italic +corrections. The following procedure takes a given list head |h| and a +given dimension |d|, and returns the minimum $m$ such that the elements +of the list can be covered by $m$ intervals of width $d$. It also sets +|next_d| to the smallest value $d^\prime>d$ such that the covering found +by this procedure would be different. In particular, if $d=0$ it computes +the number of elements of the list, and sets |next_d| to the smallest +distance between two list elements. (The covering by intervals of width +|next_d| is not guaranteed to have fewer than $m$ elements, but in +practice this seems to happen most of the time.) + +@= +@!next_d:fix_word; {the next larger interval that is worth trying} + +@ Once again we can make good use of the fact that |memory[0]| is ``infinite.'' + +@p function min_cover(@!h:pointer;@!d:fix_word):integer; +var p:pointer; {the current node of interest} +@!l:fix_word; {the least element covered by the current interval} +@!m:integer; {the current size of the cover being generated} +begin m:=0; p:=link[h]; next_d:=memory[0]; +while p<>0 do begin + incr(m); l:=memory[p]; + while memory[link[p]]<=l+d do p:=link[p]; + p:=link[p]; + if memory[p]-lm then begin + excess:=memory[h]-m; + k:=min_cover(h,0); d:=next_d; {now the answer is at least |d|} + repeat d:=d+d; k:=min_cover(h,d); + until k<=m; {first we ascend rapidly until finding the range} + d:=d div 2; k:=min_cover(h,d); {now we run through the feasible steps} + while k>m do begin + d:=next_d; k:=min_cover(h,d); + end; + shorten:=d; + end +else shorten:=0; +end; + +@ When we are nearly ready to output the \.{TFM} file, we will set +|index[p]:=k| if the dimension in |memory[p]| is being rounded to the +|k|th element of its list. + +@= +@!index:array[pointer] of byte; +@!excess:byte; {number of words to remove, if list is being shortened} + +@ Here is the procedure that sets the |index| values. It also shortens +the list so that there is only one element per covering interval; +the remaining elements are the midpoints of their clusters. + +@p procedure set_indices(@!h:pointer;@!d:fix_word); + {reduces and indexes a list} +var p:pointer; {the current node of interest} +@!q:pointer; {trails one step behind |p|} +@!m:byte; {index number of nodes in the current interval} +@!l:fix_word; {least value in the current interval} +begin q:=h; p:=link[q]; m:=0; +while p<>0 do begin + incr(m); l:=memory[p]; index[p]:=m; + while memory[link[p]]<=l+d do begin + p:=link[p]; index[p]:=m; decr(excess); + if excess=0 then d:=0; + end; + link[q]:=p; memory[p]:=l+(memory[p]-l) div 2; q:=p; p:=link[p]; + end; +memory[h]:=m; +end; + +@* The input phase. +We're ready now to read and parse the \.{PL} file, storing property +values as we go. + +@= +@!c:integer; {the current character or byte being processed} +@!cprime:char_type; {Processing for several characters together} +@!crange:char_type; {ditto} + +@ @= +cur_char:=" "; +repeat while cur_char=" " do get_next; +if cur_char="(" then @ +else if (cur_char=")")and not input_has_ended then begin + err_print('Extra right parenthesis'); + incr(loc); cur_char:=" "; + end +@.Extra right parenthesis@> +else if not input_has_ended then junk_error; +until input_has_ended + +@ The |junk_error| routine just referred to is called when something +appears in the forbidden area between properties of a property list. + +@p procedure junk_error; {gets past no man's land} +begin err_print('There''s junk here that is not in parentheses'); +@.There's junk here...@> +skip_to_paren; +end; + +@ For each font property, we are supposed to read the data from the +left parenthesis that is the current value of |cur_char| to the right +parenthesis that matches it in the input. The main complication is +to recover with reasonable grace from various error conditions that +might arise. + +@= +begin get_name; +if cur_code=comment_code then skip_to_end_of_item +else if (cur_code<110) and (cur_code>character_code) then + flush_error('This property name doesn''t belong on the outer level') +else if (cur_code>=110) and ((cur_code mod 10)<>0) then + flush_error('This property name doesn''t belong on the outer level') +@.This property name doesn't belong...@> +else begin @; + finish_the_property; + end; +end + +@ @= +case cur_code of + check_sum_code: begin + check_sum_specified:=true; + read_four_bytes(check_sum_loc); + end; + design_size_code: @; + design_units_code: @; + coding_scheme_code: read_BCPL(coding_scheme_loc,40); + family_code: read_BCPL(family_loc,20); + face_code: begin + c:=get_byte; if c>255 then + begin err_print('FACE clipped to 255'); c:=255 end; + header_bytes[face_loc]:=c + end; + seven_bit_safe_flag_code: @; + header_code: @; + font_dimen_code: @; + lig_table_code: read_lig_kern; + boundary_char_code: bchar:=get_byte; + character_code: read_char_info; + ofm_level_code: @; + font_dir_code: @; + n_font_dir_code: @; + char_repeat_code: read_repeated_character_info; + font_rule_code: read_font_rule_list; + font_glue_code: read_font_glue_list; + font_penalty_code: read_font_penalty_list; + font_mvalue_code: read_font_mvalue_list; + font_fvalue_code: read_font_fvalue_list; + font_ivalue_code: read_font_ivalue_list; + end + +@ The |case| statement just given makes use of two subroutines that we +haven't defined yet. The first of these puts a 32-bit octal quantity +into four specified bytes of the header block. + +@p procedure read_four_bytes(l:header_index); +begin get_four_bytes; +header_bytes[l]:=c0; +header_bytes[l+1]:=c1; +header_bytes[l+2]:=c2; +header_bytes[l+3]:=c3; +end; + +@ The second little procedure is used to scan a string and to store it in +the ``{\mc BCPL} format'' required by \.{TFM} files. The string is supposed +to contain at most |n| bytes, including the first byte (which holds the +length of the rest of the string). + +@p procedure read_BCPL(l:header_index;n:byte); +var k:header_index; +begin k:=l; +while cur_char=" " do get_next; +while (cur_char<>"(")and(cur_char<>")") do begin + if k + ' characters will be kept'); decr(k); + end; +header_bytes[l]:=k-l; +while k= +begin next_d:=get_fix; +if next_d +else design_size:=next_d; +end + +@ @= +begin next_d:=get_fix; +if next_d<=0 then + err_print('The number of units per design size must be positive') +@.The number of units...@> +else design_units:=next_d; +end + +@ @= +begin while cur_char=" " do get_next; +if cur_char="T" then seven_bit_safe_flag:=true +else if cur_char="F" then seven_bit_safe_flag:=false +else err_print('The flag value should be "TRUE" or "FALSE"'); +@.The flag value should be...@> +skip_to_paren; +end + +@ @= +begin c:=get_byte; +if c<18 then skip_error('HEADER indices should be 18 or more') +@.HEADER indices...@> +else if 4*c+4>max_header_bytes then + skip_error('This HEADER index is too big for my present table size') +@.This HEADER index is too big...@> +else begin + while header_ptr<4*c+4 do begin + header_bytes[header_ptr]:=0; incr(header_ptr); + end; + read_four_bytes(4*c); + end; +end + +@ The remaining kinds of font property values that need to be read are +those that involve property lists on higher levels. Each of these has a +loop similar to the one that was used at level zero. Then we put the +right parenthesis back so that `|finish_the_property|' will be happy; +there is probably a more elegant way to do this. + +@d finish_inner_property_list==begin decr(loc); incr(level); cur_char:=")"; + end + +@= +begin while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin get_name; +if cur_code=comment_code then skip_to_end_of_item +else if (cur_code=char_wd_code) then + flush_error('This property name doesn''t belong in a FONTDIMEN list') +@.This property name doesn't belong...@> +else begin + if cur_code=parameter_code then c:=get_integer + else c:=cur_code-parameter_code; + if c=0 then flush_error('PARAMETER index must not be zero') +@.PARAMETER index must not...@> + else if c>max_param_words then + flush_error('This PARAMETER index is too big for my present table size') +@.This PARAMETER index is too big...@> + else begin + while np= +begin lk_step_ended:=false; +while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then read_lig_kern_command + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin get_name; +if cur_code=comment_code then skip_to_end_of_item +else if (cur_code>=label_code) and (cur_code<=(lig_code+11)) then begin + case cur_code of + label_code:@; + stop_code:@; + skip_code:@; + krn_code:@; + lig_code,lig_code+1,lig_code+2,lig_code+3,lig_code+5, + lig_code+6,lig_code+7,lig_code+11:@; + end; {there are no other cases |>=label_code|} + finish_the_property; +end +else if (cur_code>=clabel_code) and (cur_code<=cpenglue_code) then begin + case cur_code of + clabel_code:@; + cpen_code:@; + cglue_code:@; + cpenglue_code:@; + ckrn_code:@; + end; {there are no other cases |>=label_code|} + finish_the_property; +end +else flush_error('This property name doesn''t belong in a LIGTABLE list'); +@.This property name doesn't belong...@> +end + +@ When a character is about to be tagged, we call the following +procedure so that an error message is given in case of multiple tags. + +@p procedure check_tag(c:integer); {print error if |c| already tagged} +begin case char_tag[c] of + no_tag: do_nothing; + lig_tag: err_print('This character already appeared in a LIGTABLE LABEL'); +@.This character already...@> + list_tag: err_print('This character already has a NEXTLARGER spec'); + ext_tag: err_print('This character already has a VARCHAR spec'); + end; +end; + +@ @= +begin while cur_char=" " do get_next; +if cur_char="B" then begin + bchar_label:=nl; skip_to_paren; {\.{LABEL BOUNDARYCHAR}} + end +else begin + backup; c:=get_byte; + check_tag(c); char_tag[c]:=lig_tag; char_remainder[c]:=nl; + end; +if min_nl<=nl then min_nl:=nl+1; +lk_step_ended:=false; +end + +@ @d stop_flag=128 {value indicating `\.{STOP}' in a lig/kern program} +@d kern_flag=128 {op code for a kern step} + +@= +@!lk_step_ended:boolean; + {was the last \.{LIGTABLE} property \.{LIG} or \.{KRN}?} +@!krn_ptr:0..max_kerns; {an index into |kern|} + +@ @= +if not lk_step_ended then + err_print('STOP must follow LIG or KRN') +@.STOP must follow LIG or KRN@> +else begin + lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag; + lk_step_ended:=false; + end + +@ @= +if not lk_step_ended then + err_print('SKIP must follow LIG or KRN') +@.SKIP must follow LIG or KRN@> +else begin + c:=get_byte; + if c>=128 then err_print('Maximum SKIP amount is 127') +@.Maximum SKIP amount...@> + else if nl+c>=max_lig_steps then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> + else begin + lig_kern[nl-1].b0:=c; + if min_nl<=nl+c then min_nl:=nl+c+1; + end; + lk_step_ended:=false; + end + +@ @= +begin lig_kern[nl].b0:=0; +lig_kern[nl].b2:=cur_code-lig_code; +lig_kern[nl].b1:=get_byte; +lig_kern[nl].b3:=get_byte; +if nl>=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +begin lig_kern[nl].b0:=0; lig_kern[nl].b1:=get_byte; +kern[nk]:=get_fix; krn_ptr:=0; +while kern[krn_ptr]<>kern[nk] do incr(krn_ptr); +if krn_ptr=nk then begin + if nk + decr(krn_ptr); + end; + end; +if ofm_level=-1 then begin + lig_kern[nl].b2:=kern_flag+(krn_ptr div 256); + lig_kern[nl].b3:=krn_ptr mod 256; + end +else begin + lig_kern[nl].b2:=kern_flag+(krn_ptr div 65536); + lig_kern[nl].b3:=krn_ptr mod 65536; + end; +if nl>=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +@!category_remainders:array[0..256] of integer; +@!ivalue_category,@!max_ivalue_category:integer; +@!glue_category,@!max_glue_category:integer; +@!penalty_category,@!max_penalty_category:integer; + +@ @= +for ivalue_category:=0 to 256 do begin + category_remainders[ivalue_category]:=-1; + end; +max_ivalue_category:=-1; +max_glue_category:=-1; +max_penalty_category:=-1; + +@ @= +begin +c:=get_byte; +category_remainders[c]:=nl; +if max_ivalue_category= +begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte; +lig_kern[nl].b2:=17; +penalty_category:=get_byte; +if max_penalty_category=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte; +lig_kern[nl].b2:=18; +glue_category:=get_byte; +if max_glue_category=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte; +lig_kern[nl].b2:=19; +penalty_category:=get_byte; +if max_penalty_category=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +begin lig_kern[nl].b0:=256; lig_kern[nl].b1:=get_byte; +lig_kern[nl].b2:=20; +kern[nk]:=get_fix; krn_ptr:=0; +while kern[krn_ptr]<>kern[nk] do incr(krn_ptr); +if krn_ptr=nk then begin + if nk + decr(krn_ptr); + end; + end; +if krn_ptr>65535 then + err_print('Sorry, too many different kerns for me to handle'); +lig_kern[nl].b3:=krn_ptr; +if nl>=max_lig_steps-1 then + err_print('Sorry, LIGTABLE too long for me to handle') +@.Sorry, LIGTABLE too long...@> +else incr(nl); +lk_step_ended:=true; +end + +@ @= +@!char_extended_tag:array [char_type] of boolean; + +@ @= +for c:=0 to max_char do + char_extended_tag[c]:=false; + +@ @= +begin +if max_penalty_category>0 then begin + if nkp=0 then + err_print('No PENALTY table') + else if npp[0]0 then begin + if nkg=0 then + err_print('No GLUE table') + else if npg[0]0 then begin + if nki=0 then + err_print('No IVALUE table') + else if npi[0]0) then begin + for j:=0 to max_ivalue_category do + if char_table[c,0]=j then begin + if category_remainders[j]<>-1 then begin + if char_tag[c]<>0 then + err_print('Character already has a tag') + else begin + char_extended_tag[c]:=true; + char_remainder[c]:=category_remainders[j]; + end; + end; + end; + end; + end; + end; + end; +end + +@ @= +tables_read:boolean; + +@ @= +tables_read:=false; + +@ Finally we come to the part of \.{PLtoTF}'s input mechanism +that is used most, the processing of individual character data. + +@= +begin +if not tables_read then begin + compute_new_header_ofm; + tables_read:=true; + end; +c:=get_byte; {read the character code that is being specified} +@; +while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then read_character_property + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|} +finish_inner_property_list; +end + +@ @= +@!char_original:array [0..max_char] of integer; +@!char_repeats:array [0..max_char] of integer; +@!diff:boolean; +@!needed_space,@!extra_bytes:integer; + +@ @= +for ch_entry:=0 to max_char do begin + char_original[ch_entry]:=ch_entry; + char_repeats[ch_entry]:=0; + end; + +@ @= +begin +if not tables_read then begin + @; + tables_read:=true; + end; +c:=get_byte; {read the character code that is being specified} +@; +crange:=get_byte; {read how many characters are being defined} +if (crange<0) then begin + err_print('Character ranges must be positive'); + crange:=0; + end; +if ((c+crange)>max_char) then begin + err_print('Character range too large'); + crange:=0; + end; +print('-'); print_hex(c+crange); +while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then read_character_property + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +if char_wd[c]=0 then char_wd[c]:=sort_in(width,0); {legitimatize |c|} +finish_inner_property_list; +cprime:=c; +for c:=(cprime+1) to (cprime+crange) do begin + char_wd[c]:=char_wd[cprime]; + char_ht[c]:=char_ht[cprime]; + char_dp[c]:=char_dp[cprime]; + char_ic[c]:=char_ic[cprime]; + for tab:=0 to (nki+nkf+nkr+nkg+nkp-1) do begin + char_table[c,tab]:= char_table[cprime,tab]; + end; + end; +end + +@ Tables for character parameters + +@d char_param_tables==8 + +@= +@!char_table:array [0..max_char,0..char_param_tables] of integer; +@!ch_table,@!ch_entry:integer; +@!temp_value:integer; + +@ @= +for c:=0 to max_char do + for ch_table:=0 to char_param_tables do + char_table[c,ch_table]:=0; + +@ @= +begin get_name; +if cur_code=comment_code then skip_to_end_of_item +else if (cur_codevar_char_code)and + ((cur_codechar_penalty_code))) +then + flush_error('This property name doesn''t belong in a CHARACTER list') +@.This property name doesn't belong...@> +else begin + case cur_code of + char_wd_code:char_wd[c]:=sort_in(width,get_fix); + char_ht_code:char_ht[c]:=sort_in(height,get_fix); + char_dp_code:char_dp[c]:=sort_in(depth,get_fix); + char_ic_code:char_ic[c]:=sort_in(italic,get_fix); + sec_width_code:temp_value:=get_fix; + sec_height_code:temp_value:=get_fix; + sec_depth_code:temp_value:=get_fix; + sec_italic_code:temp_value:=get_fix; + accent_code:temp_value:=get_fix; + prim_top_axis_code:temp_value:=get_fix; + prim_top_axis_bis_code:temp_value:=get_fix; + prim_bot_axis_code:temp_value:=get_fix; + prim_bot_axis_bis_code:temp_value:=get_fix; + prim_mid_hor_code:temp_value:=get_fix; + prim_mid_vert_code:temp_value:=get_fix; + prim_base_slant_code:temp_value:=get_fix; + sec_top_axis_code:temp_value:=get_fix; + sec_top_axis_bis_code:temp_value:=get_fix; + sec_bot_axis_code:temp_value:=get_fix; + sec_bot_axis_bis_code:temp_value:=get_fix; + sec_mid_hor_code:temp_value:=get_fix; + sec_mid_vert_code:temp_value:=get_fix; + sec_base_slant_code:temp_value:=get_fix; + next_larger_code:begin check_tag(c); char_tag[c]:=list_tag; + char_remainder[c]:=get_byte; + end; + var_char_code:@; + char_ivalue_code: begin + ch_table:=get_integer; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkci then nkci:=ch_table; + end; + char_fvalue_code: begin + ch_table:=get_integer+nki; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkcf then nkcf:=ch_table; + end; + char_mvalue_code: begin + ch_table:=get_integer+nki+nkf; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkcm then nkcm:=ch_table; + end; + char_rule_code: begin + ch_table:=get_integer+nki+nkf+nkm; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkcr then nkcr:=ch_table; + end; + char_glue_code: begin + ch_table:=get_integer+nki+nkf+nkm+nkr; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkcg then nkcg:=ch_table; + end; + char_penalty_code: begin + ch_table:=get_integer+nki+nkf+nkm+nkr+nkg; + ch_entry:=get_integer; + char_table[c,ch_table]:=ch_entry; + if ch_table>nkcp then nkcp:=ch_table; + end; + end;@/ + finish_the_property; + end; +end + +@ @= +begin if ne=xmax_char then + err_print('Sorry, too many VARCHAR specs') +@.Sorry, too many VARCHAR specs@> +else begin + check_tag(c); char_tag[c]:=ext_tag; char_remainder[c]:=ne;@/ + exten[ne]:=zero_bytes; + while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + incr(ne); + finish_inner_property_list; + end; +end + +@ @= +begin get_name; +if cur_code=comment_code then skip_to_end_of_item +else if (cur_codevar_char_code+4) then + flush_error('This property name doesn''t belong in a VARCHAR list') +@.This property name doesn't belong...@> +else begin + case cur_code-(var_char_code+1) of + 0:exten[ne].b0:=get_byte; + 1:exten[ne].b1:=get_byte; + 2:exten[ne].b2:=get_byte; + 3:exten[ne].b3:=get_byte; + end;@/ + finish_the_property; + end; +end + +@ The input routine is now complete except for the following code, +which prints a progress report as the file is being read. +@= +@!ASCII_04,@!ASCII_10,@!ASCII_14,HEX: packed array [1..32] of char; + {strings for output in the user's external character set} +@!MBL_string,@!RI_string,@!RCE_string:packed array [1..3] of char; + {handy string constants for |face| codes} + +@ @= +ASCII_04:=' !"#$%&''()*+,-./0123456789:;<=>?';@/ +ASCII_10:='@@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_';@/ +ASCII_14:='`abcdefghijklmnopqrstuvwxyz{|}~ ';@/ +HEX:='0123456789ABCDEF';@/ +MBL_string:='MBL'; RI_string:='RI '; RCE_string:='RCE'; + +@ The array |dig| will hold a sequence of digits to be output. + +@= +@!dig:array[0..32] of integer; + +@ Here, in fact, are two procedures that output +|dig[j-1]|$\,\ldots\,$|dig[0]|, given $j>0$. + +@p procedure out_digs(j:integer); {outputs |j| digits} +begin repeat decr(j); out(HEX[1+dig[j]]); +until j=0; +end; +@# +procedure print_digs(j:integer); {prints |j| digits} +begin repeat decr(j); print(HEX[1+dig[j]]); +until j=0; +end; + + +@ The |print_number| procedure indicates how |print_digs| can be used. +This procedure can print in octal, decimal or hex notation. + +@d print_hex(#)==print_number(#,16) +@d print_octal(#)==print_number(#,8) +@d print_decimal(#)==print_number(#,10) + +@p procedure print_number(c:integer; form:integer); {prints value of |c|} +var j:0..32; {index into |dig|} +begin +j:=0; +if (c<0) then begin + print_ln('Internal error: print_number (negative value)'); + c:=0 + end; +if form=8 then + print('''') {an apostrophe indicates the octal notation} +else if form=16 then + print('"') { a double apostrophe indicates the hexadecimal notation} +else if form<>10 then begin + print_ln('Internal error: print_number'); + form:=10 + end; +while (c>0) or (j=0) do begin + dig[j]:=c mod form; c:=c div form; + j:=j+1; + end; +print_digs(j); +end; + + +@ @= +begin if chars_on_line=8 then begin + print_ln(' '); chars_on_line:=1; + end +else begin + if chars_on_line>0 then print(' '); + incr(chars_on_line); + end; +print_hex(c); {progress report} +end + +@* The checking and massaging phase. +Once the whole \.{PL} file has been read in, we must check it for consistency +and correct any errors. This process consists mainly of running through +the characters that exist and seeing if they refer to characters that +don't exist. We also compute the true value of |seven_unsafe|; we make sure +that the charlists and ligature programs contain no loops; and we +shorten the lists of widths, heights, depths, and italic corrections, +if necessary, to keep from exceeding the required maximum sizes. + +@= +@!seven_unsafe:boolean; {do seven-bit characters generate eight-bit ones?} + +@ @= +if nl>0 then @; +seven_unsafe:=false; +for c:=0 to max_char do if char_wd[c]<>0 then + @; +if bchar_label; + end; +if seven_bit_safe_flag and seven_unsafe then + print_ln('The font is not really seven-bit-safe!'); +@.The font is not...safe@> +@; +@; +finish_extended_font; +for c:=0 to max_char do + @; +@ + +@ The checking that we need in several places is accomplished by three +macros that are only slightly tricky. + +@d existence_tail(#)==begin char_wd[g]:=sort_in(width,0); + print(#,' '); print_hex(c); + print_ln(' had no CHARACTER spec.'); + end; + end +@d check_existence_and_safety(#)==begin g:=#; + if (g>=128)and(c<128) then seven_unsafe:=true; + if char_wd[g]=0 then existence_tail +@d check_existence(#)==begin g:=#; + if char_wd[g]=0 then existence_tail + +@= +case char_tag[c] of + no_tag: do_nothing; + lig_tag: @; + list_tag: check_existence_and_safety(char_remainder[c]) + ('The character NEXTLARGER than'); +@.The character NEXTLARGER...@> + ext_tag:@; + end + +@ @= +begin if exten[char_remainder[c]].b0>0 then + check_existence_and_safety(exten[char_remainder[c]].b0) + ('TOP piece of character'); +@.TOP piece of character...@> +if exten[char_remainder[c]].b1>0 then + check_existence_and_safety(exten[char_remainder[c]].b1) + ('MID piece of character'); +@.MID piece of character...@> +if exten[char_remainder[c]].b2>0 then + check_existence_and_safety(exten[char_remainder[c]].b2) + ('BOT piece of character'); +@.BOT piece of character...@> +check_existence_and_safety(exten[char_remainder[c]].b3) + ('REP piece of character'); +@.REP piece of character...@> +end + +@ @= +if char_tag[c]=list_tag then begin + g:=char_remainder[c]; + while (g + print_hex(c); print_ln('.'); + end; + end + +@ @= +@!delta:fix_word; {size of the intervals needed for rounding} + +@ @d round_message(#)==if delta>0 then print_ln('I had to round some ', +@.I had to round...@> + #,'s by ',(((delta+1) div 2)/@'4000000):1:7,' units.') + +@= +case ofm_level of + -1: begin + top_width:=255; top_depth:=15; top_height:=15; top_italic:=63; + end; + 0: begin + top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255; + end; + 1: begin + top_width:=65535; top_depth:=255; top_height:=255; top_italic:=255; + end; + end; +delta:=shorten(width,top_width); set_indices(width,delta); + round_message('width');@/ +delta:=shorten(height,top_height); set_indices(height,delta); + round_message('height');@/ +delta:=shorten(depth,top_depth); set_indices(depth,delta); + round_message('depth');@/ +delta:=shorten(italic,top_italic); set_indices(italic,delta); + round_message('italic correction'); + +@ @d clear_lig_kern_entry== {make an unconditional \.{STOP}} + lig_kern[nl].b0:=255; lig_kern[nl].b1:=0; + lig_kern[nl].b2:=0; lig_kern[nl].b3:=0 + +@= +begin if bchar_labelnl do begin + clear_lig_kern_entry; incr(nl); + end; +if (lig_kern[nl-1].b0 mod 256)=0 then + lig_kern[nl-1].b0:=lig_kern[nl-1].b0 div 256 * 256 + stop_flag; +end + +@ It's not trivial to check for infinite loops generated by repeated +insertion of ligature characters. But fortunately there is a nice +algorithm for such testing, copied here from the program \.{TFtoPL} +where it is explained further. + +@d simple=0 {$f(x,y)=z$} +@d left_z=1 {$f(x,y)=f(z,y)$} +@d right_z=2 {$f(x,y)=f(x,z)$} +@d both_z=3 {$f(x,y)=f(f(x,z),y)$} +@d pending=4 {$f(x,y)$ is being evaluated} + + +@ @= +@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|} +@!hash:array[0..hash_size] of integer; +@!class:array[0..hash_size] of simple..pending; +@!lig_z:array[0..hash_size] of xxchar_type; +@!hash_ptr:0..hash_size; {the number of nonzero entries in |hash|} +@!hash_list:array[0..hash_size] of 0..hash_size; {list of those nonzero entries} +@!h,@!hh:0..hash_size; {indices into the hash table} +@!tt:indx; {temporary register} +@!x_lig_cycle,@!y_lig_cycle:xchar_type; {problematic ligature pair} + +@ @= +hash_ptr:=0; y_lig_cycle:=xmax_char; +for k:=0 to hash_size do hash[k]:=0; + +@ @d lig_exam==lig_kern[lig_ptr].b1 +@d lig_gen==lig_kern[lig_ptr].b3 + +@= +begin lig_ptr:=char_remainder[c]; +if (lig_kern[lig_ptr].b0 div 256)=0 then +begin +repeat if hash_input(lig_ptr,c) then begin + if lig_kern[lig_ptr].b2bchar then + check_existence(lig_exam)('LIG character examined by'); +@.LIG character examined...@> + check_existence(lig_gen)('LIG character generated by'); +@.LIG character generated...@> + if lig_gen>=128 then if(c<128)or(c=bchar) then + if(lig_exam<128)or(lig_exam=bchar) then seven_unsafe:=true; + end + else if lig_exam<>bchar then + check_existence(lig_exam)('KRN character examined by'); +@.KRN character examined...@> + end; +if (lig_kern[lig_ptr].b0 mod 256)>=stop_flag then lig_ptr:=nl +else lig_ptr:=lig_ptr+1+lig_kern[lig_ptr].b0; +until lig_ptr>=nl; +end; +end + +@ The |hash_input| procedure is copied from \.{TFtoPL}, but it is made +into a boolean function that returns |false| if the ligature command +was masked by a previous one. + +@p function hash_input(@!p,@!c:indx):boolean; + {enter data for character |c| and command in location |p|, unless it isn't new} +label 30; {go here for a quick exit} +var @!cc:simple..both_z; {class of data being entered} +@!zz:char_type; {function value or ligature character being entered} +@!y:char_type; {the character after the cursor} +@!key:integer; {value to be stored in |hash|} +@!t:integer; {temporary register for swapping} +begin if hash_ptr=hash_size then + begin hash_input:=false; goto 30;@+end; +@; +key:=xmax_char*c+y+1; h:=(hash_mult*(key mod hash_size)) mod hash_size; +while hash[h]>0 do begin + if hash[h]<=key then begin + if hash[h]=key then begin + hash_input:=false; goto 30; {unused ligature command} + end; + t:=hash[h]; hash[h]:=key; key:=t; {do ordered-hash-table insertion} + t:=class[h]; class[h]:=cc; cc:=t; {namely, do a swap} + t:=lig_z[h]; lig_z[h]:=zz; zz:=t; + end; + if h>0 then decr(h)@+else h:=hash_size; + end; +hash[h]:=key; class[h]:=cc; lig_z[h]:=zz; +incr(hash_ptr); hash_list[hash_ptr]:=h; +hash_input:=true; +30:end; + +@ @= +y:=lig_kern[p].b1; t:=lig_kern[p].b2; cc:=simple; +zz:=lig_kern[p].b3; +if t>=kern_flag then zz:=y +else begin + case t of + 0,6:do_nothing; {\.{LIG},\.{/LIG>}} + 5,11:zz:=y; {\.{LIG/>}, \.{/LIG/>>}} + 1,7:cc:=left_z; {\.{LIG/}, \.{/LIG/>}} + 2:cc:=right_z; {\.{/LIG}} + 3:cc:=both_z; {\.{/LIG/}} + end; {there are no other cases} + end + +@ (More good stuff from \.{TFtoPL}.) + +@p function f(@!h,@!x,@!y:indx):indx; forward;@t\2@> + {compute $f$ for arguments known to be in |hash[h]|} +function eval(@!x,@!y:indx):indx; {compute $f(x,y)$ with hashtable lookup} +var @!key:integer; {value sought in hash table} +begin key:=xmax_char*x+y+1; h:=(hash_mult*key) mod hash_size; +while hash[h]>key do + if h>0 then decr(h)@+else h:=hash_size; +if hash[h]= +if hash_ptrsimple then {make sure $f$ is well defined} + tt:=f(tt,(hash[tt]-1)div xmax_char,(hash[tt]-1)mod xmax_char); + end; +if(hash_ptr=hash_size)or(y_lig_cycle + if x_lig_cycle=xmax_char + then print('boundary')@+else print_hex(x_lig_cycle); + print(' and '); print_hex(y_lig_cycle); print_ln('!'); + end + else print_ln('Sorry, I haven''t room for so many ligature/kern pairs!'); +@.Sorry, I haven't room...@> + print_ln('All ligatures will be cleared.'); + for c:=0 to max_char do if char_tag[c]=lig_tag then begin + char_tag[c]:=no_tag; char_remainder[c]:=0; + end; + nl:=0; bchar:=xmax_char; bchar_label:=xmax_label; + end + +@ The lig/kern program may still contain references to nonexistent characters, +if parts of that program are never used. Similarly, there may be extensible +characters that are never used, because they were overridden by +\.{NEXTLARGER}, say. This would produce an invalid \.{TFM} file; so we +must fix such errors. + +@d double_check_tail(#)==@t\1@>if char_wd[0]=0 + then char_wd[0]:=sort_in(width,0); + print('Unused ',#,' refers to nonexistent character '); + print_hex(c); print_ln('!'); + end; + end +@d double_check_lig(#)==begin c:=lig_kern[lig_ptr].#; + if char_wd[c]=0 then if c<>bchar then + begin lig_kern[lig_ptr].#:=0; double_check_tail +@d double_check_ext(#)==begin c:=exten[g].#; + if c>0 then if char_wd[c]=0 then + begin exten[g].#:=0; double_check_tail +@d double_check_rep(#)==begin c:=exten[g].#; + if char_wd[c]=0 then + begin exten[g].#:=0; double_check_tail + +@= +if nl>0 then for lig_ptr:=0 to nl-1 do + if (lig_kern[lig_ptr].b0 div 256)=0 then begin + if lig_kern[lig_ptr].b2 +@.Unused KRN step...@> +if ne>0 then for g:=0 to ne-1 do begin + double_check_ext(b0)('VARCHAR TOP'); + double_check_ext(b1)('VARCHAR MID'); + double_check_ext(b2)('VARCHAR BOT'); + double_check_rep(b3)('VARCHAR REP'); +@.Unused VARCHAR...@> + end + +@* The output phase. +Now that we know how to get all of the font data correctly stored in +\.{PLtoTF}'s memory, it only remains to write the answers out. + +First of all, it is convenient to have an abbreviation for output to the +\.{TFM} file: + +@d out(#)==write(tfm_file,#) + +@ The general plan for producing \.{TFM} files is long but simple: + +@= +compute_subfile_sizes; +output_subfile_sizes; +@; +output_new_information_ofm; +output_character_info; +@; +@; +@; +@; + +@ A \.{TFM} file begins with 12 numbers that tell how big its subfiles are. +We already know most of these numbers; for example, the number of distinct +widths is |memory[width]+1|, where the $+1$ accounts for the zero width that +is always supposed to be present. But we still should compute the beginning +and ending character codes (|bc| and |ec|), the number of header words (|lh|), +and the total number of words in the \.{TFM} file (|lf|). + +@= +@!bc:byte; {the smallest character code in the font} +@!ec:byte; {the largest character code in the font} +@!lh:byte; {the number of words in the header block} +@!lf:unsigned_integer; {the number of words in the entire \.{TFM} file} +@!not_found:boolean; {has a font character been found?} +@!temp_width:fix_word; {width being used to compute a check sum} +@!ncw,@!nco,@!npc:integer; + +@ It might turn out that no characters exist at all. But \.{PLtoTF} keeps +going and writes the \.{TFM} anyway. In this case |ec| will be~0 and |bc| +will be~1. + +@= +case ofm_level of + -1: begin + lh:=header_ptr div 4;@/ + not_found:=true; bc:=0; + while not_found do + if (char_wd[bc]>0)or(bc=255) then not_found:=false + else incr(bc); + not_found:=true; ec:=255; + while not_found do + if (char_wd[ec]>0)or(ec=0) then not_found:=false + else decr(ec); + if bc>ec then bc:=1; + incr(memory[width]); incr(memory[height]); incr(memory[depth]); + incr(memory[italic]);@/ + @; + lf:=6+lh+(ec-bc+1)+memory[width]+memory[height]+memory[depth]+ + memory[italic]+nl+lk_offset+nk+ne+np; + end; + 0: begin + lh:=header_ptr div 4;@/ + not_found:=true; bc:=0; + while not_found do + if (char_wd[bc]>0)or(bc=max_char) then not_found:=false + else incr(bc); + not_found:=true; ec:=max_char; + while not_found do + if (char_wd[ec]>0)or(ec=0) then not_found:=false + else decr(ec); + if bc>ec then bc:=1; + incr(memory[width]); incr(memory[height]); incr(memory[depth]); + incr(memory[italic]);@/ + @; + lf:=14+lh+2*(ec-bc+1)+memory[width]+memory[height]+memory[depth]+ + memory[italic]+2*nl+lk_offset+nk+2*ne+np; + end; + 1: begin + lh:=header_ptr div 4;@/ + not_found:=true; bc:=0; + while not_found do + if (char_wd[bc]>0)or(bc=max_char) then not_found:=false + else incr(bc); + not_found:=true; ec:=max_char; + while not_found do + if (char_wd[ec]>0)or(ec=0) then not_found:=false + else decr(ec); + if bc>ec then bc:=1; + incr(memory[width]); incr(memory[height]); incr(memory[depth]); + incr(memory[italic]);@/ + @; + @; + lf:=29+lh+ncw+memory[width]+memory[height]+memory[depth]+ + memory[italic]+2*(nl+lk_offset)+nk+2*ne+np+ + nki+nwi+nkf+nwf+nkm+nwm++nkr+nwr+nkg+nwg+nkp+nwp; + nco:=29+lh+nki+nwi+nkf+nwf+nkm+nwm++nkr+nwr+nkg+nwg+nkp+nwp; + end; + end; + +@ @d out_size(#)==out((#) div 256); out((#) mod 256) + @d out_integer(#)==out((#) div @"1000000); + out(((#) mod @"1000000) div @"10000); + out(((#) mod @"10000) div @"100); + out((#) mod @"100) + +@= +case ofm_level of + -1: begin + out_size(lf); out_size(lh); out_size(bc); out_size(ec); + out_size(memory[width]); out_size(memory[height]); + out_size(memory[depth]); out_size(memory[italic]); + out_size(nl+lk_offset); out_size(nk); out_size(ne); out_size(np); + end; + 0: begin + out_integer(0); + out_integer(lf); out_integer(lh); out_integer(bc); out_integer(ec); + out_integer(memory[width]); out_integer(memory[height]); + out_integer(memory[depth]); out_integer(memory[italic]); + out_integer(nl+lk_offset); out_integer(nk); + out_integer(ne); out_integer(np); out_integer(font_dir); + end; + 1: begin + out_integer(1); + out_integer(lf); out_integer(lh); + out_integer(bc); out_integer(ec); + out_integer(memory[width]); out_integer(memory[height]); + out_integer(memory[depth]); out_integer(memory[italic]); + out_integer(nl+lk_offset); out_integer(nk); + out_integer(ne); out_integer(np); out_integer(font_dir); + out_integer(nco); out_integer(ncw); out_integer(npc); + out_integer(nki); out_integer(nwi); out_integer(nkf); out_integer(nwf); + out_integer(nkm); out_integer(nwm); out_integer(nkr); out_integer(nwr); + out_integer(nkg); out_integer(nwg); out_integer(nkp); out_integer(nwp); + end; + end; + +@ The routines that follow need a few temporary variables of different types. + +@= +@!j:0..max_header_bytes; {index into |header_bytes|} +@!p:pointer; {index into |memory|} +@!q:width..italic; {runs through the list heads for dimensions} +@!par_ptr:0..max_param_words; {runs through the parameters} + +@ The header block follows the subfile sizes. The necessary information all +appears in |header_bytes|, except that the design size and the seven-bit-safe +flag must still be set. + +@= +if not check_sum_specified then @; +header_bytes[design_size_loc]:=design_size div @'100000000; + {this works since |design_size>0|} +header_bytes[design_size_loc+1]:=(design_size div @'200000) mod 256; +header_bytes[design_size_loc+2]:=(design_size div 256) mod 256; +header_bytes[design_size_loc+3]:=design_size mod 256; +if not seven_unsafe then header_bytes[seven_flag_loc]:=128; +for j:=0 to header_ptr-1 do out(header_bytes[j]); + +@ @= +begin c0:=bc; c1:=ec; c2:=bc; c3:=ec; +for c:=bc to ec do if char_wd[c]>0 then begin + temp_width:=memory[char_wd[c]]; + if design_units<>unity then + temp_width:=round((temp_width/design_units)*1048576.0); + temp_width:=temp_width + (c+4)*@'20000000; {this should be positive} + c0:=(c0+c0+temp_width) mod 255; + c1:=(c1+c1+temp_width) mod 253; + c2:=(c2+c2+temp_width) mod 251; + c3:=(c3+c3+temp_width) mod 247; + end; +header_bytes[check_sum_loc]:=c0; +header_bytes[check_sum_loc+1]:=c1; +header_bytes[check_sum_loc+2]:=c2; +header_bytes[check_sum_loc+3]:=c3; +end + +@ @= +@!tab:integer; + +@ +@= +if ofm_level=1 then begin + ncw:=0; + if nkcp>-1 then + npc:=nki+nkf+nkr+nkg+nkcp+1 + else if nkcg>-1 then + npc:=nki+nkf+nkr+nkcg+1 + else if nkcr>-1 then + npc:=nki+nkf+nkcr+1 + else if nkcf>-1 then + npc:=nki+nkcf+1 + else if nkci>-1 then + npc:=nkci+1 + else + npc:=0; + needed_space:=(12+npc*2) div 4; + extra_bytes:=(needed_space*4) - (10+npc*2); + for c:=bc to ec do begin + if char_original[c]=c then begin + cprime:=c+1; + diff:=false; + while (not diff) and (cprime<=ec) do begin + if index[char_wd[c]]<>index[char_wd[cprime]] then diff:=true; + if index[char_ht[c]]<>index[char_ht[cprime]] then diff:=true; + if index[char_dp[c]]<>index[char_dp[cprime]] then diff:=true; + if index[char_ic[c]]<>index[char_ic[cprime]] then diff:=true; + if char_remainder[c]<>char_remainder[cprime] then diff:=true; + for tab:=0 to npc-1 do begin + if char_table[c,tab]<>char_table[cprime,tab] then diff:=true; + end; + if not diff then begin + char_original[cprime]:=c; + cprime:=cprime+1; + end; + end; + if cprime>(c+1) then begin + char_repeats[c]:=cprime-c-1; + end; + ncw:=ncw+needed_space; + end; + end; + end; + +@ The next block contains packed |char_info|. + +@= +index[0]:=0; +for c:=bc to ec do +case ofm_level of + -1: begin + out(index[char_wd[c]]); + out(index[char_ht[c]]*16+index[char_dp[c]]); + out(index[char_ic[c]]*4+char_tag[c]); + out(char_remainder[c]); + end; + 0: begin + out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256); + out(index[char_ht[c]]); out(index[char_dp[c]]); + out(index[char_ic[c]] div 64);out((index[char_ic[c]] mod 64)*4+char_tag[c]); + out(char_remainder[c] div 256); out(char_remainder[c] mod 256); + end; + 1: begin + if c=char_original[c] then begin + out(index[char_wd[c]] div 256); out(index[char_wd[c]] mod 256); + out(index[char_ht[c]]); out(index[char_dp[c]]); + out(index[char_ic[c]]); + tab:=char_tag[c]; + if char_extended_tag[c] then begin + tab:=5; + end; + out(tab); + out(char_remainder[c] div 256); out(char_remainder[c] mod 256); + out_size(char_repeats[c]); + for tab:=0 to npc-1 do begin + out(char_table[c,tab] div 256); out(char_table[c,tab] mod 256); + end; + for tab:=1 to extra_bytes do begin + out(0); + end; + end; + end; + end; + + +@ When a scaled quantity is output, we may need to divide it by |design_units|. +The following subroutine takes care of this, using floating point arithmetic +only if |design_units<>1.0|. + +@p procedure out_scaled(x:fix_word); {outputs a scaled |fix_word|} +var @!n:byte; {the first byte after the sign} +@!m:0..65535; {the two least significant bytes} +begin if abs(x/design_units)>=16.0 then begin + print_ln('The relative dimension ',x/@'4000000:1:3, + ' is too large.'); +@.The relative dimension...@> + print(' (Must be less than 16*designsize'); + if design_units<>unity then print(' =',design_units/@'200000:1:3, + ' designunits'); + print_ln(')'); x:=0; + end; +if design_units<>unity then x:=round((x/design_units)*1048576.0); +if x<0 then begin + out(255); x:=x+@'100000000; + if x<=0 then x:=1; + end +else begin out(0); + if x>=@'100000000 then x:=@'77777777; + end; +n:=x div @'200000; m:=x mod @'200000; +out(n); out(m div 256); out(m mod 256); +end; + +@ We have output the packed indices for individual characters. +The scaled widths, heights, depths, and italic corrections are next. + +@= +for q:=width to italic do begin + out(0); out(0); out(0); out(0); {output the zero word} + p:=link[q]; {head of list} + while p>0 do begin + out_scaled(memory[p]); + p:=link[p]; + end; + end; + +@ One embarrassing problem remains: The ligature/kern program might be very +long, but the starting addresses in |char_remainder| can be at most~255. +Therefore we need to output some indirect address information; we want to +compute |lk_offset| so that addition of |lk_offset| to all remainders makes +all but |lk_offset| distinct remainders less than~256. + +For this we need a sorted table of all relevant remainders. + +@= +@!label_table:array[xchar_type] of record + @!rr: -1..xmax_label; {sorted label values} + @!cc: integer; {associated characters} + end; +@!label_ptr:xchar_type; {index of highest entry in |label_table|} +@!sort_ptr:xchar_type; {index into |label_table|} +@!lk_offset:xchar_type; {smallest offset value that might work} +@!t:0..xmax_label; {label value that is being redirected} +@!extra_loc_needed:boolean; {do we need a special word for |bchar|?} + +@ @= +@; +if bchar; +if bchar_label= +label_ptr:=0; label_table[0].rr:=-1; {sentinel} +for c:=bc to ec do if char_tag[c]=lig_tag then begin + sort_ptr:=label_ptr; {there's a hole at position |sort_ptr+1|} + while label_table[sort_ptr].rr>char_remainder[c] do begin + label_table[sort_ptr+1]:=label_table[sort_ptr]; + decr(sort_ptr); {move the hole} + end; + label_table[sort_ptr+1].cc:=c; + label_table[sort_ptr+1].rr:=char_remainder[c]; + incr(label_ptr); + end + +@ @= +begin sort_ptr:=label_ptr; {the largest unallocated label} +if ofm_level=-1 then begin + if label_table[sort_ptr].rr+lk_offset > 255 then begin + lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty} + repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset; + while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin + decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset; + end; + incr(lk_offset); decr(sort_ptr); + until lk_offset+label_table[sort_ptr].rr<256; + {N.B.: |lk_offset=256| satisfies this when |sort_ptr=0|} + end; + end +else begin + if label_table[sort_ptr].rr+lk_offset > 65535 then begin + lk_offset:=0; extra_loc_needed:=false; {location 0 can do double duty} + repeat char_remainder[label_table[sort_ptr].cc]:=lk_offset; + while label_table[sort_ptr-1].rr=label_table[sort_ptr].rr do begin + decr(sort_ptr); char_remainder[label_table[sort_ptr].cc]:=lk_offset; + end; + incr(lk_offset); decr(sort_ptr); + until lk_offset+label_table[sort_ptr].rr<65536; + {N.B.: |lk_offset=65536| satisfies this when |sort_ptr=0|} + end; + end; +if lk_offset>0 then while sort_ptr>0 do begin + char_remainder[label_table[sort_ptr].cc]:= + char_remainder[label_table[sort_ptr].cc]+lk_offset; + decr(sort_ptr); + end; +end + +@ @= +if ofm_level=-1 then begin + if extra_loc_needed then begin {|lk_offset=1|} + out(255); out(bchar); out(0); out(0); + end + else for sort_ptr:=1 to lk_offset do begin {output the redirection specs} + t:=label_table[label_ptr].rr; + if bchar<256 then begin + out(255); out(bchar); + end + else begin + out(254); out(0); + end; + out_size(t+lk_offset); + repeat decr(label_ptr); until label_table[label_ptr].rr0 then for lig_ptr:=0 to nl-1 do begin + out(lig_kern[lig_ptr].b0); + out(lig_kern[lig_ptr].b1); + out(lig_kern[lig_ptr].b2); + out(lig_kern[lig_ptr].b3); + end; + if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr]) + end +else begin + if extra_loc_needed then {|lk_offset=1|} begin + out_size(255); out_size(bchar); out_size(0); out_size(0); + end + else + for sort_ptr:=1 to lk_offset do {output the redirection specs} begin + t:=label_table[label_ptr].rr; + if bchar0 then for lig_ptr:=0 to nl-1 do begin + out_size(lig_kern[lig_ptr].b0); + out_size(lig_kern[lig_ptr].b1); + out_size(lig_kern[lig_ptr].b2); + out_size(lig_kern[lig_ptr].b3); + end; + if nk>0 then for krn_ptr:=0 to nk-1 do out_scaled(kern[krn_ptr]) + end + +@ @= +if ofm_level=-1 then begin + if ne>0 then for c:=0 to ne-1 do begin + out(exten[c].b0); + out(exten[c].b1); + out(exten[c].b2); + out(exten[c].b3); + end; + end +else begin + if ne>0 then for c:=0 to ne-1 do begin + out_size(exten[c].b0); + out_size(exten[c].b1); + out_size(exten[c].b2); + out_size(exten[c].b3); + end; + end; + +@ For our grand finale, we wind everything up by outputting the parameters. + +@= +for par_ptr:=1 to np do begin + if par_ptr=1 then + @ + else out_scaled(param[par_ptr]); + end + +@ @= +begin if param[1]<0 then begin + param[1]:=param[1]+@'10000000000; + out((param[1] div @'100000000)+256-64); + end +else out(param[1] div @'100000000); +out((param[1] div @'200000) mod 256); +out((param[1] div 256) mod 256); +out(param[1] mod 256); +end + +@* The main program. +The routines sketched out so far need to be packaged into separate procedures, +on some systems, since some \PASCAL\ compilers place a strict limit on the +size of a routine. The packaging is done here in an attempt to avoid some +system-dependent changes. + +@p procedure param_enter; +begin @; +end; +@# +procedure name_enter; {enter all names and their equivalents} +begin @; +param_enter; +end; +@# +procedure read_lig_kern; +var @!krn_ptr:0..max_kerns; {an index into |kern|} +@!c:integer; {runs through all character codes} +begin @; +end; +@# +procedure output_new_information_ofm; +begin @; +end; +@# +procedure compute_new_header_ofm; +begin @; +end; +@# +procedure finish_extended_font; +begin @; +end; +@# +procedure output_subfile_sizes; +begin @; +end; +@# +procedure compute_subfile_sizes; +begin @; +end; +@# +procedure output_character_info; +begin @; +end; +@# +procedure read_font_rule_list; +begin @; +end; +@# +procedure read_font_glue_list; +begin @; +end; +@# +procedure read_font_penalty_list; +begin @; +end; +@# +procedure read_font_mvalue_list; +begin @; +end; +@# +procedure read_font_fvalue_list; +begin @; +end; +@# +procedure read_font_ivalue_list; +begin @; +end; +@# +procedure read_repeated_character_info; +begin @; +end; +@# +procedure read_lig_kern_command; +begin @; +end; +@# +procedure read_character_property; +begin @; +end; +@# +procedure read_char_info; +begin @; +end; +@# +procedure read_input; +var @!c:integer; {header or parameter index} +begin @; +end; +@# +procedure corr_and_check; +var @!c:integer; {runs through all character codes} +@!hh:0..hash_size; {an index into |hash_list|} +@!lig_ptr:0..max_lig_steps; {an index into |lig_kern|} +@!g:byte; {a character generated by the current character |c|} +begin @ +end; + +@ Here is where \.{PLtoTF} begins and ends. + +@p begin initialize;@/ +name_enter;@/ +read_input; print('.');@/ +corr_and_check;@/ +@; +end. + +@ @= +@!ofm_level:integer; + +@ @= +ofm_level:=-1; {Suppose that it is a TFM file} + +@ @= +begin +ofm_level:=get_integer; +if (ofm_level<0) or (ofm_level>1) then begin + flush_error('OFMLEVEL must be 0 or 1 -- 1 assumed'); + ofm_level:=1; + end; +end + +@ @= +begin +font_dir:=-1; +repeat get_next; +until cur_char<>" "; +case cur_char of + "T": begin get_next; + if cur_char="L" then font_dir:=0 + else if cur_char="R" then font_dir:=2; + end; + "B": begin get_next; + if cur_char="L" then font_dir:=4 + else if cur_char="R" then font_dir:=6; + end; + "R": begin get_next; + if cur_char="T" then font_dir:=5 + else if cur_char="B" then font_dir:=7; + end; + "L": begin get_next; + if cur_char="T" then font_dir:=1 + else if cur_char="B" then font_dir:=3; + end; + end; +while cur_char<>")" do get_next; +if font_dir = -1 then begin + flush_error('FONTDIR must be valid direction, -- TR assumed'); + font_dir:=0; + end; +end + +@ @= +begin +font_dir:=-1; +repeat get_next; +until cur_char<>" "; +case cur_char of + "T": begin get_next; + if cur_char="L" then font_dir:=8 + else if cur_char="R" then font_dir:=10; + end; + "B": begin get_next; + if cur_char="L" then font_dir:=12 + else if cur_char="R" then font_dir:=14; + end; + "R": begin get_next; + if cur_char="T" then font_dir:=13 + else if cur_char="B" then font_dir:=15; + end; + "L": begin get_next; + if cur_char="T" then font_dir:=9 + else if cur_char="B" then font_dir:=11; + end; + end; +while cur_char<>")" do get_next; +if font_dir = -1 then begin + flush_error('NFONTDIR must be valid direction, -- TR assumed'); + font_dir:=8; + end; +end + +@ +Here are some general values for the various entries. +They can all be changed. + +@d arrays_per_kind==20 +@d entries_per_array==200 + +@ @= +@!rule_arrays=arrays_per_kind; +@!rule_entries=entries_per_array; + +@ @= +rule_array_type=0..rule_arrays; +rule_entry_type=0..rule_entries; +rule_node= +record + rn_width: fix_word; + rn_height: fix_word; + rn_depth: fix_word; +end; + +@ @= +@!rules:array[rule_array_type,rule_entry_type] of rule_node; +@!npr:array[rule_array_type] of integer; +@!nkr:integer; +@!nkcr:integer; +@!nwr:integer; +@!r_array:integer; +@!r_number:integer; + +@ @= +for r_array := 0 to rule_arrays do begin + npr[r_array]:=0; + @; + end; +nkr:=-1; +nkcr:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +r_array:=get_integer; +if r_array>rule_arrays then + flush_error('This FONTRULE table index is too big for my present size') +else if r_array<0 then + flush_error('This FONTRULE index is negative') +else begin + if r_array>nkr then nkr:=r_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>rule_code then + flush_error('This property name doesn''t belong in a RULE list') +else begin + r_number:=get_integer; + if r_number>rule_entries then + flush_error('This RULE index is too big for my present table size') + else if r_number<0 then + flush_error('This RULE index is negative') + else begin + while npr[r_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +rules[r_array,npr[r_array]].rn_width:=0; +rules[r_array,npr[r_array]].rn_depth:=0; +rules[r_array,npr[r_array]].rn_height:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + rule_width_code: + rules[r_array,r_number].rn_width:=get_fix; + rule_height_code: + rules[r_array,r_number].rn_height:=get_fix; + rule_depth_code: + rules[r_array,r_number].rn_depth:=get_fix; + end; +finish_the_property; +end + +@ @
= +begin +nwr:=0; +for r_array := 0 to nkr do begin + incr(npr[r_array]); + nwr := nwr + 3*npr[r_array]; + end; +incr(nkr); +end + +@ @= +begin +for r_array:= 0 to nkr-1 do + for r_number:=0 to npr[r_array]-1 do begin + out_scaled(rules[r_array,r_number].rn_width); + out_scaled(rules[r_array,r_number].rn_height); + out_scaled(rules[r_array,r_number].rn_depth); + end; +end + +@ @= +begin +for r_array:= 0 to nkr-1 do begin + out_integer(npr[r_array]); + end; +end + +@ @= +@!glue_arrays=arrays_per_kind; +@!glue_entries=entries_per_array; + +@ +@d t_normal==0 +@d t_aleaders==1 +@d t_cleaders==2 +@d t_xleaders==3 + +@d o_unit==0 +@d o_fi==1 +@d o_fil==2 +@d o_fill==3 +@d o_filll==4 + +@d g_space==0 +@d g_rule==1 +@d g_char==2 + +@= +glue_array_type=0..glue_arrays; +glue_entry_type=0..glue_entries; +glue_node= +record + gn_width: fix_word; + gn_stretch: fix_word; + gn_shrink: fix_word; + gn_type: integer; + gn_arg_type: g_space..g_char; + gn_stretch_order: integer; + gn_shrink_order: integer; + gn_argument: integer; +end; + +@ @= +@!glues:array[glue_array_type,glue_entry_type] of glue_node; +@!npg:array[glue_array_type] of integer; +@!nkg:integer; +@!nkcg:integer; +@!nwg:integer; +@!g_array:integer; +@!g_byte:integer; +@!g_number:integer; + +@ @= +for g_array := 0 to glue_arrays do +begin + npg[g_array]:=0; + @; +end; +nkg:=-1; +nkcg:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +g_array:=get_integer; +if g_array>glue_arrays then + flush_error('This FONTGLUE table index is too big for my present size') +else if g_array<0 then + flush_error('This FONTGLUE index is negative') +else begin + if g_array>nkg then nkg:=g_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>glue_code then + flush_error('This property name doesn''t belong in a GLUE list') +else begin + g_number:=get_integer; + if g_number>glue_entries then + flush_error('This GLUE index is too big for my present table size') + else if g_number<0 then + flush_error('This GLUE index is negative') + else begin + while npg[g_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +glues[g_array,npg[g_array]].gn_width:=0; +glues[g_array,npg[g_array]].gn_stretch:=0; +glues[g_array,npg[g_array]].gn_shrink:=0; +glues[g_array,npg[g_array]].gn_type:=0; +glues[g_array,npg[g_array]].gn_arg_type:=0; +glues[g_array,npg[g_array]].gn_stretch_order:=0; +glues[g_array,npg[g_array]].gn_shrink_order:=0; +glues[g_array,npg[g_array]].gn_argument:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + glue_width_code: + glues[g_array,g_number].gn_width:=get_fix; + glue_stretch_code: + glues[g_array,g_number].gn_stretch:=get_fix; + glue_shrink_code: + glues[g_array,g_number].gn_shrink:=get_fix; + glue_type_code: begin + g_byte:=get_integer; + if (g_byte<0) or (g_byte>3) then begin + g_byte:=0; + end; + glues[g_array,g_number].gn_type:=g_byte; + end; + glue_stretch_order_code: begin + g_byte:=get_integer; + if (g_byte<0) or (g_byte>4) then begin + g_byte:=0; + end; + glues[g_array,g_number].gn_stretch_order:=g_byte; + end; + glue_shrink_order_code: begin + g_byte:=get_integer; + if (g_byte<0) or (g_byte>4) then begin + g_byte:=0; + end; + glues[g_array,g_number].gn_shrink_order:=g_byte; + end; + glue_char_code: begin + glues[g_array,g_number].gn_argument:=get_integer; + glues[g_array,g_number].gn_arg_type:=g_char; + end; + glue_rule_code: begin + glues[g_array,g_number].gn_argument:=get_integer; + glues[g_array,g_number].gn_arg_type:=g_rule; + end; + end; +finish_the_property; +end + +@ @
= +begin +nwg:=0; +for g_array := 0 to nkg do begin + incr(npg[g_array]); + nwg := nwg + 4*npg[g_array]; + end; +incr(nkg); +end + +@ @= +begin +for g_array:= 0 to nkg-1 do + for g_number:=0 to npg[g_array]-1 do begin + g_byte:=glues[g_array,g_number].gn_type*16+ + glues[g_array,g_number].gn_arg_type; + out(g_byte); + g_byte:=glues[g_array,g_number].gn_stretch_order*16+ + glues[g_array,g_number].gn_shrink_order; + out(g_byte); + g_byte:=glues[g_array,g_number].gn_argument div 256; + out(g_byte); + g_byte:=glues[g_array,g_number].gn_argument mod 256; + out(g_byte); + out_scaled(glues[g_array,g_number].gn_width); + out_scaled(glues[g_array,g_number].gn_stretch); + out_scaled(glues[g_array,g_number].gn_shrink); + end; +end + +@ @= +begin +for g_array:= 0 to nkg-1 do begin + out_integer(npg[g_array]); + end; +end + +@ @= +@!penalty_arrays=arrays_per_kind; +@!penalty_entries=entries_per_array; + +@ @= +penalty_array_type=0..penalty_arrays; +penalty_entry_type=0..penalty_entries; +penalty_node= +record + pn_val: integer; +end; + +@ @= +@!penalties:array[penalty_array_type,penalty_entry_type] of penalty_node; +@!npp:array[penalty_array_type] of integer; +@!nkp:integer; +@!nkcp:integer; +@!nwp:integer; +@!p_array:integer; +@!p_number:integer; + +@ @= +for p_array := 0 to penalty_arrays do begin + npp[p_array]:=0; + @; + end; +nkp:=-1; +nkcp:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +p_array:=get_integer; +if p_array>penalty_arrays then + flush_error('This FONTPENALTY table index is too big for my present size') +else if p_array<0 then + flush_error('This FONTPENALTY index is negative') +else begin + if p_array>nkp then nkp:=p_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>penalty_code then + flush_error('This property name doesn''t belong in a PENALTY list') +else begin + p_number:=get_integer; + if p_number>penalty_entries then + flush_error('This PENALTY index is too big for my present table size') + else if p_number<0 then + flush_error('This PENALTY index is negative') + else begin + while npp[p_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +penalties[p_array,npp[p_array]].pn_val:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + penalty_val_code: + penalties[p_array,p_number].pn_val:=get_integer; + end; +finish_the_property; +end + +@ @
= +begin +nwp:=0; +for p_array := 0 to nkp do begin + incr(npp[p_array]); + nwp := nwp + npp[p_array]; + end; +incr(nkp); +end + +@ @= +begin +for p_array:= 0 to nkp-1 do + for p_number:=0 to npp[p_array]-1 do begin + out_integer(penalties[p_array,p_number].pn_val); + end; +end + +@ @= +begin +for p_array:= 0 to nkp-1 do begin + out_integer(npp[p_array]); + end; +end + +@ @= +@!mvalue_arrays=arrays_per_kind; +@!mvalue_entries=entries_per_array; + +@ @= +mvalue_array_type=0..mvalue_arrays; +mvalue_entry_type=0..mvalue_entries; +mvalue_node= +record + fn_val: fix_word; +end; + +@ @= +@!mvalues:array[mvalue_array_type,mvalue_entry_type] of mvalue_node; +@!npm:array[mvalue_array_type] of integer; +@!nkm:integer; +@!nkcm:integer; +@!nwm:integer; +@!m_array:integer; +@!m_number:integer; + +@ @= +for m_array := 0 to mvalue_arrays do begin + npm[m_array]:=0; + @; + end; +nkm:=-1; +nkcm:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +m_array:=get_integer; +if m_array>mvalue_arrays then + flush_error('This FONTMVALUE table index is too big for my present size') +else if m_array<0 then + flush_error('This FONTMVALUE index is negative') +else begin + if m_array>nkm then nkm:=m_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>mvalue_code then + flush_error('This property name doesn''t belong in an MVALUE list') +else begin + m_number:=get_integer; + if m_number>mvalue_entries then + flush_error('This MVALUE index is too big for my present table size') + else if m_number<0 then + flush_error('This MVALUE index is negative') + else begin + while npm[m_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +mvalues[m_array,npm[m_array]].fn_val:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + mvalue_val_code: + mvalues[m_array,m_number].fn_val:=get_fix; + end; +finish_the_property; +end + +@ @
= +begin +nwm:=0; +for m_array := 0 to nkm do begin + incr(npm[m_array]); + nwm := nwm + npm[m_array]; + end; +incr(nkm); +end + +@ @= +begin +for m_array:= 0 to nkm-1 do + for m_number:=0 to npm[m_array]-1 do begin + out_scaled(mvalues[m_array,m_number].fn_val); + end; +end + +@ @= +begin +for m_array:= 0 to nkm-1 do begin + out_integer(npm[m_array]); + end; +end + +@ @= +@!fvalue_arrays=arrays_per_kind; +@!fvalue_entries=entries_per_array; + +@ @= +fvalue_array_type=0..fvalue_arrays; +fvalue_entry_type=0..fvalue_entries; +fvalue_node= +record + fn_val: fix_word; +end; + +@ @= +@!fvalues:array[fvalue_array_type,fvalue_entry_type] of fvalue_node; +@!npf:array[fvalue_array_type] of integer; +@!nkf:integer; +@!nkcf:integer; +@!nwf:integer; +@!f_array:integer; +@!f_number:integer; + +@ @= +for f_array := 0 to fvalue_arrays do begin + npf[f_array]:=0; + @; + end; +nkf:=-1; +nkcf:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +f_array:=get_integer; +if f_array>fvalue_arrays then + flush_error('This FONTFVALUE table index is too big for my present size') +else if f_array<0 then + flush_error('This FONTFVALUE index is negative') +else begin + if f_array>nkf then nkf:=f_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>fvalue_code then + flush_error('This property name doesn''t belong in an FVALUE list') +else begin + f_number:=get_integer; + if f_number>fvalue_entries then + flush_error('This FVALUE index is too big for my present table size') + else if f_number<0 then + flush_error('This FVALUE index is negative') + else begin + while npf[f_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +fvalues[f_array,npf[f_array]].fn_val:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + fvalue_val_code: + fvalues[f_array,f_number].fn_val:=get_fix; + end; +finish_the_property; +end + +@ @
= +begin +nwf:=0; +for f_array := 0 to nkf do begin + incr(npf[f_array]); + nwf := nwf + npf[f_array]; + end; +incr(nkf); +end + +@ @= +begin +for f_array:= 0 to nkf-1 do + for f_number:=0 to npf[f_array]-1 do begin + out_scaled(fvalues[f_array,f_number].fn_val); + end; +end + +@ @= +begin +for f_array:= 0 to nkf-1 do begin + out_integer(npf[f_array]); + end; +end + +@ @= +@!ivalue_arrays=arrays_per_kind; +@!ivalue_entries=entries_per_array; + +@ @= +ivalue_array_type=0..ivalue_arrays; +ivalue_entry_type=0..ivalue_entries; +ivalue_node= +record + in_val: integer; +end; + +@ @= +@!ivalues:array[ivalue_array_type,ivalue_entry_type] of ivalue_node; +@!npi:array[ivalue_array_type] of integer; +@!font_i_array:boolean; +@!nki:integer; +@!nkci:integer; +@!nwi:integer; +@!i_array:integer; +@!i_number:integer; + +@ @= +for i_array := 0 to ivalue_arrays do begin + npi[i_array]:=0; + @; + end; +nki:=-1; +nkci:=-1; + +@ @= +begin +if tables_read then + flush_error('All parameter tables must appear before character info'); +i_array:=get_integer; +if i_array>ivalue_arrays then + flush_error('This FONTIVALUE table index is too big for my present size') +else if i_array<0 then + flush_error('This FONTIVALUE index is negative') +else begin + if i_array>nki then nki:=i_array; + while level=1 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; + finish_inner_property_list; + end; +end + +@ @= +begin +get_name; +if cur_code=comment_code then skip_to_end_of_item +else if cur_code<>ivalue_code then + flush_error('This property name doesn''t belong in an IVALUE list') +else begin + i_number:=get_integer; + if i_number>ivalue_entries then + flush_error('This IVALUE index is too big for my present table size') + else if i_number<0 then + flush_error('This IVALUE index is negative') + else begin + while npi[i_array]; + end; + @; + finish_the_property; + end; + end; +end + +@ @= +begin +ivalues[i_array,npi[i_array]].in_val:=0; +end + +@ @= +begin +while level=2 do begin + while cur_char=" " do get_next; + if cur_char="(" then @ + else if cur_char=")" then skip_to_end_of_item + else junk_error; + end; +finish_inner_property_list; +end + +@ @= +begin +get_name; +case cur_code of + ivalue_val_code: + ivalues[i_array,i_number].in_val:=get_integer; + end; +finish_the_property; +end + +@ @
= +begin +nwi:=0; +for i_array := 0 to nki do begin + incr(npi[i_array]); + nwi := nwi + npi[i_array]; + end; +incr(nki); +end + +@ @= +begin +for i_array:= 0 to nki-1 do + for i_number:=0 to npi[i_array]-1 do begin + out_integer(ivalues[i_array,i_number].in_val); + end; +end + +@ @= +begin +for i_array:= 0 to nki-1 do begin + out_integer(npi[i_array]); + end; +end + +@ @= +begin +@
; +@
; +@
; +@
; +@
; +@
; +end + +@ @= +begin +@; +@; +@; +@; +@; +@; +@; +@; +@; +@; +@; +end + +@* System-dependent changes. +This section should be replaced, if necessary, by changes to the program +that are necessary to make \.{PLtoTF} work at a particular installation. +It is usually best to design your change file so that all changes to +previous sections preserve the section numbering; then everybody's version +will be consistent with the printed program. More extensive changes, +which introduce new sections, can be inserted here; then only the index +itself will get a new section number. +@^system dependencies@> + +@* Index. +Pointers to error messages appear here together with the section numbers +where each ident\-i\-fier is used. -- cgit v1.2.3