PACKET font convertor (* Autor : Rudolf Ruland *) (* Stand : 11.07.86 *) DEFINES create font table , (* Version 9 *) add fonts, create font file : LET t tag = 1, t bold = 2, t number = 3, t text = 4, t operator = 5, t delimiter = 6, t end of file = 7, nil modus = 0, font table modus = 1, font modus = 2, extension modus = 3, x unit = 1, y unit = 2, on string = 3, off string = 4, indentation pitch = 5, font lead = 6, font height = 7, font depth = 8, larger font = 9, smaller font = 10, font string = 11, y off sets = 12, bold off set = 13; THESAURUS VAR names, english identification := empty thesaurus, german identification := empty thesaurus; insert (english identification, "xunit"); insert (english identification, "yunit"); insert (english identification, "onstring"); insert (english identification, "offstring"); insert (english identification, "indentationpitch"); insert (english identification, "fontlead"); insert (english identification, "fontheight"); insert (english identification, "fontdepth"); insert (english identification, "nextlargerfont"); insert (english identification, "nextsmallerfont"); insert (english identification, "fontstring"); insert (english identification, "yoffsets"); insert (english identification, "boldoffset"); insert (german identification, "xeinheit"); insert (german identification, "yeinheit"); insert (german identification, "onsequenz"); insert (german identification, "offsequenz"); insert (german identification, "einrueckbreite"); insert (german identification, "durchschuss"); insert (german identification, "fonthoehe"); insert (german identification, "fonttiefe"); insert (german identification, "groessererfont"); insert (german identification, "kleinererfont"); insert (german identification, "fontsequenz"); insert (german identification, "yverschiebungen"); insert (german identification, "boldverschiebung"); INT VAR modus, last modus, symbol type, int symbol, pitch, identification nr, link nr, extension code 1, char code 1, char code, char pos, vorzeichen, replacements length, index; TEXT VAR symbol, font table name, replacement, char, buffer, z; BOOL VAR english; FILE VAR file, font file; (*****************************************************************) LET max fonts = 50, max extensions = 120, font table type = 3009, FONTTABLE = STRUCT ( THESAURUS font names, TEXT replacements, font name links, extension chars, extension indexes, ROW 4 TEXT on strings, off strings, REAL x unit, y unit, ROW 256 INT replacements table, INT last font, last extension ROW max fonts STRUCT ( TEXT font string, font name indexes, replacements, extension chars, extension indexes, y offsets, ROW 256 INT pitch table, replacements table, INT indentation pitch, font lead, font height, font depth, next larger font, next smaller font, bold offset ) fonts , ROW max extensions STRUCT ( TEXT replacements, ROW 256 INT pitch table, replacements table, INT std pitch ) extensions , ); BOUND FONTTABLE VAR font table; DATASPACE VAR ds; INT VAR font nr, extension nr; . font : font table. fonts (font nr) . extension : font table. extensions (extension nr) . line nr : line no (file) - 1 .; (*****************************************************************) PROC create font table : create font table (last param) END PROC create font table; PROC create font table (TEXT CONST font file) : file := sequential file (input, font file); disable stop; ds := nilspace; modus := nil modus; load; IF is error THEN error (errormessage) FI; forget (ds); END PROC create font table; PROC add fonts (TEXT CONST font tab name, font file) : file := sequential file (input, font file); font table name := font tab name; change all (font table name, " ", ""); IF NOT exists (font table name) COR type (old (font table name)) <> font table type THEN errorstop ("Fonttabelle """ + font table name + """ gibt es nicht") FI; disable stop; ds := old (font table name); fonttable := ds; modus := font modus; font nr := fonttable. last font; extension nr := fonttable. last extension; load; IF is error THEN error (errormessage) FI; forget (ds); END PROC add fonts; PROC load : enable stop; initialize loading; REP get kennung; get identification; get char specifications; UNTIL eof (file) OR symbol type = t end of file PER; font table found; . initialize loading : scan (file); get next symbol; . font table found : IF font nr = 0 THEN errorstop ("Fonts zur Fonttabelle """ + font table name + """ fehlen"); ELSE font table. last font := font nr; font table. last extension := extension nr; forget (font table name, quiet); copy (ds, font table name); type (old (font table name), font table type); forget (ds); ds := nilspace; FI; . get next symbol : next symbol (file, symbol, symbol type); . get semicolon : get next symbol; IF symbol <> ";" OR symbol type <> t delimiter THEN errorstop ("';' erwartet") FI; . get kennung : cout (line nr); IF symbol type <> t bold THEN errorstop ("Kennung erwartet") FI; IF symbol = "FONTTABLE" OR symbol = "FONTTABELLE" THEN initialize font table; get font table name; ELIF symbol = "FONT" THEN initialize font; get font names; ELIF symbol = "EXTENSION" OR symbol = "ERWEITERUNG" THEN get extension char; initialize extension; ELIF modus = nil modus THEN errorstop ("Kennung 'FONTTABLE' oder 'FONTTABELLE' zu Beginn der Datei erwartet") ELSE errorstop ("unzulaessige Kennung") FI; . initialize font table : IF modus <> nil modus THEN font table found FI; modus := font table modus; font nr := 0; extension nr := 0; font table := ds; font table. font names := empty thesaurus; font table. replacements := ""; font table. font name links := ""; font table. extension chars := ""; font table. extension indexes := ""; font table. x unit := 10.0/2.54; font table. y unit := 6.0/2.54; font table. replacements table := 0; FOR index FROM 1 UPTO 4 REP font table. on strings (index) := ""; font table. off strings (index) := ""; PER; . get font table name : get name list; symbol type := t text; symbol := name (names, 1); IF exists (symbol) THEN forget (symbol); IF exists (symbol) THEN errorstop ("Fonttabelle existiert schon") FI; FI; font table name := symbol; . initialize font : IF font nr = max fonts THEN errorstop ("zu viele Fonts") FI; font nr INCR 1; modus := font modus; replacements length := LENGTH font table. replacements; font. font string := ""; font. font name indexes := ""; font. replacements := ""; font. extension chars := ""; font. extension indexes := ""; font. y offsets := ""0""0""; font. indentation pitch := int (font table. x unit * 2.54 / 10.0); font. font lead := 0; font. font height := int (font table. y unit * 2.54 / 6.0); font. font depth := 0; font. next larger font := 0; font. next smaller font := 0; font. bold offset := 0; font. pitch table := font. indentation pitch; font. replacements table := font table. replacements table; FOR index FROM 1 UPTO LENGTH font table. extension chars REP font. replacements table ( code (font table. extension chars SUB index) + 1 ) := maxint; PER; . get font names : get name list; index := 0; symbol type := t text; WHILE next font name REP link nr := link (font table. font names, symbol); IF link nr = 0 THEN insert (font table. font names, symbol, link nr); font table. font name links CAT font nr; ELIF (font table. font name links ISUB link nr) = 0 THEN replace (font table. font name links, link nr, font nr); ELSE errorstop ("Font existiert in Fonttabelle """ + font table name + """ schon") FI; font. font name indexes CAT link nr; PER; . next font name : get (names, symbol, index); symbol <> "" . get extension char : get name list; symbol type := t text; symbol := name (names, 1); IF LENGTH symbol <> 1 THEN errorstop ("nur ein Zeichen bei Erweiterung erlaubt") FI; extension code 1 := code (symbol) + 1; IF NOT is kanji esc (symbol) THEN errorstop ("ESC-Zeichen erwartet") FI; . initialize extension : IF NOT two bytes THEN errorstop ("Erweiterungen nur im zwei-Byte-Modus erlaubt") FI; IF extension nr = max extensions THEN errorstop ("zu viele Erweiterungen") FI; extension nr INCR 1; IF modus <> extension modus THEN last modus := modus FI; modus := extension modus; IF last modus = font table modus THEN initalize font table extension ELSE initalize font extension FI; . initalize font table extension : IF pos (font table. extension chars, symbol) <> 0 THEN errorstop ("Erweiterung wurde schon definiert") FI; extension. replacements := ""; extension. std pitch := 0; extension. pitch table := 0; extension. replacements table := 0; font table. extension chars CAT symbol; font table. extension indexes CAT extension nr; font table. replacements table (extension code 1) := max int; replacements length := 0; . initalize font extension : IF pos (font. extension chars, symbol) <> 0 THEN errorstop ("Erweiterung wurde schon definiert") FI; extension. replacements := ""; extension. std pitch := font. pitch table (extension code 1) XOR (-maxint-1); extension. pitch table := extension. std pitch; font. extension chars CAT symbol; font. extension indexes CAT extension nr; char pos := pos (font table. extension chars, symbol); IF char pos <> 0 THEN index := font table. extension indexes ISUB char pos; extension. replacements table := font table. extensions (index). replacements table; replacements length := LENGTH font table. extensions (index). replacements; font. replacements table (extension code 1) := max int; ELSE extension. replacements table := 0; replacements length := 0; FI; . get identification : WHILE identification found REP cout (line nr); determine identification link nr; select identification; PER; . identification found : get next symbol; symbol type = t tag . determine identification link nr : identification nr := link (english identification, symbol); english := TRUE; IF identification nr = 0 THEN identification nr := link (german identification, symbol); english := FALSE; IF identification nr = 0 THEN errorstop ("unzulaesige Identifikation") FI; FI; . select identification : get next symbol; IF symbol <> "=" OR symbol type <> t operator THEN errorstop ("'=' nach Identifikation fehlt") FI; get next symbol; SELECT identification nr OF CASE x unit : x unit found CASE y unit : y unit found CASE on string : on string found CASE off string : off string found CASE indentation pitch : indentation pitch found CASE font lead : font lead found CASE font height : font height found CASE font depth : font depth found CASE larger font : larger font found CASE smaller font : smaller font found CASE font string : font string found CASE y offsets : y offsets found CASE bold offset : bold offset found END SELECT; . x unit found : check modus (font table modus); font table. x unit := real (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("REAL-Denoter nach 'x unit' erwartet") ELSE errorstop ("REAL-Denoter nach 'x einheit' erwartet") FI; FI; get semicolon; . y unit found : check modus (font table modus); font table. y unit := real (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("REAL-Denoter nach 'y unit' erwartet") ELSE errorstop ("REAL-Denoter nach 'y einheit' erwartet") FI; FI; get semicolon; . on string found : check modus (font table modus); FOR index FROM 1 UPTO 4 REP IF symbol type <> t text THEN IF english THEN errorstop ("TEXT-Denoter nach 'on string' erwartet") ELSE errorstop ("TEXT-Denoter nach 'on sequenz' erwartet") FI; FI; font table. on strings (index) := symbol; get next symbol; IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter THEN errorstop ("',' oder ';' in Liste erwartet") FI; IF symbol = ";" THEN LEAVE on string found FI; IF index = 4 THEN errorstop ("';' erwartet") FI; get next symbol; PER; . off string found : check modus (font table modus); FOR index FROM 1 UPTO 4 REP IF symbol type <> t text THEN IF english THEN errorstop ("TEXT-Denoter nach 'off string' erwartet") ELSE errorstop ("TEXT-Denoter nach 'off sequenz' erwartet") FI; FI; font table. off strings (index) := symbol; get next symbol; IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter THEN errorstop ("',' oder ';' in Liste erwartet") FI; IF symbol = ";" THEN LEAVE off string found FI; IF index = 4 THEN errorstop ("';' erwartet") FI; get next symbol; PER; . indentation pitch found : check modus (font modus); font. indentation pitch := int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'indentation pitch' erwartet") ELSE errorstop ("INT-Denoter nach 'einrueckbreite' erwartet") FI; FI; font. pitch table := font. indentation pitch; get semicolon; . font lead found : check modus (font modus); font. font lead := int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'font lead' erwartet") ELSE errorstop ("INT-Denoter nach 'durchschuss' erwartet") FI; FI; get semicolon; . font height found : check modus (font modus); font. font height := int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'font height' erwartet") ELSE errorstop ("INT-Denoter nach 'fonthoehe' erwartet") FI; FI; get semicolon; . font depth found : check modus (font modus); font. font depth := int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'font depth' erwartet") ELSE errorstop ("INT-Denoter nach 'fonttiefe' erwartet") FI; FI; get semicolon; . larger font found : check modus (font modus); IF symbol type <> t text THEN IF english THEN errorstop ("TEXT-Denoter nach 'next larger font' erwartet") ELSE errorstop ("TEXT-Denoter nach 'groesserer font' erwartet") FI; FI; determine link nr; font. next larger font := link nr; get semicolon; . smaller font found : check modus (font modus); IF symbol type <> t text THEN IF english THEN errorstop ("TEXT-Denoter nach 'next smaller font' erwartet") ELSE errorstop ("TEXT-Denoter nach 'kleinerer font' erwartet") FI; FI; determine link nr; font. next smaller font := link nr; get semicolon; . determine link nr : change all (symbol, " ", ""); IF symbol = "" THEN link nr := 0 ELSE link nr := link (font table. font names, symbol); IF link nr = 0 THEN insert (font table. font names, symbol, link nr); font table. font name links CAT 0; FI; FI; . font string found : check modus (font modus); IF symbol type <> t text THEN IF english THEN errorstop ("TEXT-Denoter nach 'font string' erwartet") ELSE errorstop ("TEXT-Denoter nach 'fontsequenz' erwartet") FI; FI; font. font string := symbol; get semicolon; . y offsets found : check modus (font modus); font. y offsets := ""; REP IF symbol = "-" AND symbol type = t operator THEN vorzeichen := -1; get next symbol; ELSE vorzeichen := 1; FI; int symbol := vorzeichen * int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'y offsets' erwartet") ELSE errorstop ("INT-Denoter nach 'y verschiebungen' erwartet") FI; FI; font. y offsets CAT int symbol; get next symbol; IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter THEN errorstop ("',' oder ';' in Liste erwartet") FI; IF symbol = ";" THEN LEAVE y offsets found FI; get next symbol; PER; . bold offset found : check modus (font modus); IF symbol = "-" AND symbol type = t operator THEN vorzeichen := -1; get next symbol; ELSE vorzeichen := 1; FI; font. bold offset := vorzeichen * int (symbol); IF NOT last conversion ok THEN IF english THEN errorstop ("INT-Denoter nach 'bold offset' erwartet") ELSE errorstop ("INT-Denoter nach 'bold verschiebungen' erwartet") FI; FI; get semicolon; . get char specifications : WHILE char found REP cout (line nr); char specification; get next symbol; PER; . char found : symbol type = t text . char specification : IF LENGTH symbol <> 1 THEN errorstop ("nur ein Zeichen bei Zeichenangabe erlaubt") FI; char := symbol; char code 1 := code (char) + 1; look for specification; look for specification; get semicolon; . look for specification : get next symbol; IF symbol = ";" AND symbol type = t delimiter THEN LEAVE char specification ELIF symbol = "," AND symbol type = t delimiter THEN get specification ELSE errorstop ("',' oder ';' bei Zeichenspezifikation erwartet") FI; . get specification : get next symbol; IF symbol type = t number THEN pitch specification; ELIF symbol type = t text THEN replacement specification ELSE errorstop ("unzulaessiger Wert bei Zeichenspezifikation") FI; . pitch specification : int symbol := int (symbol); IF NOT last conversion ok THEN errorstop ("INT-Denoter bei Breitenangabe erwartet") FI; IF modus = font modus THEN font. pitch table (char code 1) := int symbol; IF is kanji esc (char) THEN set bit (font. pitch table (char code 1), 15) FI; ELIF modus = extension modus THEN IF last modus = font modus AND font. pitch table (extension code 1) <> max int THEN font. pitch table (extension code 1) := max int FI; extension. pitch table (char code 1) := int symbol; FI; . replacement specification : IF LENGTH symbol > 255 THEN errorstop ("Ersatzdarstellungen duerfen nur 255 Zeichen haben") FI; IF modus = font table modus THEN font table. replacements table (char code 1) := (LENGTH font table. replacements + 1); font table. replacements CAT code (LENGTH symbol); font table. replacements CAT symbol; IF is kanji esc (char) THEN set bit (font table. replacements table (char code 1), 15) FI; ELIF modus = font modus THEN font. replacements table (char code 1) := (replacements length + LENGTH font. replacements + 1); font. replacements CAT code (LENGTH symbol); font. replacements CAT symbol; IF is kanji esc (char) THEN set bit (font. replacements table (char code 1), 15) FI; ELIF modus = extension modus THEN IF last modus = font modus AND font. replacements table (extension code 1) <> max int THEN font. replacements table (extension code 1) := max int FI; extension. replacements table (char code 1) := (replacements length + LENGTH extension. replacements + 1); extension. replacements CAT code (LENGTH symbol); extension. replacements CAT symbol; FI; END PROC load; PROC get name list : names := empty thesaurus; get next symbol; IF symbol <> ":" OR symbol type <> t delimiter THEN errorstop ("':' nach Kennung erwartet") FI; REP get next symbol; change all (symbol, " ", ""); IF symbol type <> t text THEN errorstop ("TEXT-Denoter in Namesliste erwartet") FI; IF symbol = "" THEN errorstop ("'niltext' als Name nicht erlaubt") FI; insert (names, symbol); get next symbol; IF (symbol <> "," AND symbol <> ";") OR symbol type <> t delimiter THEN errorstop ("',' oder ';' in Liste erwartet") FI; UNTIL symbol = ";" PER; . get next symbol : next symbol (file, symbol, symbol type); END PROC get name list; OP := (ROW 256 INT VAR l, INT CONST r) : INT VAR i; IF modus = extension modus OR NOT two bytes THEN FOR i FROM 1 UPTO 256 REP l (i) := r PER; ELSE FOR i FROM 1 UPTO 129 REP l (i) := r PER; FOR i FROM 130 UPTO 160 REP l (i) := r - maxint - 1 PER; FOR i FROM 161 UPTO 224 REP l (i) := r PER; FOR i FROM 225 UPTO 240 REP l (i) := r - maxint - 1 PER; FOR i FROM 241 UPTO 256 REP l (i) := r PER; FI; END OP :=; PROC check modus (INT CONST mod) : IF mod <> modus THEN errorstop ("unzulaessige Identifikation") FI; END PROC check modus; PROC error (TEXT CONST message) : (*INT CONST l := error line;*) clear error; errorstop ("Zeile " + text (line nr) + " bei " + letztes symbol + " : " + message (* + errorline if neccessary *) ); . letztes symbol : IF symbol type <> t text THEN symbol ELSE decode (symbol); """" + symbol + """" FI (* . errorline if neccessary : IF l = 0 THEN "" ELSE " -> " + text (l) FI *) END PROC error; (*******************************************************************) PROC create font file (TEXT CONST font table name, font file name) : enable stop; connect font table; put font table in font file; . connect font table : buffer := font table name; change all (buffer, " ", ""); IF NOT exists (buffer) COR type (old (buffer)) <> font table type THEN errorstop ("Fonttabelle """ + buffer + """ gibt es nicht") FI; font table := old (buffer); . put font table in font file : enable stop; font file := sequential file (output, font file name); z := " "; max line length (font file, 1000); put font table; FOR font nr FROM 1 UPTO font table. last font REP put font PER; . put font table : z CAT "FONTTABLE : """; z CAT buffer; z CAT """;"; put z; z CAT " x unit = "; z CAT text (font table. x unit); z CAT ";"; put z; z CAT " y unit = "; z CAT text (font table. y unit); z CAT ";"; put z; z CAT " on string = """; z cat on strings; z CAT """;"; put z; z CAT " off string = """; z cat off strings; z CAT """;"; put z; put font table replacements; put font table extensions; put z; . z cat on strings : FOR index FROM 1 UPTO 4 REP buffer := font table. on strings (index); decode (buffer); z CAT buffer; IF index <> 4 THEN z CAT """, """ FI; PER; . z cat off strings : FOR index FROM 1 UPTO 4 REP buffer := font table. off strings (index); decode (buffer); z CAT buffer; IF index <> 4 THEN z CAT """, """ FI; PER; . put font table replacements : put z; FOR char code FROM 0 UPTO 255 REP char code 1 := char code + 1; link nr := font table. replacements table (char code 1); reset bit (link nr, 15); IF link nr > 0 AND link nr <> maxint THEN z CAT " "; put char code; put font table replacement; put z; FI; PER; . put font table replacement : replacement := subtext (font table. replacements, link nr + 1, link nr + code (font table. replacements SUB link nr) ); put replacement; . put font table extensions : IF font table. extension chars <> "" THEN FOR index FROM 1 UPTO LENGTH font table. extension chars REP put font table extension PER; FI; . put font table extension : put z; z CAT " EXTENSION : """""; z CAT text 3 (code (font table. extension chars SUB index)); z CAT """"";"; put z; put z; replacements length := 0; extension nr := font table. extension indexes ISUB index; FOR char code FROM 0 UPTO 255 REP char code 1 := char code + 1; link nr := extension. replacements table (char code 1); IF link nr > 0 THEN z CAT " "; put char code; put extension replacement; put z; FI; PER; . put font : put z; z CAT " FONT : "; z cat font names; z CAT ";"; put z; z CAT " indentation pitch = "; z CAT text(font. indentation pitch); z CAT ";"; put z; IF font. font lead <> 0 THEN z CAT " font lead = "; z CAT text(font. font lead); z CAT ";"; put z; FI; z CAT " font height = "; z CAT text(font. font height); z CAT ";"; put z; IF font. font depth <> 0 THEN z CAT " font depth = "; z CAT text(font. font depth); z CAT ";"; put z; FI; IF next larger <> "" THEN z CAT " next larger font = """; z CAT next larger; z CAT """;"; put z; FI; IF next smaller <> "" THEN z CAT " next smaller font = """; z CAT next smaller; z CAT """;"; put z; FI; IF font. font string <> "" THEN z CAT " font string = """; z CAT font string; z CAT """;"; put z; FI; IF (font. y offsets ISUB 1) <> 0 OR LENGTH font. y offsets > 2 THEN z CAT " y offsets = "; z cat y offsets; z CAT ";"; put z; FI; IF font. bold offset <> 0 THEN z CAT " bold offset = "; z CAT text(font. bold offset); z CAT ";"; put z; FI; put font pitches and replacements; put font extensions; . next larger : name (font table. font names, font. next larger font) . next smaller : name (font table. font names, font. next smaller font) . font string : buffer := font. font string; decode (buffer); buffer . z cat font names : z CAT """"; z CAT name (font table. font names, font. font name indexes ISUB 1); z CAT """"; FOR index FROM 2 UPTO LENGTH font. font name indexes DIV 2 REP z CAT ", """; z CAT name (font table. font names, font. font name indexes ISUB index); z CAT """"; PER; . z cat y offsets : z CAT text (font. y offsets ISUB 1); FOR index FROM 2 UPTO LENGTH font. y offsets DIV 2 REP z CAT ", "; z CAT text (font. y offsets ISUB index); PER; . put font pitches and replacements : BOOL VAR ausgabe := FALSE; replacements length := LENGTH font table. replacements; put z; z CAT " "; FOR char code FROM 0 UPTO 255 REP char code 1 := char code + 1; pitch := font. pitch table (char code 1); reset bit (pitch, 15); link nr := font. replacements table (char code 1); reset bit (link nr, 15); IF (pitch <> font. indentation pitch) OR (link nr > replacements length AND link nr <> maxint) THEN put font char pitch and replacement; IF ausgabe THEN put z; ausgabe := FALSE; ELSE ausgabe := TRUE; FI; z CAT " "; FI; PER; IF ausgabe THEN put z ELSE z := " " FI; . put font char pitch and replacement : put char code; put font char pitch; IF link nr > replacements length AND link nr <> maxint THEN put font replacement; IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; ELIF ausgabe THEN z CAT ";" ELSE z CAT "; "; FI; . put font char pitch : IF pitch = max int THEN char pos := pos (font. extension chars, code (char code)); IF char pos <> 0 THEN pitch := font table. extensions (font. extension indexes ISUB char pos). std pitch FI; FI; put char pitch; . put font replacement : link nr DECR replacements length; replacement := subtext (font. replacements, link nr + 1, link nr + code (font. replacements SUB link nr) ); put replacement; . put font extensions : IF font. extension chars <> "" THEN FOR index FROM 1 UPTO LENGTH font. extension chars REP put font extension PER; FI; . put font extension : put z; z CAT " ERWEITERUNG : """""; z CAT text 3 (code (font. extension chars SUB index)); z CAT """"";"; put z; put z; z CAT " "; detemine replacements length; extension nr := font. extension indexes ISUB index; ausgabe := FALSE; FOR char code FROM 0 UPTO 255 REP char code 1 := char code + 1; pitch := extension. pitch table (char code 1); link nr := extension. replacements table (char code 1); IF pitch <> extension. std pitch OR link nr > replacements length THEN put extension char pitch and replacement; IF ausgabe THEN put z; ausgabe := FALSE; ELSE ausgabe := TRUE; FI; z CAT " "; FI; PER; IF ausgabe THEN put z ELSE z := " " FI; . detemine replacements length : char pos := pos (font table. extension chars, font. extension chars SUB index); IF char pos <> 0 THEN replacements length := LENGTH font table. extensions (font table. extension indexes ISUB char pos). replacements; ELSE replacements length := 0; FI; . put extension char pitch and replacement : put char code; put char pitch; IF link nr > replacements length THEN put extension replacement; IF NOT ausgabe THEN z CAT (6 - LENGTH replacement) * " " FI; ELIF ausgabe THEN z CAT ";" ELSE z CAT "; "; FI; . put extension replacement : link nr DECR replacements length; replacement := subtext (extension. replacements, link nr + 1, link nr + code (extension. replacements SUB link nr) ); put replacement; . put char code : IF (char code >= 32 AND char code <= 122) OR (char code >= 214 AND char code <= 223) OR char code = 124 OR char code = 126 OR char code = 251 THEN z CAT "(* "; z CAT code (char code); z CAT " *) """""; ELSE z CAT " """""; FI; z CAT text 3 (char code); z CAT """"""; . put char pitch : z CAT ","; z CAT text (pitch, 5); . put replacement : decode (replacement); z CAT ", """; z CAT replacement; z CAT """;" END PROC create font file; PROC put z : putline (font file, z); cout (lines (font file)); z := " "; END PROC put z; PROC decode (TEXT VAR string) : INT VAR p; change all (string, """", """"""); p := pos (string, ""0"", ""31"", 1); WHILE p <> 0 REP change (string, p, p, """" + text (code(string SUB p)) + """"); p := pos (string, ""0"", ""31"", p); PER; p := pos (string, ""127"", ""255"", 1); WHILE p <> 0 REP change (string, p, p, """" + text (code(string SUB p)) + """"); p := pos (string, ""127"", ""255"", p); PER; END PROC decode; TEXT PROC text 3 (INT CONST value) : buffer := text (value, 3); change all (buffer, " ", "0"); buffer END PROC text 3; END PACKET font convertor;