path: root/system/std.zusatz/1.7.5/src/font convertor 9

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;