summaryrefslogtreecommitdiff
path: root/obsolete/macros/text1/compugraphics_8600/fonttex.web
diff options
context:
space:
mode:
Diffstat (limited to 'obsolete/macros/text1/compugraphics_8600/fonttex.web')
-rw-r--r--obsolete/macros/text1/compugraphics_8600/fonttex.web1936
1 files changed, 1936 insertions, 0 deletions
diff --git a/obsolete/macros/text1/compugraphics_8600/fonttex.web b/obsolete/macros/text1/compugraphics_8600/fonttex.web
new file mode 100644
index 0000000000..6f2ce2858e
--- /dev/null
+++ b/obsolete/macros/text1/compugraphics_8600/fonttex.web
@@ -0,0 +1,1936 @@
+%test version
+\font\twelvept=cmbx12
+\font\tentex=cmr10
+\def\topofcontents{\null
+ \def\titlepage{T}
+ \centerline{{\twelvept The FONTTEX Program}}
+ \vskip15pt
+ \centerline{Version 2, July 1986}
+ \hbox{\vbox{\hsize\the\hsize This work is
+ protected as an unpublished work under U.S. copyright laws.
+ Copyright $\copyright$ 1986 by WSUCSC. All rights Reserved.}}
+ \vskip18pt
+ \hbox{\vbox{\hsize\the\hsize This software is furnished under a
+ license for
+ use only on a single computer system and may be copied only
+ with the inclusion of the above copyright notice.
+ This software, or any other copies
+ thereof, may not be provided or otherwise made available to any
+ other person except for use on such system and to one who agrees to
+ these license terms. Title to and ownership of the software shall
+ at all times remain in WSUCSC.}}
+ \vfill}
+
+@* Introduction.
+ This version of fonttex writes font and driver information
+ into elements. Infile, a data file, must be assigned prior
+ the font data.
+
+ Fonttex reads a font description source element, and creates
+ a \TeX\ font file (TFM) and an 8600 driver element.
+
+ The font description source is divided into three sections.
+ The first section includes comments and parameters for the
+ entire font, the second describes the individual characters,
+ and the third provides information about ligatures, kerns,
+ linked math characters, and limit conventions on math
+ operators. Numeric information is given as integers,
+ or fractions depending on the context in which it
+ occurs. All sizes given will be scaled by the point size by
+ \TeX\ and so should reflect the sizes for 1-point
+ type.
+
+ The first section can include comments, which begin with a
+ "*" in column one of the line. It also includes definitions
+ of numeric parameters for the \TeX\ and driver font files.
+ The parameter definitions consist of an alphabetic name
+ beginning in column 1 and ending with one or more blanks;
+ and a numeric value. Comments and parameters can be
+ interspersed. This section is ended by a line containing a
+ dollar sign in column 1. Although the order the parameters
+ are given in is not significant, we will discuss them in a
+ conventional order. The first two parameters are the
+ scaling factors for the heights, widths, and depths of the
+ characters given in section 2. These scaling factors are
+ called |HUNITS| and |VUNITS|. Both have real values. All
+ character widths are implicitly multiplied by |HUNITS|, and
+ all heights and depths by |VUNITS|. For the Compugraphic 8600
+ we use |HUNITS|=1/54 and |VUNITS|=1/64, because of the internal
+ units used on the machine. The next several parameters give
+ information about the font needed by the 8600 driver.
+ |DEFFONT| specifies a font number on the typesetter. Unless
+ otherwise defined, all characters in this file come from
+ this font. |DEFWIDTH| gives the width multiplier. All
+ character widths are also multiplied by |DEFWIDTH|. Typically
+ |DEFWIDTH| is 1, but it could be less for condensed type and
+ more for expanded type. The remaining parameters are for
+ the \TeX\ font file. They all take real values.
+
+ There should be 128 character entries in section two.
+ Information about character is given in free format columns,
+ which are separated by one or more blanks. Beginning in
+ column 1 is the character mnemonic. Most fonts use standard
+ ascii codes, so that character 65 is A, etc. For this
+ reason, any single character name will be checked to see
+ that it corresponds to the appropriate ascii value. If not a
+ warning is issued.
+ Following this may be the keyword
+ LIGATURE or BUILD describing ligatures and built-up math
+ delimiters. This is omitted for ordinary characters. The
+ ligature keyword indicates that this character should be
+ substituted for a combination of two other characters.
+ Following the keyword should be the names of the two
+ characters separated by a plus sign. For example, fi
+ LIGATURE f+i and: ff LIGATURE f+f ffl LIGATURE ff+l.
+ For the
+ BUILD keyword, the character will be made from pieces.
+ There can be a top, bottom, middle, and extension character.
+ All are optional except the extension character. This is
+ specified as BUILD keyword=charname,keyword=charname,...
+ For instance, bigparen BUILD
+ TOP=parentop,MID=parenmid,BOT=parenmid.
+ The third field of
+ information is the character width, the fourth the height,
+ and the fifth the depth. Widths are given relative to the
+ point size and are implicitly multiplied by the |HUNITS|
+ parameter. Likewise height and depth are relative and are
+ multiplied by |VUNITS|. For example, the typical value of
+ |HUNITS| is 1/54. Then a character width given as 27 means
+ that the character is 0.5 times the point size in width. The
+ point size will be determined when the file is referred to
+ in \TeX , and the character sizes will be multiplied by it as
+ the file is read into \TeX . The sixth column gives 8600
+ commands and character codes. The commands have integer or
+ real parameters. Most characters will have a single character
+ code, and will be selected from the default font. An
+ alternate font can be specified by the F command. 8600 code
+ can also include point size commands, psuedo-italic
+ commands, etc. Refer to the module discussing ``Reading the
+ 8600 Codes.''
+
+ The final section specifies kerns, linked math characters,
+ and math operator conventions. A kern is an amount of
+ horizontal space to be subtracted between two characters.
+ It is specified as KERN A+W 5/100 for instance, to shave
+ 5/100 of the point size between occurences of A and W.
+ Linking occurs in math extension fonts where various sizes
+ of parentheses, brackets, and so forth occur. To link one
+ character to the next larger size of the same symbol,
+ specify LINK charname1 charname2 Finally, a character is
+ specified to be a mathop by the MATHOP keyword. (Common
+ mathops are sum and integral signs.) Following the keyword
+ is the character name and a real number. If the real number
+ is zero, limits for the operator will be centered above and
+ below it in display style. If non-zero, limits are set to
+ the right of the symbol, and the lower limit is moved left
+ by this amount.
+
+ Some further detail on the methods and data structures used
+ by Fonttex. Widths, heights, depths, and italic corrections
+ are stored in arrays of reals (type realarray). Entry -1
+ gives the highest numbered entry used so far. When a height,
+ depth, etc is read from the input file, procedure |AddToList|
+ is called to add the value to the array and return the index
+ of the entry in the array. If two or more characters have
+ the same dimension, the value is stored only once and the
+ characters have identical indices pointing to it. In the TFM
+ format font files, each character has an index into the
+ width, height, depth, italic correction arrays, and the
+ arrays of values are given separately. (See TUGboat volume
+ 2, no 1; or the comments in Sysdep at |ReadFontInfo| for more
+ details on the font file format.)
+
+ Ligatures are specified by giving the name of the two
+ "component" characters of the ligature. These are saved in
+ an array of records, "lig" until the entire pre-file has
+ been read. Then a pass is made through these records to look
+ up all the names of the component characters, and a another
+ pass is made through the lig records to group them by the
+ first character of the ligature and add a pointer in the
+ outstuff array for that character pointing to the
+ ligature/kern program. The same is done with kern
+ specifications and the final pass over both is done
+ simultaneously.
+
+ Extendible characters made from top, bottom, middle, and
+ extension pieces are marked at the character entry, and the
+ names of the pieces are saved in array ext until the file
+ has been read. The tag value and pointer into the ext array
+ are set in outstuff when the line is read in |ReadBuildStuff|,
+ but the character numbers for the ext array itself are not
+ found until after the entire file has been read.
+
+ When records are written to the driver and font files they
+ can be displayed by compiling Fonttex with "drvdump" and
+ "dump" respectively set to true.
+
+@ Following are a few macros and definitions used throughout program:
+
+@d incr(#) == # := # + 1
+@d decr(#) == # := # - 1
+@d do_nothing == begin; end
+@d ccat==@=||@>
+@f static == var
+@f value == var
+
+@ The beginning of the program.
+
+@p program fonttex(terminal,sysprint,fontpkt,drvpkt,infile);
+const
+ @<Global Constants@>@/
+type
+ @<Global Types@>@/
+var
+ @<Global Variables@>@/
+static@/
+ @^system dependencies@>
+ com_table :packed array[0..18] of string(7);@/
+value@/
+ com_table[0] := 'HDR'; {Header Record}@/
+ com_table[1] := 'CHWIDTH';{Character Width}@/
+ com_table[2] := 'RT'; {Reverse Type}@/
+ com_table[3] := 'PS'; {Point Size}@/
+ com_table[4] := 'SS'; {Set Size}@/
+ com_table[5] := 'VMF'; {Vertical Move Forward}@/
+ com_table[6] := 'VMR'; {Vertical Move Reverse}@/
+ com_table[7] := 'RW'; {Rule Width}@/
+ com_table[8] := 'RD'; {Rule Depth}@/
+ com_table[9] := 'IR'; {Insert Rule}@/
+ com_table[10] := 'SL'; {Slant Mode}@/
+ com_table[11] := 'RTWT'; {Reverse Type Window Top}@/
+ com_table[12] := 'RTWB'; {Reverse Type Window Bottom}@/
+ com_table[13] := 'AU'; {Auxiliary Character Set}@/
+ com_table[14] := 'F'; {Change Fonts}@/
+ com_table[15] := 'HMR'; {Horizontal Move Right}@/
+ com_table[16] := 'HML'; {Horizontal Move Left}@/
+ com_table[17] := 'TTS'; {8600 character, in decimal}@/
+ com_table[18] := 'MAXCMD';@/
+%include pasclib(asciicvt)@/
+
+@* Beginning section.
+This section includes some basic functions for reading the DVI file
+as well as a couple of procedures, like error and allcaps. Nothing
+tricky or noteworthy in these.
+
+@<Global Constants@>=
+ maxkerns = 255;
+ num_entries = 128; {maximum number of characters entered}
+
+@
+@<Global Types@>=
+ oneoftwo = packed 1..2;
+ oneoffour = packed 1..4;
+ bytes4 = packed record
+ byte0 :packed 0..255;
+ byte1 :packed 0..255;
+ case oneoftwo of
+ 1 :(rhword :packed 0..65535);
+ 2 :(byte2 :packed 0..255;
+ byte3 :packed 0..255)
+ end;
+ charindex = 0..127;@\
+ comm = (HDR,CHWIDTH,RT,PS,SS,VMF,VMR,RW,RD,IR,SL,
+ RTWT,RTWB,AU,F,HMR,HML,TTS,MAXCMD);@\
+ driverrec = record
+ cmd :integer;
+ case oneoftwo of
+ 1 :(param :shortreal);
+ 2 :(code :integer);
+ end;
+ extrec = record
+ sourceline:integer;
+ topname,botname,extname,midname :string(40);
+ top,bot,mid,ext :charindex;
+ end;
+ fonttypes = (standard,mathex,mathsy);
+ halves2 = packed record
+ lhword :packed 0..65535;
+ case oneoftwo of
+ 1 :(rhword :packed 0..65535);
+ 2 :(byte2 :packed 0..255;
+ byte3 :packed 0..255)
+ end;
+ kernrec = record
+ frstchar :charindex;
+ scndchar :charindex;
+ kernslot :integer;
+ end;
+ ligrec = record
+ sourceline :integer;
+ firstname :string(40);
+ scndname :string(40);
+ frstchar :charindex;
+ scndchar :charindex;
+ ligcode :charindex;
+ end;
+ memoryword = packed record case oneoffour of
+ 1 :(pts :shortreal);
+ 2 :(int :integer);
+ 3 :(twohalves :halves2);
+ 4 :(fourbytes :bytes4)
+ end;
+ outarray = array[charindex] of memoryword;
+ parameter = (slant,spacee,spstretch,spshrink,
+ xheight,quad,extraspace,
+ raisen1,raisen2,raisen3,
+ denom1,denom2,sup1,sup2,
+ sup3,sub1,sub2,supdrop,subdrop,
+ dlims1,dlims2,axisheight,
+ defthickness,bgopsp1,
+ bgopsp2,bgopsp3,
+ bgopsp4,bgopsp5);
+ realarray = array[-1..num_entries] of real;
+
+@ This function will convert whatever is passed to it into
+all capital letters. It translates lower case letters into upper case
+letters. All other characters outside of the range
+a$<$=character$<$=z are returned as their original value.
+
+@^system dependencies@>
+@p function allcaps(instring :string(40)) :string(40);
+var
+ i :integer;
+ character :char;
+ buildit :string(40);
+static
+ chtable :packed array['81'xc..'e9'xc] of char;
+value
+ chtable['81'xc] := 'A';
+ chtable['82'xc] := 'B';
+ chtable['83'xc] := 'C';
+ chtable['84'xc] := 'D';
+ chtable['85'xc] := 'E';
+ chtable['86'xc] := 'F';
+ chtable['87'xc] := 'G';
+ chtable['88'xc] := 'H';
+ chtable['89'xc] := 'I';
+ chtable['91'xc] := 'J';
+ chtable['92'xc] := 'K';
+ chtable['93'xc] := 'L';
+ chtable['94'xc] := 'M';
+ chtable['95'xc] := 'N';
+ chtable['96'xc] := 'O';
+ chtable['97'xc] := 'P';
+ chtable['98'xc] := 'Q';
+ chtable['99'xc] := 'R';
+ chtable['a2'xc] := 'S';
+ chtable['a3'xc] := 'T';
+ chtable['a4'xc] := 'U';
+ chtable['a5'xc] := 'V';
+ chtable['a6'xc] := 'W';
+ chtable['a7'xc] := 'X';
+ chtable['a8'xc] := 'Y';
+ chtable['a9'xc] := 'Z';
+begin
+ buildit := '';
+ for i := 1 to length(instring) do begin
+ readstr(substr(instring,i,1),character);
+ if character in ['a'..'z']
+ then buildit := buildit || str(chtable[character])
+ else buildit := buildit || str(character);
+ end;
+ allcaps := buildit;
+ end;
+
+@ This function receives an integer value and converts it to its
+hex value and returns that value as a string.
+
+@^system dependencies@>
+@p function hex(int :integer) :string(8);
+var
+ i :integer;
+ j :integer;
+ k16 :integer;
+ stri :string(8);
+static
+ hexarray :array[0..15] of string(1);
+value
+ hexarray[0] := '0';
+ hexarray[1] := '1';
+ hexarray[2] := '2';
+ hexarray[3] := '3';
+ hexarray[4] := '4';
+ hexarray[5] := '5';
+ hexarray[6] := '6';
+ hexarray[7] := '7';
+ hexarray[8] := '8';
+ hexarray[9] := '9';
+ hexarray[10] := 'A';
+ hexarray[11] := 'B';
+ hexarray[12] := 'C';
+ hexarray[13] := 'D';
+ hexarray[14] := 'E';
+ hexarray[15] := 'F';
+begin
+ stri := '';
+ i := int;
+ if i < 0 then begin
+ stri := 'FF';
+ i := 'FFFFFF'x + i + 1;
+ end;
+ k16 := 1048576;
+ repeat
+ if i >= k16
+ then begin
+ j := i div k16;
+ stri := stri || hexarray[j];
+ i := i - (j * k16);
+ end
+ else if length(stri) > 0
+ then stri := stri || '0';
+ k16 := k16 div 16;
+ until k16 = 1;
+ stri := stri || hexarray[i];
+ i := length(stri);
+ if (i = 1) or (i = 3) or (i = 5)
+ then stri := '0' || stri;
+ hex := stri;
+ end;
+
+@
+@<Global Types@>=
+ oneofsix = 1..6;
+
+@
+@<Global Variables@>=
+ dump :boolean;
+ fontpkt :file of memoryword;
+ inx :integer;
+ name :array[0..127] of string(40);
+ outcount :integer;
+ outrec :memoryword;
+
+@
+@p procedure writeout(outrec :memoryword;
+ outtype :oneofsix);
+var
+ length :integer;
+begin
+ if dump then begin
+ write(outcount:6,': ');
+ case outtype of
+ 1 :writeln('Pts=',outrec.pts);
+ 2 :begin
+ writeln('Fix=',outrec.int);
+ end;
+ 3 :with outrec.twohalves do
+ writeln('lhword=',lhword,',rhword=',rhword);
+ 4 :with outrec.fourbytes do
+ writeln(' Byte0=',byte0:3,'=>"',hex(byte0),'"',
+ ',Byte1=',byte1:3,'=>"',hex(byte1),'"',
+ ',Byte2=',byte2:3,'=>"',hex(byte2),'"',
+ ',Byte3=',byte3:3,'=>"',hex(byte3),'"');
+ 5 :with outrec.fourbytes do
+ writeln(' Width inx =',byte0:3,
+ ',Height inx= ',byte1 div 16:2,
+ ',Depth inx =',byte1 mod 16:2,
+ ',ItCor inx= ',byte2 div 4:2,
+ ',Tag =',byte2 mod 4:1,
+ ',Rem =',byte3:2,
+ ',chr="',name[inx],'"');
+ 6 :writeln(outrec.int:1);
+ end;{case}
+ end;{if}
+ outcount := outcount + 1; {count it}
+ fontpkt@@ := outrec;
+ put(fontpkt);
+ end; {writeout}
+
+@
+@<Global Types@>=
+@!error_severity = (fatal,notreallyfatal,overlookable);
+
+@
+@<Global Variables@>=
+@!currchar :charindex;
+@!errlin :integer;
+@!errlstr :string(10);
+@!errmax :integer;
+@!errmin :integer;
+@!errnum :integer;
+@!errstr :string(133);
+@!infile :text;
+@!lenfile :integer;
+@!lineno :integer;
+@!sysprint :text;
+
+@ The error procedure. When a byte is read that does not jive with
+what the program was expecting, it goes to this procedure with a
+return code of some kind and an appropriate message is printed to user.
+
+@p procedure error(err :integer;
+ howbad :error_severity);
+begin
+ if errlin = 0 then errlin := lineno;
+ {The caller can override the current line by setting errlin}
+ case err of
+ 0 :writeln('Empty input file');
+ 1 :writeln('Unrecognized keyword :',errstr);
+ 2 :begin
+ write('Number of entries must be specified');
+ writeln(' before the entries appear');
+ end;
+ 4 :begin
+ write('Integer expected but not found: next char=');
+ if eoln(infile)
+ then writeln('end of line')
+ else writeln(infile@@);
+ end;
+ 5 :writeln('Too many unique widths, depths, or heights');
+ 6 :begin
+ writeln('Entries in font file are out of sequence:');
+ writeln('The entry labelled ',errstr[1],
+ ' has a sequence ', 'of ',currchar:3,
+ ', not its Ascii value ',ordx[errstr[1]]:3);
+ end;
+ 7 :writeln('Ran out of entries in font file prematurely');
+ 8 :writeln('Real value given for parameter ',errstr,
+ ', but integer required');
+ 9 :writeln('The character names in a ligature or kern ',
+ 'have to be separated by a "+"');
+ 10 :writeln('Knave! No space should follow thine plus sign');
+ 11 :writeln('We expected to see a keyword here, not ',
+ errstr,'. Perhaps you have too many ',
+ 'character entries, or (gasp!) a typo');
+ 12 :writeln('You never specified "',errstr,
+ '" as a character name');
+ 13 :writeln('Keyword should be TOP,BOT,MID,EXT, not "',
+ errstr:3,'"');
+ 14 :writeln('You''ve specified parameters for both ',
+ 'mathex and mathsy fonts');
+ 15 :writeln('Expected to write ',lenfile:3,' records, ',
+ 'but actually wrote ',outcount:3);
+ 16 :writeln('After character name should be BUILD, ',
+ 'LIGATURE, or integer, not ',errstr);
+ 17 :writeln('Invalid value for parameter ',errlstr,', ',
+ errnum,' is <',errmin,' or >',errmax);
+ 18 :writeln('TTS codes must be within 0 to 127');
+ 19 :writeln(errlstr,' is not a valid 8600 command');
+ 20 :writeln('There is no 8600 code given for character ',
+ errstr:1);
+ 21 :writeln('Bad character for 8600 code :',infile@@);
+ 24 :writeln('Major font number should be between 1 and ',
+ maxfont:3);
+ 27 :writeln('Fontname too long, truncated to 8 characters');
+ 28 :writeln('Invalid input values for tracing, ',
+ 'record "',errlstr,'" skipped');
+ otherwise writeln('Unspecified error number ',err:3);
+ end; {case}
+ if howbad = fatal
+ then begin
+ writeln('Fatal error ends program at input line',
+ errlin:4);
+ trace(sysprint);
+ halt;
+ end
+ else writeln('Error at input line',errlin:4);
+ if (not eof(infile)) and (howbad = overlookable)
+ then begin
+ readln(infile);
+ writeln('rest of this string has been overlooked');
+ end;
+ errlin := 0; {reset default line to lineno}
+ end; {Error}
+
+@
+@p procedure skipblanks;
+begin
+ while (infile@@=' ') and not eoln(infile) do
+ get(infile); {advance one character}
+ end;
+
+@
+@<Global Types@>=
+@!chrset = set of char;
+
+@ This procedure reads a string from infile to be delimited by
+a character in the set delimiters.
+
+@p procedure readmnemonic(var mn :string(40);
+ delimiters :chrset);
+var
+ str :string(1);
+begin
+ mn := '';
+ while (length(mn) <= 40) and not (infile@@ in delimiters) do begin
+ read(infile,str);
+{writeln('character="',str);}
+ mn := mn || str;
+ end;
+ errstr := mn; {save globally for error messages}
+ end; {readmnemonic}
+
+@
+@<Global Constants@>=
+ exspacekey = 'EXTRASPACE';
+ quadkey = 'QUAD';
+ slantkey = 'SLANT';
+ spaceekey = 'SPACE';
+ spshrkey = 'SPSHRINK';
+ spstrkey = 'SPSTRETCH';
+ xhtkey = 'XHEIGHT';
+
+@
+@p procedure printparam(p :parameter);
+begin
+ case p of
+ slant :write(slantkey:5);
+ spacee :write(spaceekey:6);
+ spstretch :write(spstrkey:9);
+ spshrink :write(spshrkey:8);
+ xheight :write(xhtkey:7);
+ quad :write(quadkey:4);
+ extraspace:write(exspacekey:10);
+ otherwise write(' next math parm');
+ end; {case}
+ end; {printparam}
+
+@ This converts the byte to an integer, for further evaluation by
+the program.
+
+@p procedure readinteger(var int :integer);
+var
+ minusint :integer;
+begin
+ skipblanks;
+ if not (infile@@ in ['0'..'9','-']) then error(4,fatal);
+ if infile@@ = '-'
+ then begin
+ get(infile);
+ readinteger(minusint);
+ int := 0 - minusint;
+ end
+ else read(infile,int);
+ end; {readinteger}
+
+@ Reads series of integers separated by * and /. Returns
+ value in fractional form: multiplier/divisor is the real value
+
+@p procedure readexpr(var multiplier :integer;
+ var divisor :integer);
+var
+ op :char;
+ int :integer;
+begin
+ skipblanks;
+ if infile@@ = ' ' then error(4,fatal);
+ op := '*';
+ multiplier := 1;
+ divisor := 1;
+ while not (infile@@ in [' ',',']) do begin
+ readinteger(int);
+ if op = '*'
+ then multiplier := multiplier * int
+ else divisor := divisor * int;
+ if (infile@@ = '*') or (infile@@ = '/')
+ then read(infile,op);
+ end; {while}
+ end; {readexpr}
+
+@
+@p procedure readreal(var r :real);
+var
+ mult :integer;
+ divs :integer;
+begin
+ readexpr(mult,divs);
+ r := (1.0 * mult)/(1.0 * divs);
+ end;
+
+@
+@<Global Constants@>=@/
+ axishtkey = 'AXISHEIGHT';
+ bosp1key = 'BIGOPSPACE1';
+ bosp2key = 'BIGOPSPACE2';
+ bosp3key = 'BIGOPSPACE3';
+ bosp4key = 'BIGOPSPACE4';
+ bosp5key = 'BIGOPSPACE5';
+ codingschemekey = 'CODINGSCHEME';
+ deffontkey = 'DEFFONT';
+ dethicknesskey = 'DEFTHICKNESS';
+ dewidthkey = 'DEFWIDTH';
+ dlims1key = 'DELIMSIZE1';
+ dlims2key = 'DELIMSIZE2';
+ denom1key = 'DENOMLOWER1';
+ denom2key = 'DENOMLOWER2';
+ fntnamekey = 'FONTNAME';
+ hunitskey = 'HUNITS';
+ raizen1key = 'NUMRAISE1';
+ raizen2key = 'NUMRAISE2';
+ raizen3key = 'NUMRAISE3';
+ ptsizekey = 'POINTSIZE';
+ subdrpkey = 'SUBDROP';
+ sub1key = 'SUB1';
+ sub2key = 'SUB2';
+ supdrpkey = 'SUPDROP';
+ sup1key = 'SUP1';
+ sup2key = 'SUP2';
+ sup3key = 'SUP3';
+ vunitskey = 'VUNITS';
+ maxfont = 255;
+ uninitialized = -5000.0;
+
+@
+@<Global Variables@>=
+ codescheme :string(40);
+ def_ft_stuff :driverrec;
+ def_width_stuff :driverrec;
+ fontname :string(40);
+ fontype :fonttypes;
+ hunits :real;
+ params :array[parameter] of real;
+ paramset :array[fonttypes] of set of parameter;
+ pointsize :integer;
+ uniquecode :integer;
+ vunits :real;
+
+@
+@p procedure read_the_parameters;
+label 0;
+var
+ mn :string(40);
+ int :integer;
+ realval :real;
+ mult :integer;
+ divs :integer;
+ isint :boolean;
+ pp :parameter;
+ parmerror :boolean;
+begin
+ while infile@@ in ['A'..'Z','a'..'z','*'] do
+ if (infile@@ = '*')
+ then begin
+ readln(infile);
+ errlin := errlin + 1;
+ end
+ else begin
+ @<read vunits or hunits or parameter@>
+ {You can end the parameters with a '\$' line -- check it}
+ if infile@@ = '$'
+ then begin
+ readln(infile); {Skip end params marker}
+ errlin := errlin + 1;
+ end;
+ {now check that all parameters are given}
+0: parmerror := false;
+ for pp := slant to bgopsp5 do
+ if (params[pp] = uninitialized) and
+ (pp in paramset[fontype]+paramset[standard])
+ then begin
+ write('Parameter ');
+ printparam(pp);
+ writeln(' was not specified');
+ parmerror := true;
+ end;
+ if parmerror then error(7,fatal);
+ end; {|read_the_parameters|}
+
+@
+@<read vunits or hunits or parameter@>=
+ readmnemonic(mn,[' ']);
+ if dump then write('Parameter ',mn);
+ mn := allcaps(mn);
+ if mn = 'ENDPARAMS'
+ @<endparams@>
+ if (mn <> fntnamekey) and (mn <> codingschemekey)
+ then readexpr(mult,divs);
+ if divs = 0
+ then realval := 1.0 * mult
+ else realval := (1.0 * mult)/(1.0 * divs);
+ int := mult;
+ if divs = 1
+ then isint := true
+ else isint := false; {only reals have divisor}
+ if mn = hunitskey
+ @<hunits@>
+ else if mn = vunitskey
+ @<vunits@>
+ else if mn = fntnamekey
+ @<fontname@>
+ else if mn = codingschemekey
+ @<codingscheme@>
+ else if mn = deffontkey
+ @<deffont@>
+ else if mn = dewidthkey
+ @<defwidth@>
+ else if mn = ptsizekey
+ @<pointsize@>
+ else begin
+ @<TEX standard parameter@>
+ readln(infile);
+ errlin := errlin + 1;
+ end; {else..begin}
+
+@
+ @<endparams@>=
+ then begin
+ readln(infile);
+ errlin := errlin + 1;
+ goto 0; {marks end of parameters}
+ end;
+
+@
+ @<hunits@>=
+ then begin
+ hunits := realval;
+ if dump then writeln(' = ',realval);
+ end
+
+@
+ @<vunits@>=
+ then begin
+ vunits := realval;
+ if dump then writeln(' = ',realval);
+ end
+
+@
+ @<fontname@>=
+ then begin
+ skipblanks;
+ readmnemonic(fontname,[' ','.']);
+ fontname := allcaps(fontname);
+ if dump then writeln(' = ',fontname);
+ end
+
+@
+ @<codingscheme@>=
+ then begin
+ skipblanks;
+ readmnemonic(codescheme,[' ','.']);
+ codescheme := allcaps(codescheme);
+ if dump then writeln(' = ',codescheme);
+ end
+
+@
+ @<deffont@>=
+ then {set up |def_ft_stuff| record}
+ with def_ft_stuff do begin
+ cmd := ord(F); {8600 font command}
+ if int > maxfont
+ then error(24,notreallyfatal);
+ code := int * 10;
+ uniquecode := int;
+ if dump then writeln(' = ',int);
+ end
+
+@
+ @<defwidth@>=
+ then {set up |def_width_stuff| record}
+ with def_width_stuff do begin
+ {ratio of set width to point size}
+ cmd := ord(CHWIDTH);
+ param := realval;
+ if dump then writeln(' = ',realval);
+ end
+
+@
+ @<pointsize@>=
+ then begin
+ pointsize := int;
+ if dump then writeln(' = ',int);
+ end
+
+@
+ @<TEX standard parameter@>=
+ if mn = slantkey
+ then pp := slant
+ else if mn = spaceekey
+ then pp := spacee
+ else if mn = spstrkey
+ then pp := spstretch
+ else if mn = spshrkey
+ then pp := spshrink
+ else if mn = xhtkey
+ then pp := xheight
+ else if mn = quadkey
+ then pp := quad
+ else if mn = exspacekey
+ then pp := extraspace
+ @<TEX mathsy parameter@>
+ @<TEX mathex parameter@>
+ else error(1,fatal);
+ params[pp] := realval; {save value of it}
+ if dump then writeln(' = ',realval);
+ if pp in paramset[mathex]
+ then begin
+ if fontype = standard
+ then fontype := mathex
+ else if fontype <> mathex
+ then error(14,fatal);
+ end
+ else if pp in paramset[mathsy]
+ then begin
+ if fontype = standard
+ {change assumption}
+ then fontype := mathsy
+ else if fontype <> mathsy
+ then error(14,fatal);
+ end; {then..begin}
+ end; {else..begin TEX}
+
+@
+ @<TEX mathsy parameter@>=
+ else if mn = raizen1key
+ then pp := raisen1
+ else if mn = raizen2key
+ then pp := raisen2
+ else if mn = raizen3key
+ then pp := raisen3
+ else if mn = denom1key
+ then pp := denom1
+ else if mn = denom2key
+ then pp := denom2
+ else if mn = sup1key
+ then pp := sup1
+ else if mn = sup2key
+ then pp := sup2
+ else if mn = sup3key
+ then pp := sup3
+ else if mn = sub1key
+ then pp := sub1
+ else if mn = sub2key
+ then pp := sub2
+ else if mn = supdrpkey
+ then pp := supdrop
+ else if mn = subdrpkey
+ then pp := subdrop
+ else if mn = dlims1key
+ then pp := dlims1
+ else if mn = dlims2key
+ then pp := dlims2
+ else if mn = axishtkey
+ then pp := axisheight
+
+@
+ @<TEX mathex parameter@>=
+ else if mn = dethicknesskey
+ then pp := defthickness
+ else if mn = bosp1key
+ then pp := bgopsp1
+ else if mn = bosp2key
+ then pp := bgopsp2
+ else if mn = bosp3key
+ then pp := bgopsp3
+ else if mn = bosp4key
+ then pp := bgopsp4
+ else if mn = bosp5key
+ then pp := bgopsp5
+
+@ finds entry in array list if present and returns its index
+ as slot. otherwise it adds it at the end of list (specified
+ by list[-1]) and returns that index as slot.
+
+@p procedure add_to_list(var list :realarray;
+ entry :real;
+ lmax :integer;
+ var slot :integer);
+var
+ linx :integer;
+begin
+ if entry = 0 then begin
+ slot := 0;
+ return;
+ end;
+ for linx := 1 to trunc(list[-1]) do
+ if entry = list[linx]
+ then begin
+ slot := linx;
+ return;
+ end;
+ {not found}
+ if trunc(list[-1]) = lmax then error(5,fatal);
+ list[-1] := list[-1] + 1.0;
+ list[trunc(list[-1])] := entry;
+ slot := trunc(list[-1]);
+ end; {|add_to_list|}
+
+@
+@<Global Variables@>=
+ max :array[comm] of integer;
+ min :array[comm] of integer;
+
+@ Sets up info needed to read driver file info from the input
+ file, and write it in proper format into the driver output file
+
+@p procedure init8600commands;
+var
+ cmd :comm;
+begin
+ for cmd := HDR to MAXCMD do begin {initialize 8600 commands}
+ if cmd in [PS,SS] then begin
+ min[cmd] := 0;
+ max[cmd] := 1275;
+ end
+ else if cmd in [VMF, VMR, RD] then begin
+ min[cmd] := 1;
+ max[cmd] := 1736;
+ end
+ else if cmd in [RW, HML, HMR] then begin
+ min[cmd] := 1;
+ max[cmd] := 14688;
+ end
+ else if cmd in [SL] then begin
+ min[cmd] := 0;
+ max[cmd] := 48;
+ end
+ else if cmd in [RTWT, RTWB] then begin
+ min[cmd] := 0;
+ max[cmd] := 1440;
+ end
+ else if cmd in [F] then begin
+ min[cmd] := 1;
+ max[cmd] := 255;
+ end
+ else begin {catch any others}
+ min[cmd] := 0;
+ max[cmd] := 65535; {largest 2 byte integer}
+ end;
+ end; {FOR..begin}
+ end; {init8600commands}
+
+@
+@<Global Variables@>=
+ depth :realarray;
+ drvdump :boolean;
+ drvpkt :file of driverrec;
+ drvoutcount :integer;
+ dumpval :boolean;
+ height :realarray;
+ inrec :string(30);
+ itcorr :realarray;
+ kernout :realarray;
+ numext :integer;
+ numkerns :integer;
+ numligs :integer;
+ numparams :array[fonttypes] of integer;
+ outstuff :outarray;
+ str1 :string(30);
+ str2 :string(30);
+ terminal :text;
+ width :realarray;
+
+@
+@p procedure initialize;
+var
+ pp :parameter;
+ outinx :integer;
+begin
+ fontname := trim(parms);
+ termout(terminal);
+ termout(output);
+ rewrite(fontpkt,'NAME='||fontname||'.PRTFM.A');
+ rewrite(drvpkt,'NAME='||fontname||'.CGINFO.A');
+ reset(infile,'NAME='||fontname||'.FONTINFO.*');
+ dump := false;
+ drvdump := false;
+{
+ while not eof(terminal) do begin
+ readln(terminal,inrec);
+ inx := index(inrec,'=');
+ if inx < 1
+ then begin
+ errstr := inrec;
+ error(28,notreallyfatal);
+ end
+ else begin
+ str1 := substr(inrec,1,inx-1);
+ str2 := substr(inrec,inx+1,length(inrec)-inx);
+ str1 := allcaps(ltrim(trim(str1)));
+ str2 := allcaps(ltrim(trim(str2)));
+ if str2 = 'false'
+ then dumpval := false
+ else if str2 = 'true'
+ then dumpval := true;
+ if ((str2 <> 'false') and (str2 <> 'true')) or
+ ((str1 <> 'DUMP') and (str1 <> 'DRVDUMP'))
+ then begin
+ errstr := inrec;
+ error(28,notreallyfatal);
+ end
+ else if str1 = 'DUMP'
+ then dump := dumpval
+ else drvdump := dumpval;
+ end;
+ end;
+}
+ hunits := 1.0 / 54.0;
+ vunits := 1.0 / 8.0;
+ lineno := 1;
+ width[-1] := 0;
+ width[0] := 0.0; {for non-existent chars}
+ height[-1] := 0;
+ height[0] := 0.0; {for non-existent chars}
+ depth[-1] := 0;
+ depth[0] := 0.0; {for non-existent chars}
+ itcorr[-1] := 0;
+ itcorr[0] := 0.0; {for non-existent chars}
+ kernout[-1] := 0.0;
+ kernout[0] := 0.0;
+ {Set all tag values to 0 = vanilla}
+ for outinx := 0 to 127 do outstuff[outinx].fourbytes.byte2 := 0;
+ numkerns := -1;
+ numligs := -1;
+ numext := -1;
+ fontname := ' ';
+ codescheme := 'PARC TEXT';
+ fontype := standard;
+ paramset[standard] := [slant..quad,extraspace];
+ paramset[mathsy] := [raisen1..axisheight];
+ paramset[mathex] := [defthickness..bgopsp5];
+ pointsize := 1;
+ numparams[standard] := 7;
+ numparams[mathex] := 13;
+ numparams[mathsy] := 22;
+ for pp := slant to extraspace do params[pp] := uninitialized;
+ drvoutcount := 0; {no records to driver file yet}
+ init8600commands;
+ with def_ft_stuff do begin
+ cmd := ord(F);
+ code := 10; {font 1, fontlet 0 = def}
+ end;
+ with def_width_stuff do begin
+ cmd := ord(CHWIDTH);
+ param := 1.0; {normal width type is def}
+ end;
+ end;{initialize}
+
+@
+@p procedure readentry(var list :realarray;
+ lmax :integer;
+ var slot :integer;
+ units :real);
+var
+ entry :real;
+ multiplier :integer;
+ divisor :integer; {save value in expression}
+begin
+ readexpr(multiplier,divisor);
+ entry := (1.0 * multiplier) / (1.0 * divisor) * units;
+ if dump then writeln('entry read is ',multiplier:4,'/',
+ divisor:4,' * ',units:4:2, '=',entry);
+ add_to_list(list,entry,lmax,slot);
+ end; {readentry}
+
+@
+@<Global Variables@>=
+ lig :array[0..255] of ligrec;
+
+@ The keyword LIGATURE has just been scanned in the input for one of
+characters 0 to 127. Now we expect to find blank separators followed
+by the names of the two characters the ligature replaces. These will
+be separated by a '+' sign. Since the characters in question may
+not have been specified yet, the names will be saved for now, and
+looked up after all 128 character entries have been read.
+
+@
+@p procedure read_ligature_stuff;
+begin
+ skipblanks;
+ numligs := numligs+1;
+ with lig[numligs] do begin
+ sourceline := lineno; {save line for later error messages}
+ readmnemonic(firstname,[' ','+']);
+ if dump then writeln('first char of ligature is ',firstname);
+ if infile@@ <> '+'
+ then error(9,notreallyfatal)
+ else begin
+ get(infile); {skip plus sign}
+ if infile@@ = ' ' then error(10,overlookable);
+ skipblanks; {overlook}
+ readmnemonic(scndname,[' ']); {read second name}
+ if dump then writeln('second character of ligature',
+ ' is ',scndname);
+ end; {else..begin}
+ ligcode := currchar;
+ end; {with..begin}
+ end; {|read_ligature_stuff|}
+
+@
+ @<Global Variables@>=@/
+ charno :charindex;
+
+@ look up this name in the name array and tell where and if it was
+
+@p procedure lookup(lookee :string(40);
+ var charno :charindex; {where if found}
+ var found :boolean); {was it found}
+var
+ inx :integer;
+begin
+ found := false;
+ inx := 0;
+ while not found and (inx<128) do
+ if name[inx] = lookee
+ then found := true {found}
+ else inx := inx + 1; {check next}
+ if found
+ then charno := inx
+ else charno := 127; {not found, avoid out of range err}
+ if not found
+ then begin
+ errstr := lookee; {string for message}
+ error(12,notreallyfatal);
+ end; {then..begin}
+ end; {lookup}
+
+@ Set Tag value in lower 2 bits of byte 2 of outstuff record
+
+@p procedure set_tag_val(chinx :charindex;
+ tagval :integer);
+begin
+ with outstuff[chinx].fourbytes do begin
+ if (byte2 mod 4) <> 0
+ then writeln('Tag for char ',chinx:1,
+ ' already set to ',byte2 mod 4);
+ if tagval > 3 then error(25,fatal);
+ byte2 := (byte2 div 4 * 4) + tagval;
+ end; {with..begin}
+ end; {|set_tag_val|}
+
+@ Convert a real to a "FIX" which is a 32-bit number stored in the
+leftmost 32 bits of a word. The first 12 bits are the integer part, and
+the last 20 are the fraction. The left most bit is the sign
+
+@p function scaleout(r :real) :integer;
+var
+ stri :string(8);
+ int :integer;
+begin
+ int := round(r*'100000'x);
+ if dump then begin
+ stri := hex(int);
+ if length(stri) < 8
+ then stri := substr('00000000',1,8-length(stri)) || stri;
+ writeln('FIX of ',r,' is ',int,', hex value="',stri,'"');
+ end;
+ scaleout := int;
+ end; {scaleout}
+
+@
+@<Global Variables@>=
+ found :boolean;
+ kern :array[0..maxkerns] of kernrec;
+ mnem :string(40);
+
+@ The keyword KERN has been read: process the rest of the line
+
+@p procedure read_kern_stuff;
+begin
+ numkerns := numkerns + 1;
+ skipblanks;
+ with kern[numkerns] do begin
+ readmnemonic(mnem,[' ','+']);
+ lookup(mnem,charno,found);
+ if found
+ then frstchar := charno
+ else begin
+ frstchar := 127;
+ error(12,notreallyfatal);
+ end; {else..begin}
+ if infile@@ = ' '
+ then begin
+ error(9,notreallyfatal);
+ scndchar := 127; {put any old value there}
+ end
+ else begin
+ get(infile); {skip plus sign}
+ if infile@@ = ' '
+ then error(10,overlookable);
+ skipblanks;{overlook it!}
+ readmnemonic(mnem,[' ','-']);
+ lookup(mnem,charno,found);
+ if found
+ then scndchar := charno
+ else scndchar := 127;
+ end; {else..begin}
+ readentry(kernout,maxkerns,kernslot,hunits);
+ end; {with}
+ readln(infile);
+ errlin := errlin + 1;
+ end; {|read_kern_stuff|}
+
+@
+@<Global Constants@>=
+ linktag = 2;
+
+@
+@p procedure read_link_stuff;
+var
+ mn1 :string(40);
+ mn2 :string(40);
+ char1 :charindex;
+ char2 :charindex;
+ found :boolean;
+begin
+ skipblanks;
+ readmnemonic(mn1,[' ']);
+ lookup(mn1,char1,found);
+ skipblanks;
+ readmnemonic(mn2,[' ']);
+ lookup(mn2,char2,found);
+ set_tag_val(char1,linktag); {set tag type for special info}
+ outstuff[char1].fourbytes.byte3 := char2; {next bigger char}
+ readln(infile);
+ errlin := errlin + 1;
+ end;
+
+@
+@<Global Constants@>=
+ maxitcorr = 63;
+
+@
+@p procedure read_mathop_stuff;
+var
+ mn :string(40);
+ charno :charindex;
+ realval :real;
+ found :boolean;
+ slot :integer; {index into itcorr array for kerns}
+ tag :integer; {saves "tag" value from outstuff array}
+begin
+ skipblanks;
+ readmnemonic(mn,[' ']);
+ lookup(mn,charno,found);
+ readreal(realval);
+ add_to_list(itcorr,realval,maxitcorr,slot); {add value to list}
+ with outstuff[charno].fourbytes do begin
+ tag := byte2 mod 4; {tag is lower 2 bits}
+ byte2 := slot * 4 + tag; {and ic index is upper 6 bits}
+ end;{with..begin}
+ readln(infile);
+ errlin := errlin + 1;
+ end; {|read_mathop_stuff|}
+
+@
+@<Global Constants@>=
+ botkey = 'BOT';
+ extkey = 'EXT';
+ midkey = 'MID';
+ topkey = 'TOP';
+ exttag = 3;
+
+@
+@<Global Variables@>=
+ ext :array[0..127] of extrec;
+
+@ Name and keyword BUILD already read. Now expect keyword=value,
+keyword=value, ... Keywords are TOP, MID, BOT, EXT, and values are
+char names. Add a miscellaneous entry and point to it from this
+character record. initialize the four names in the ext record
+and set the four character values to zero. Later we will look up the
+names to determine the actual character numbers of the components.
+
+@p procedure read_build_stuff;
+var
+ key :string(40);
+ charname :string(40);
+begin
+ numext := numext + 1;
+ with ext[numext] do begin
+ sourceline := lineno; {save line for later error messages}
+ top := 0;
+ mid := 0;
+ bot := 0;
+ ext := 0;
+ topname := '';
+ midname := '';
+ botname := '';
+ extname := '';
+ end;
+ set_tag_val(currchar,exttag);
+ outstuff[currchar].fourbytes.byte3 := numext; {ptr into EXT array}
+ skipblanks;
+ repeat
+ if infile@@ = ',' then get(infile); {skip separator}
+ readmnemonic(key,['=']);
+ key := allcaps(key);
+ get(infile); {skip equal sign delimiter}
+ readmnemonic(charname,[',',' ']);
+ if key = topkey then ext[numext].topname := charname
+ else if key = midkey then ext[numext].midname := charname
+ else if key = botkey then ext[numext].botname := charname
+ else if key = extkey then ext[numext].extname := charname
+ else error(13,fatal);
+ until infile@@ <> ',';
+ end; {|read_build_stuff|}
+
+@
+@<Global Variables@>=
+ drvrec :driverrec;
+
+@ Print out the record about to be written to the driver file. This can
+ be turned on or off by setting constant 'drvdump' to true or false.
+
+@p procedure dump_driver_rec(cmdord :integer);
+begin
+ with drvrec do begin
+ if drvoutcount = 0
+ then writeln('*** Driver File Output ***');
+ write(drvoutcount:3,': ');
+ drvoutcount := drvoutcount + 1;
+ write('Command=',com_table[cmdord],', Parameter=');
+ if (cmdord = ord(CHWIDTH)) or
+ ((cmdord >= ord(VMF)) and (cmdord <= ord(IR))) or
+ (cmdord = ord(RTWT)) or
+ (cmdord = ord(RTWB)) or
+ (cmdord = ord(HMR)) or
+ (cmdord = ord(HML))
+ then writeln(param)
+ else writeln(code);
+ end; {with..begin}
+ end; {|dump_driver_rec|}
+
+@
+@<Global Variables@>=
+ stk :array [0..20] of driverrec;
+
+@ Push a record with an integer character code
+
+@p procedure pushcode(var stktop :integer);
+var
+ icode :integer;
+begin
+ readinteger(icode);
+ if icode > 127 then error(18,notreallyfatal);
+ stktop := stktop + 1;
+ with stk[stktop] do begin
+ cmd := ord(TTS);
+ code := icode;
+ end; {with..begin}
+ end; {pushcode}
+
+@ Reads a command or letter from the input file -- i.e., reads the
+ 1 to 4 char mnemonic and looks it up in array cmdname to find
+ the enumeration value of type "command" corresponding to it.
+ A letter is distinguished from a command because a letter has no
+ parameter whereas all one-character commands do.
+
+@p procedure readcmd(var cmd :comm);
+label 99;
+var
+ name :string(9);
+ ch :string(1);
+ cmdind :comm;
+begin
+ name := '';
+ while infile@@ in ['a'..'z','A'..'Z'] do begin
+ read(infile,ch);
+ name := name || ch;
+ end;
+ name := allcaps(name);
+ errlstr := name; {save name for error message (if needed)}
+ {cmd will be the command or MAXCMD if not found}
+ for cmdind := HDR to MAXCMD do
+ if name = com_table[ord(cmdind)] then goto 99;
+99: cmd := cmdind;
+ if cmdind = MAXCMD then error(19,notreallyfatal); {bad command}
+ end; {readcmd}
+
+@ Read the command "cmnd" -- see if it has any parameters, and
+if so read them. Push a record on the local stack for this command
+
+@p procedure readparams(var stktop :integer);
+var
+ cmnd :comm;
+begin
+ readcmd(cmnd);
+ stktop := stktop + 1; {push}
+ with stk[stktop] do begin
+ cmd := ord(cmnd);
+ if cmnd in [AU] {this one has no parameters}
+ then code := 0
+ else begin {read integer parm, stuff it into record}
+ if cmnd in [IR,VMF,VMR,RW,RD,RTWT,RTWB,HMR,HML]
+ then begin
+ readreal(param);
+ if (round(param) < min[cmnd]) or
+ (round(param) > max[cmnd]) then begin
+ errlstr := com_table[ord(cmnd)];
+ errnum := round(param);
+ errmax := max[cmnd];
+ errmin := min[cmnd];
+ error(17,notreallyfatal);
+ param := min[cmnd];
+ end; {then..begin}
+ if cmnd in [VMF,VMR,RD]
+ then param := param * vunits
+ else param := param * hunits;
+ end {then..end}
+ else begin
+ readinteger(code);
+ if (code < min[cmnd]) or
+ (code > max[cmnd]) then begin
+ errlstr := com_table[ord(cmnd)];
+ errnum := code;
+ errmax := max[cmnd];
+ errmin := min[cmnd];
+ error(17,notreallyfatal);
+ code := min[cmnd];
+ end; {then..begin}
+ end; {else..begin}
+ end; {else..begin}
+ end; {with..begin}
+ end; {readparams}
+
+@* Read 8600 Codes.
+The 8600 code info corresponding to this character will consist of 1
+or more entries separated by commas and containing no blanks. An entry
+can be a decimal character code or an 8600 command in which case it
+begins with a letter. The command name will be up to 4 letters long and
+may be followed by a parameter. Some commands take integer parameters
+and others take reals which will be given in the same format as widths,
+etc: i.e., as products and quotients of integer values.
+Following are listed the possible codes.
+\settabs\+\indent&RTWB = &Reverse Type Window Bottom\quad&value=0--1440
+in 10ths of a point\cr
+\+&PS\hfill =&Point Size\hfill&value=0--1275 in 10ths of a point.\cr
+\+&SS\hfill =&Set Size\hfill&value=0--1275 in 10ths of a point.\cr
+\+&VMF\hfill =&Vertical Move Forward\hfill&value=1--1736 in 8ths of a
+point\cr
+\+&VMR\hfill =&Vertical Move Reverse\hfill&value=1--1736 in 8ths of a
+point\cr
+\+&RD\hfill =&Rule Depth\hfill&value=1--1736 in 8ths of a point\cr
+\+&RW\hfill =&Rule Width\hfill&value=1--1736 in 8ths of a point\cr
+\+&HML\hfill =&Horizontal Move Left\hfill&value=1--14688 in 18ths of a
+point\cr
+\+&HMR\hfill =&Horizontal Move Right\hfill&value=1--14688 in 18ths of a
+point\cr
+\+&SL\hfill =&Slant\hfill&value=0 or 48\cr
+\+&IR\hfill =&Insert Rule\cr
+\+&AU\hfill =&Auxiliary Font\cr
+\+&F\hfill =&Font\hfill&value=1--255\cr
+\+&RTWT\hfill =&Reverse Type Window Top\hfill&value=0--1440 in 16ths of
+a point\cr
+\+&RTWB =&Reverse Type Window Bottom&value=0--1440 in 16ths of a point\cr
+
+@p procedure read8600codes;
+var
+ more_to_come :boolean;
+ stktop :integer; {gives index of last used (initially 0)}
+ inx :integer;
+begin
+ skipblanks;
+ stktop := -1; {no code yet}
+ if eoln(infile)
+ then error(20,notreallyfatal) {no code given}
+ else begin
+ {Repeat until next is no longer a comma, in which case it
+ had better be a blank!}
+ repeat
+ if infile@@ in ['0'..'9']
+ then pushcode(stktop) {decimal character code}
+ else if infile@@ in ['A'..'Z','a'..'z']
+ {read command and optional parms}
+ then readparams(stktop)
+ else error(21,notreallyfatal);
+ if infile@@ = ','
+ then begin
+ more_to_come := true;
+ get(infile);
+ end {then..begin}
+ else more_to_come := false;
+ until not more_to_come;
+ end; {else..begin}
+ {put header record out}
+ drvrec.cmd := ord(HDR);
+ drvrec.code := stktop; {how many codes for this character}
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ {write out character width record}
+ drvrec.cmd := ord(CHWIDTH);
+ drvrec.param := width[outstuff[currchar].fourbytes.byte0];
+ {nw for the current character indexes its width in points}
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ {Put out rec for each code or command}
+ for inx := 0 to stktop do begin
+ drvrec := stk[inx];
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ end; {FOR..begin}
+ end; {read8600codes}
+
+@* MAIN PROGRAM.
+
+@<Global Constants@>=
+ buildkey = 'BUILD';
+ kernkey = 'KERN';
+ ligaturekey = 'LIGATURE';
+ linkkey = 'LINK';
+ mathopkey = 'MATHOP';
+ maxdp = 15;
+ maxht = 15;
+ maxwd = 255;
+ ligkerntag = 1;
+
+@
+@<Global Variables@>=
+ chnum :0..127;
+ chrt :char;
+ first :boolean;
+ heightslot :integer;
+ iny :integer;
+ itc :real;
+ ligcnt :integer;
+ ligout :array[0..255] of memoryword;
+ pp :parameter;
+ slot :integer;
+ tag :integer;
+
+@
+@p begin
+ {--------------- initialize -----------------------}
+ initialize;
+ {---------------- read input -------------------------}
+ read_the_parameters;
+ {Write first three entries to driver file}
+ drvrec.cmd := ord(HDR);
+ drvrec.code := ord(MAXCMD);
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ drvrec := def_ft_stuff;
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ drvrec := def_width_stuff;
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ drvrec.cmd := ord(SL);
+ if params[slant] = uninitialized
+ then drvrec.code := 0
+ else drvrec.code := trunc(params[slant]);
+ if drvdump then dump_driver_rec(drvrec.cmd);
+ drvpkt@@ := drvrec;
+ put(drvpkt);
+ {Now read entries...}
+ for currchar := 0 to num_entries-1 do begin
+ if eof(infile) then error(7,fatal);
+ with outstuff[currchar].fourbytes do
+ byte3 := 0; {set remainder to 0}
+ readmnemonic(mnem,[' ']); {if any}
+ if dump then writeln('** Processing font info for "',mnem,'"');
+ name[currchar] := mnem; {save for later use!}
+ {one non-blank character -- check sequencing}
+ readstr(mnem,chrt);
+ if (length(mnem) = 1) and (ordx[chrt] <> currchar)
+ then error(6,notreallyfatal);
+ skipblanks; {look at next non-blank}
+ if infile@@ in ['A'..'Z','a'..'z']
+ then begin
+ readmnemonic(mnem,[' ']);
+ mnem := allcaps(mnem);
+ if mnem = ligaturekey
+ then read_ligature_stuff
+ else if mnem = buildkey
+ then read_build_stuff
+ else error(16,fatal);
+ end; {then..begin}
+ readentry(width,maxwd,slot,hunits); {read width}
+ outstuff[currchar].fourbytes.byte0 := slot; {save wid index}
+ readentry(height,maxht,slot,vunits); {read height}
+ heightslot := slot; {remember ht slot until depth read}
+ itc := height[slot] * params[slant]; {it corr = ht * slant}
+ add_to_list(itcorr,itc,maxitcorr,slot);
+ with outstuff[currchar].fourbytes do begin
+ tag := byte2 mod 4; {save tag value}
+ byte2 := slot * 4 + tag; {put itcorr in 6 bits, tag in 2}
+ end;
+ readentry(depth,maxdp,slot,vunits); {read depth}
+ outstuff[currchar].fourbytes.byte1 := heightslot * 16 + slot;
+ {now read 8600 information...}
+ read8600codes;
+ if not eoln(infile)
+ then begin
+ readln(infile);
+ errlin := errlin + 1;
+ end;
+ end; {FOR..begin}
+ {character entries have all been read...remaining entries
+ must begin with a keyword: KERN, Link, MATHOP These supply
+ additional information about certain characters}
+ while not eof(infile) do begin
+ readmnemonic(mnem,[' ']);
+ mnem := allcaps(mnem);
+ if mnem = kernkey
+ then read_kern_stuff
+ else if mnem = linkkey
+ then read_link_stuff
+ else if mnem = mathopkey
+ then read_mathop_stuff
+ else error(11,fatal);
+ end; {while..begin}
+@<look up lignames@>@/
+@<set up ligature info@>@/
+@<write font file@>@/
+end.
+
+@
+@<look up lignames@>=
+ for inx:= 0 to numligs do
+ with lig[inx] do begin
+ errlin := sourceline;
+ lookup(firstname,frstchar,found);
+ if not found
+ then begin
+ errlin := sourceline;
+ error(12,notreallyfatal);
+ frstchar := 127;
+ end; {then..begin}
+ lookup(scndname,scndchar,found);
+ if not found
+ then begin
+ errlin := sourceline;
+ error(12,notreallyfatal);
+ scndchar := 127;
+ end; {then..begin}
+ end; {with..begin}
+ for inx := 0 to numext do
+ with ext[inx] do begin
+ errlin := sourceline;
+ if topname <> '' then lookup(topname,top,found);
+ if midname <> '' then lookup(midname,mid,found);
+ if botname <> '' then lookup(botname,bot,found);
+ if extname <> '' then lookup(extname,ext,found);
+ end; {with..begin}
+
+@
+@<set up ligature info@>=
+ ligcnt := 0;
+ for chnum := 0 to 127 do begin
+ first := true;
+ for inx := 0 to numligs do
+ if lig[inx].frstchar = chnum
+ then begin
+ if first then begin
+ {ptr to first ligature}
+ outstuff[chnum].fourbytes.byte3 := ligcnt;
+ set_tag_val(chnum,ligkerntag);
+ first := false;
+ end; {then..begin}
+ with ligout[ligcnt].fourbytes, lig[inx] do
+ begin {transfer info into output records}
+ {byte0=1 if last ligature
+ byte1=next chararacter of ligature
+ byte2=0 for a ligature
+ byte3=code of ligature character}
+ byte0 := '00000000'B;
+ byte1 := scndchar;
+ byte2 := '00000000'B;
+ byte3 := ligcode;
+ end; {with..begin}
+ ligcnt := ligcnt+1; {ready for next one}
+ end; {then..begin}
+ {Now do same with kerns}
+ for inx := 0 to numkerns do
+ if kern[inx].frstchar = chnum
+ then begin
+ if first then begin
+ {link to ligature record}
+ outstuff[chnum].fourbytes.byte3 := ligcnt;
+ set_tag_val(chnum,ligkerntag);
+ first := false; {not anymore}
+ end; {then..begin}
+ with ligout[ligcnt].fourbytes, kern[inx] do
+ begin {transfer info into output records}
+ {byte0=1 if last kern
+ byte1=next chararacter of kern
+ byte2=1 for a kern
+ byte3=index of kern character}
+ byte0 := '00000000'B;
+ byte1 := scndchar;
+ byte2 := '10000000'B;
+ byte3 := kernslot;
+ end; {with..begin}
+ ligcnt := ligcnt + 1;
+ end; {FOR,then..begin}
+ if not first
+ then ligout[ligcnt-1].fourbytes.byte0 := '10000000'B;
+ {there was at least one record, so flag the last of 'em}
+ end; {FOR..begin} {that's all the characters}
+
+@ Now write out in TEX format. TUGboat vol 2, no 1 article
+ TEX FONT METRIC fileS says the first 12 half-words of the
+ file are lengths, and obey the following equation:
+ lenfile=6 + lh + (ec-be+1) + nw + nh + nd + ni + nk + nl + ne + np
+ lh=length of header=18 words ec=end character=127,
+ bc=beginning char=0, hence:
+ lenfile = 6 + 18 + 128 + nw + nh + nd + ni + nk + nl + ne + np
+ Calculate its value:
+
+@<write font file@>=
+ if not eof(infile) then error(7,fatal);
+ lenfile := 6 + 18 + 128 + trunc(width[-1]) + trunc(height[-1])@/
+ + trunc(depth[-1]) + trunc(itcorr[-1])@/
+ + numkerns + numligs + numext + trunc(kernout[-1])@/
+ + numparams[fontype] {num parameters}@/
+ + 8; {off by one on nw,nh,nd,ni,nk,nl,ne and kernout}@/
+ if dump then writeln('Writing info to TEX-readable file');
+ outcount := 0; {start counting}
+ writeln('Number of records is ',lenfile:4);
+ if dump then write('* lf, lh:');
+ outrec.twohalves.lhword := lenfile; {len of file}
+ outrec.fourbytes.rhword := 18; {len of header}
+ writeout(outrec,3);
+ if dump then write('* bc, ec:');
+ outrec.twohalves.lhword := 0; {first char code}
+ outrec.twohalves.rhword := 127; {last char code}
+ writeout(outrec,3);
+ if dump then write('* nw, nh:');
+ outrec.twohalves.lhword := trunc(width[-1]+1);
+ outrec.twohalves.rhword := trunc(height[-1]+1);
+ writeout(outrec,3);
+ if dump then write('* nd, ni:');
+ outrec.twohalves.lhword := trunc(depth[-1]+1);
+ outrec.twohalves.rhword := trunc(itcorr[-1]+1);
+ writeout(outrec,3);
+ if dump then write('* nl, nk:');
+ outrec.twohalves.lhword := numligs + numkerns + 2;
+ outrec.twohalves.rhword := trunc(kernout[-1]+1);
+ writeout(outrec,3);
+ if dump then write('* ne, np:');
+ outrec.twohalves.lhword := numext+1;
+ outrec.twohalves.rhword := numparams[fontype];
+ writeout(outrec,3);
+
+ if dump then writeln('*** Header info');
+ outrec.int := uniquecode;
+ writeout(outrec,6);
+ outrec.int := scaleout(float(pointsize)); {def = 1 point}
+ writeout(outrec,2);
+ writeln('*** Coding Scheme = ',codescheme);
+ outrec.fourbytes.byte0 := length(codescheme);
+ for inx := 2 to 40 do begin
+ iny := inx mod 4;
+ if iny = 0 then iny := 4;
+ iny := iny - 1;
+ if inx-1 <= length(codescheme)
+ then readstr(substr(codescheme,inx-1,1),chrt)
+ else chrt := chrx['00'X];
+ with outrec.fourbytes do case iny of
+ 0 :byte0 := ordx[chrt];
+ 1 :byte1 := ordx[chrt];
+ 2 :byte2 := ordx[chrt];
+ 3 :begin
+ byte3 := ordx[chrt];
+ writeout(outrec,4);
+ end;
+ otherwise error(99,fatal);
+ end;
+ end;
+ if length(fontname) > 8
+ then begin
+ error(27,notreallyfatal);
+ fontname := substr(fontname,1,8);
+ end;
+ writeln('*** Font Name = ',fontname);
+ outrec.fourbytes.byte0 := length(fontname);
+ for inx := 2 to 20 do begin
+ iny := inx mod 4;
+ if iny = 0 then iny := 4;
+ iny := iny - 1;
+ if inx-1 <= length(fontname)
+ then readstr(substr(fontname,inx-1,1),chrt)
+ else chrt := chrx['00'X];
+ with outrec.fourbytes do case iny of
+ 0 :byte0 := ordx[chrt];
+ 1 :byte1 := ordx[chrt];
+ 2 :byte2 := ordx[chrt];
+ 3 :begin
+ byte3 := ordx[chrt];
+ writeout(outrec,4);
+ end;
+ otherwise error(99,fatal);
+ end;
+ end;
+ outrec.int := 0;
+ writeout(outrec,6); {no Parc face byte now}
+ @<Write out FINFO part of font file@>
+ @<write out widths@>
+ @<write out heights@>
+ @<write out depths@>
+ @<write out itcorrs@>
+ @<write out ligature/kern programs@>
+ @<write out extension chars@>
+ @<write params@>
+ writeln('End of font file preprocessor');
+
+@
+ @<Write out FINFO part of font file@>=
+ for inx := 0 to num_entries-1 do writeout(outstuff[inx],5);
+
+@
+ @<write out widths@>=
+ if dump then writeln('*** Widths');
+ for inx := 0 to trunc(width[-1]) do begin
+ outrec.int := scaleout(width[inx]);
+ writeout(outrec,2);
+ end;
+
+@
+ @<write out heights@>=
+ if dump then writeln('*** Heights');
+ for inx := 0 to trunc(height[-1]) do begin
+ outrec.int := scaleout(height[inx]);
+ writeout(outrec,2);
+ end;
+
+@
+ @<write out depths@>=
+ if dump then writeln('*** Depths');
+ for inx := 0 to trunc(depth[-1]) do begin
+ outrec.int := scaleout(depth[inx]);
+ writeout(outrec,2);
+ end;
+
+@
+ @<write out itcorrs@>=
+ if dump then writeln('*** itcorrs');
+ for inx := 0 to trunc(itcorr[-1]) do begin
+ outrec.int := scaleout(itcorr[inx]);
+ writeout(outrec,2);
+ end;
+
+@
+ @<write out ligature/kern programs@>=
+ if dump then writeln('*** Lig/Kern programs');
+ for inx := 0 to numligs + numkerns + 1 do
+ writeout(ligout[inx],4);
+ {write out kern values as fixes}
+ if dump then writeln('*** Kern values');
+ for inx := 0 to trunc(kernout[-1]) do begin
+ outrec.int := scaleout(kernout[inx]);
+ writeout(outrec,2);
+ end;
+
+@
+ @<write out extension chars@>=
+ if dump then writeln('*** Extension chars');
+ for inx := 0 to numext do
+ with ext[inx], outrec.fourbytes do begin
+ byte0 := top;
+ byte1 := mid;
+ byte2 := bot;
+ byte3 := ext;
+ writeout(outrec,4);
+ end; {with..begin}
+
+@
+ @<write params@>=
+ if dump then writeln('*** Params');
+ for pp := slant to bgopsp5 do
+ if pp in paramset[standard]+paramset[fontype]
+ then begin
+ if dump then begin
+ printparam(pp);
+ write(': ');
+ end;
+ outrec.int := scaleout(params[pp]);
+ writeout(outrec,2);
+ end; {then..begin}
+
+@* INDEX.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 21:31:59 +0000