diff options
Diffstat (limited to 'system/std.zusatz/1.7.5/src/eumel printer')
| -rw-r--r-- | system/std.zusatz/1.7.5/src/eumel printer | 3067 |
1 files changed, 3067 insertions, 0 deletions
diff --git a/system/std.zusatz/1.7.5/src/eumel printer b/system/std.zusatz/1.7.5/src/eumel printer new file mode 100644 index 0000000..2fd3f38 --- /dev/null +++ b/system/std.zusatz/1.7.5/src/eumel printer @@ -0,0 +1,3067 @@ +PACKET eumel printer (* Autor : Rudolf Ruland *)
+ (* Version : 4 *)
+ (* Stand : 07.08.86 *)
+ DEFINES print,
+ with elan listings,
+ is elan source,
+ bottom label for elan listings,
+ x pos,
+ y pos,
+ y offset index,
+ line type,
+ material,
+ pages printed :
+
+
+LET std x wanted = 2.54,
+ std y wanted = 2.35,
+ std limit = 16.0,
+ std pagelength = 25.0,
+ std linefeed faktor = 1.0,
+ std material = "";
+
+LET blank = " ",
+ blank code 1 = 33,
+ geschuetztes blank = ""223"",
+ keine blankanalyse = 0,
+ einfach blank = 1,
+ doppel blank = 2,
+
+ anweisungszeichen = "#",
+ anweisungszeichen code 1 = 36,
+ geschuetztes anweisungszeichen = ""222"",
+ druckerkommando zeichen = "/",
+ quote = """",
+
+ erweiterungs ausgang = 32767,
+ blank ausgang = 32766,
+ anweisungs ausgang = 32765,
+ d code ausgang = 32764,
+ max breite = 32763,
+
+ punkt = ".",
+
+ leer = 0,
+
+ kommando token = 0,
+ text token = 1,
+
+ underline linetype = 1,
+ underline bit = 0,
+ bold bit = 1,
+ italics bit = 2,
+ modifikations liste = "ubir",
+ anzahl modifikationen = 4,
+
+ document = 1,
+ page = 2,
+
+ write text = 1,
+ write cmd = 2,
+ carriage return = 3,
+ move = 4,
+ draw = 5,
+ on = 6,
+ off = 7,
+ type = 8,
+
+ tag type = 1,
+ bold type = 2,
+ number type = 3,
+ text type = 4,
+ delimiter type = 6,
+ eof type = 7;
+
+
+INT CONST null ausgang := -32767-1;
+
+ROW anzahl modifikationen INT CONST modifikations werte :=
+ ROW anzahl modifikationen INT : (1, 2, 4, 8);
+
+TEXT CONST anweisungsliste :=
+ "type:1.1on:2.1off:3.1center:4.0right:5.0u:6.0d:7.0e:8.0b:9.0" +
+ "fillchar:10.1mark:11.2markend:12.0" +
+ "ub:13.0ue:14.0fb:15.0fe:16.0" +
+ "block:20.0columns:21.2columnsend:22.0free:23.1limit:24.1linefeed:25.1" +
+ "material:26.1page:27.01pagelength:29.1start:30.2" +
+ "table:31.0tableend:32.0clearpos:33.01" +
+ "lpos:35.1rpos:36.1cpos:37.1dpos:38.2bpos:39.2" +
+ "textbegin:40.02textend:42.0" +
+ "indentation:43.1ytab:44.1";
+
+LET a type = 1, a block = 20,
+ a on = 2, a columns = 21,
+ a off = 3, a columnsend = 22,
+ a center = 4, a free = 23,
+ a right = 5, a limit = 24,
+ a up = 6, a linefeed = 25,
+ a down = 7, a material = 26,
+ a end up or down = 8, a page0 = 27,
+ a bsp = 9, a page1 = 28,
+ a fill char = 10, a pagelength = 29,
+ a mark = 11, a start = 30,
+ a markend = 12, a table = 31,
+ a ub = 13, a tableend = 32,
+ a ue = 14, a clearpos0 = 33,
+ a fb = 15, a clearpos1 = 34,
+ a fe = 16, a lpos = 35,
+ a rpos = 36,
+ a cpos = 37,
+ a dpos = 38,
+ a bpos = 39,
+ a textbegin0 = 40,
+ a textbegin2 = 41,
+ a textend = 42,
+ a indentation = 43,
+ a y tab = 44;
+
+INT VAR a xpos, a breite, a font, a modifikationen,
+ a modifikationen fuer x move, a ypos, aktuelle ypos,
+ letzter font, letzte modifikationen,
+ d ypos, d xpos, d font, d modifikationen,
+
+ zeilenpos, alte zeilenpos, zeilen laenge, anzahl zeichen, ausgang,
+ anzahl einrueck blanks, blankbreite,
+ einrueckbreite, aktuelle einrueckbreite, alte einrueckbreite,
+ font durchschuss, fonthoehe, font tiefe,
+ groesste fonthoehe, aktuelle zeilenhoehe, letzte zeilenhoehe,
+ blankmodus, alter blankmodus,
+ token zeiger, erstes token der zeile,
+
+ erstes tab token, tab anfang, anzahl blanks,
+ d code 1, d pitch, fuell zeichen breite, erstes fuell token,
+ letztes fuell token,
+
+ x size, y size, x wanted, y wanted, x start, y start,
+ pagelength, limit, indentation,
+ left margin, top margin, seitenlaenge,
+ papierlaenge, papierbreite,
+ luecke, anzahl spalten, aktuelle spalte,
+
+ verschiebung, rest, neue modifikationen, modifikations modus, pass,
+
+ int param, anweisungs index, anzahl params, index,
+
+ gedruckte seiten;
+
+BOOL VAR zeile ist absatzzeile, letzte zeile war absatzzeile,
+ zeile muss geblockt werden, rechts, a block token, offsets,
+ tabellen modus, block modus, center modus, right modus,
+ seite ist offen, vor erster seite;
+
+REAL VAR linefeed faktor, real param;
+
+TEXT VAR zeile, anweisung, par1, par2, material wert, replacements,
+ fuell zeichen, d string, font offsets;
+
+ROW 256 INT VAR zeichenbreiten, replacement tabelle, zeichen zaehler;
+
+INITFLAG VAR in dieser task := FALSE;
+
+. zeile ist zu ende : zeilenpos > zeilen laenge
+
+. zeilen breite : a xpos - left margin
+
+. neue zeilenhoehe : int (linefeed faktor * real (fonthoehe) + 0.5)
+
+. naechstes zeichen ist blank : pos (zeile, blank, zeilenpos + 1, zeilenpos + 1) <> 0
+
+. naechstes nicht blankes zeichen : pos (zeile, ""33"", ""255"", zeilenpos)
+
+. in letzter spalte : aktuelle spalte >= anzahl spalten
+
+. anfangs blankmodus :
+ INT VAR dummy;
+ IF center modus OR right modus
+ THEN dummy
+ ELIF index zaehler = 0
+ THEN blankmodus
+ ELSE alter blankmodus
+ FI
+
+. initialisiere tab variablen :
+ erstes tab token := token index f + 1;
+ tab anfang := zeilen breite;
+ anzahl blanks := 0;
+.;
+
+(******************************************************************)
+
+LET zeilen nr laenge = 4,
+ teil einrueckung = 5,
+
+ headline pre = "Zeile **** E L A N EUMEL 1.7.5 **** ",
+ headline post = " **** ";
+
+INT VAR zeilen nr, rest auf seite,
+ max zeichen zeile, max zeichen fuss, layout laenge, layout laenge name,
+ symbol type, naechster symbol type;
+
+BOOL VAR vor erstem packet, innerhalb der define liste;
+
+TEXT VAR bottom label, dateiname, layout blanks, refinement layout zeile;
+
+
+. symbol : fuell zeichen
+. naechstes symbol : d string
+. elan text : d token. text
+.;
+
+(******************************************************************)
+(*** tokenspeicher ***)
+
+LET max token = 3000,
+ max ypos = 1000,
+
+ TOKEN = STRUCT (TEXT text,
+ INT xpos, breite, font, modifikationen,
+ modifikationen fuer x move,
+ offset index, naechster token index,
+ BOOL block token ),
+
+ YPOS = STRUCT (INT ypos, vorheriger ypos index, naechster ypos index,
+ erster token index, letzter token index ),
+
+ TOKENLISTE = STRUCT (ROW max token TOKEN token liste,
+ ROW max ypos YPOS ypos liste );
+
+DATASPACE VAR ds;
+
+BOUND TOKENLISTE VAR tokenspeicher;
+
+TOKEN VAR d token, offset token;
+
+INT VAR erster ypos index a, letzter ypos index a,
+ erster ypos index d, letzter ypos index d,
+ ypos index, ypos index f, ypos index a, ypos index d,
+ token index, token index f;
+
+. t : tokenspeicher. token liste (token index)
+. tf : tokenspeicher. token liste (token index f)
+
+. y : tokenspeicher. ypos liste (ypos index)
+. yf : tokenspeicher. ypos liste (ypos index f)
+. ya : tokenspeicher. ypos liste (ypos index a)
+. yd : tokenspeicher. ypos liste (ypos index d)
+
+. loesche druckspeicher :
+ erster ypos index d := 0;
+ ypos index f := 0;
+ token index f := 0;
+
+. druckspeicher ist nicht leer :
+ erster ypos index d <> 0
+
+. loesche analysespeicher :
+ erster ypos index a := 0;
+
+. analysespeicher ist nicht leer :
+ erster ypos index a <> 0
+.;
+
+(******************************************************************)
+(*** anweisungsspeicher ***)
+
+INT VAR anweisungszaehler;
+TEXT VAR anweisungs indizes, params1 zeiger, params2 zeiger;
+THESAURUS VAR params1, params2;
+
+PROC loesche anweisungsspeicher :
+
+ anweisungs zaehler := 0;
+ anweisungs indizes := "";
+ params1 zeiger := "";
+ params2 zeiger := "";
+ params1 := empty thesaurus;
+ params2 := empty thesaurus;
+
+END PROC loesche anweisungsspeicher;
+
+(******************************************************************)
+(*** indexspeicher ***)
+
+INT VAR index zaehler;
+TEXT VAR grosse fonts, verschiebungen;
+
+PROC loesche indexspeicher :
+
+ index zaehler := 0;
+ grosse fonts := "";
+ verschiebungen := "";
+
+END PROC loesche indexspeicher;
+
+
+(******************************************************************)
+(*** tabellenspeicher ***)
+
+LET max tabs = 30,
+ TABELLENEINTRAG = STRUCT (INT tab typ, tab position, tab param);
+
+TEXT VAR tab liste, fill char;
+THESAURUS VAR d strings;
+ROW max tabs TABELLENEINTRAG VAR tabspeicher;
+
+INT VAR tab index;
+
+. tab typ : tab speicher (tab liste ISUB tab index). tab typ
+. tab position : tab speicher (tab liste ISUB tab index). tab position
+. tab param : tab speicher (tab liste ISUB tab index). tab param
+. anzahl tabs : LENGTH tab liste DIV 2
+.;
+
+PROC loesche tabellenspeicher :
+
+ fill char := " ";
+ tabliste := "";
+ d strings := empty thesaurus;
+ FOR tab index FROM 1 UPTO max tabs
+ REP tab speicher (tab index). tab typ := leer PER;
+
+END PROC loesche tabellenspeicher;
+
+(******************************************************************)
+(*** markierungsspeicher ***)
+
+INT VAR mark index l, mark index r, alter mark index l, alter mark index r;
+
+ROW 4 TOKEN VAR mark token;
+
+. markierung links : mark index l > 0
+. markierung rechts : mark index r > 0
+.;
+
+PROC loesche markierung :
+
+ mark index l := 0;
+ mark index r := 0;
+
+END PROC loesche markierung;
+
+
+PROC loesche alte markierung :
+
+ alter mark index l := 0;
+ alter mark index r := 0;
+
+END PROC loesche alte markierung;
+
+
+PROC initialisiere markierung :
+
+ FOR mark index l FROM 1 UPTO 4
+ REP mark token (mark index l). modifikationen fuer x move := 0;
+ mark token (mark index l). offset index := text token;
+ mark token (mark index l). block token := FALSE;
+ mark token (mark index l). naechster token index := 0;
+ PER;
+
+END PROC initialisiere markierung;
+
+(******************************************************************)
+(*** durchschuss ***)
+
+INT VAR durchschuss 1, durchschuss 2, anzahl durchschuss 1,
+ anzahl durchschuss, zeilen zaehler;
+
+BOOL VAR wechsel := TRUE;
+
+INT PROC durchschuss :
+
+ zeilen zaehler INCR 1;
+ IF zeilen zaehler <= anzahl durchschuss 1
+ THEN durchschuss 1
+ ELIF zeilen zaehler <= anzahl durchschuss
+ THEN durchschuss 2
+ ELSE 0
+ FI
+
+END PROC durchschuss;
+
+
+PROC neuer durchschuss (INT CONST anzahl, rest) :
+
+ zeilen zaehler := 0;
+ anzahl durchschuss := anzahl;
+ IF anzahl > 0
+ THEN IF wechsel
+ THEN durchschuss 1 := rest DIV anzahl durchschuss;
+ durchschuss 2 := durchschuss 1 + sign (rest);
+ anzahl durchschuss 1 := anzahl durchschuss -
+ abs (rest) MOD anzahl durchschuss;
+ wechsel := FALSE;
+ ELSE durchschuss 2 := rest DIV anzahl durchschuss;
+ durchschuss 1 := durchschuss 2 + sign (rest);
+ anzahl durchschuss 1 := abs (rest) MOD anzahl durchschuss;
+ wechsel := TRUE;
+ FI;
+ ELSE loesche durchschuss
+ FI;
+
+END PROC neuer durchschuss;
+
+
+PROC loesche durchschuss :
+
+ durchschuss 1 := 0;
+ durchschuss 2 := 0;
+ anzahl durchschuss 1 := 0;
+ anzahl durchschuss := 0;
+ zeilen zaehler := 0;
+
+END PROC loesche durchschuss;
+
+(****************************************************************)
+
+PROC initialisierung :
+
+ forget (ds);
+ ds := nilspace; tokenspeicher := ds;
+ loesche druckspeicher;
+ loesche anweisungsspeicher;
+ loesche indexspeicher;
+ initialisiere markierung;
+ right modus := FALSE;
+ center modus := FALSE;
+ seite ist offen := FALSE;
+ pass := 0;
+ a breite := 0;
+ a block token := FALSE;
+ a modifikationen fuer x move := 0;
+ d code 1 := leer;
+ erstes fuell token := leer;
+ IF two bytes
+ THEN FOR index FROM 1 UPTO 129 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 130 UPTO 160 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 161 UPTO 224 REP zeichen zaehler (index) := 1 PER;
+ FOR index FROM 225 UPTO 240 REP zeichen zaehler (index) := - maxint PER;
+ FOR index FROM 241 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ ELSE FOR index FROM 1 UPTO 256 REP zeichen zaehler (index) := 1 PER;
+ FI;
+
+END PROC initialisierung;
+
+(****************************************************************)
+(*** print - Kommando ***)
+
+BOOL VAR elan listings erlaubt;
+FILE VAR eingabe;
+
+with elan listings (TRUE);
+
+PROC with elan listings (BOOL CONST flag) :
+ elan listings erlaubt := flag;
+END PROC with elan listings;
+
+BOOL PROC with elan listings : elan listings erlaubt END PROC with elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute ):
+
+ print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ FALSE, "");
+
+END PROC print;
+
+
+PROC print (FILE VAR file,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ eingabe := file;
+ input (eingabe);
+ print (PROC (TEXT VAR) lese zeile, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listings erlaubt CAND is elan source (eingabe),
+ headline (eingabe) );
+
+END PROC print;
+
+PROC lese zeile (TEXT VAR zeile) : getline (eingabe, zeile) END PROC lese zeile;
+
+BOOL PROC eof : eof (eingabe) END PROC eof;
+
+BOOL PROC is elan source (FILE VAR eingabe) :
+
+hole erstes symbol;
+elan programm tag COR elan programm bold COR kommentar
+
+. elan programm tag :
+ symbol type = tag type CAND pos (zeile, ";") > 0
+
+. elan programm bold :
+ symbol type = bold type CAND is elan bold
+
+ . is elan bold :
+ symbol = "PACKET" COR symbol = "LET"
+ COR proc oder op (symbol) COR deklaration
+ COR proc oder op (naechstes symbol)
+
+ . deklaration :
+ next symbol (naechstes symbol);
+ naechstes symbol = "VAR" OR naechstes symbol = "CONST"
+
+. kommentar :
+ pos (zeile, "(*") > 0 OR pos (zeile, "{") > 0
+
+.
+ hole erstes symbol :
+ hole erstes nicht blankes symbol;
+ scan (zeile);
+ next symbol (symbol, symbol type);
+
+ . hole erstes nicht blankes symbol :
+ IF eof (eingabe) THEN LEAVE is elan source WITH FALSE FI;
+ REP getline (eingabe, zeile);
+ UNTIL pos (zeile, ""33"",""254"", 1) > 0 OR eof (eingabe) PER;
+ reset (eingabe);
+
+END PROC is elan source;
+
+(****************************************************************)
+
+bottom label for elan listings ("");
+
+PROC bottom label for elan listings (TEXT CONST label) :
+ bottom label := label;
+END PROC bottom label for elan listings;
+
+TEXT PROC bottom label for elan listings : bottom label END PROC bottom label for elan listings;
+
+
+PROC print (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name) :
+
+disable stop;
+gedruckte seiten := 0;
+drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ elan listing, file name );
+IF is error THEN behandle fehlermeldung FI;
+
+. behandle fehlermeldung :
+ par1 := error message;
+ int param := error line;
+ clear error;
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ clear error;
+ close (document, 0);
+ clear error;
+ FI;
+ initialisierung;
+ errorstop (par1 (* + " -> " + text (int param) *) );
+
+END PROC print;
+
+INT PROC x pos : d xpos END PROC x pos;
+INT PROC y pos : d ypos END PROC y pos;
+INT PROC y offset index : d token. offset index END PROC y offset index;
+INT PROC linetype : underline linetype END PROC linetype;
+TEXT PROC material : material wert END PROC material;
+INT PROC pages printed : gedruckte seiten END PROC pages printed;
+
+(****************************************************************)
+
+PROC drucke datei (PROC (TEXT VAR) next line, BOOL PROC eof,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute,
+ BOOL CONST elan listing, TEXT CONST file name ) :
+
+
+enable stop;
+IF elan listing
+ THEN dateiname := file name;
+ drucke elan listing;
+ ELSE drucke text datei;
+FI;
+
+.
+ drucke text datei :
+ initialisiere druck;
+ WHILE NOT eof
+ REP next line (zeile);
+ analysiere zeile;
+ drucke token soweit wie moeglich;
+ werte anweisungsspeicher aus;
+ PER;
+ schliesse druck ab;
+
+.
+ initialisiere druck :
+ IF NOT initialized (in dieser task)
+ THEN ds := nilspace;
+ initialisierung
+ FI;
+ vor erster seite := TRUE;
+ tabellen modus := FALSE;
+ block modus := FALSE;
+ zeile ist absatzzeile := TRUE;
+ x wanted := x step conversion (std x wanted);
+ y wanted := y step conversion (std y wanted);
+ limit := x step conversion (std limit);
+ pagelength := y step conversion (std pagelength);
+ linefeed faktor := std linefeed faktor;
+ material wert := std material;
+ indentation := 0;
+ modifikations modus := maxint;
+ seitenlaenge := maxint;
+ papierlaenge := maxint;
+ left margin := 0;
+ top margin := 0;
+ a ypos := top margin;
+ a font := -1;
+ a modifikationen := 0;
+ aktuelle spalte := 1;
+ anzahl spalten := 1;
+ stelle neuen font ein (1);
+ loesche tabellenspeicher;
+ loesche markierung;
+ loesche alte markierung;
+ loesche durchschuss;
+
+.
+ schliesse druck ab :
+ IF NOT vor erster seite
+ THEN IF seite ist offen
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute )
+ FI;
+ close (document, 0);
+ FI;
+
+.
+ drucke token soweit wie moeglich :
+ IF analysespeicher ist nicht leer
+ THEN letztes token bei gleicher ypos;
+ IF NOT seite ist offen
+ THEN eroeffne seite (x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ FI;
+ gehe zur letzten neuen ypos;
+ IF seitenlaenge ueberschritten OR papierlaenge ueberschritten
+ THEN neue seite oder spalte;
+ analysiere zeile nochmal;
+ ELSE sortiere neue token ein;
+ IF in letzter spalte
+ THEN drucke tokenspeicher (a ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ FI;
+ FI;
+
+ . gehe zur letzten neuen ypos :
+ ypos index a := letzter ypos index a
+
+ . seitenlaenge ueberschritten :
+ ya. ypos > seitenlaenge
+
+ . papierlaenge ueberschritten :
+ ya. ypos > papierlaenge
+
+ . neue seite oder spalte :
+ IF in letzter spalte
+ THEN schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ eroeffne seite (x wanted, aktuelles y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open);
+ ELSE neue spalte;
+ FI;
+
+ . aktuelles y wanted :
+ IF seitenlaenge ueberschritten
+ THEN y wanted
+ ELSE 0
+ FI
+
+ . analysiere zeile nochmal :
+ setze auf alte werte zurueck;
+ loesche anweisungsspeicher;
+ analysiere zeile;
+ letztes token bei gleicher ypos;
+ sortiere neue token ein;
+
+ . setze auf alte werte zurueck :
+ zeile ist absatzzeile := letzte zeile war absatzzeile;
+ a modifikationen := letzte modifikationen;
+ stelle neuen font ein (letzter font);
+
+.
+ werte anweisungsspeicher aus :
+ INT VAR index;
+ FOR index FROM 1 UPTO anweisungszaehler
+ REP
+ SELECT anweisungs indizes ISUB index OF
+ CASE a block : block anweisung
+ CASE a columns : columns anweisung
+ CASE a columnsend : columnsend anweisung
+ CASE a free : free anweisung
+ CASE a limit : limit anweisung
+ CASE a linefeed : linefeed anweisung
+ CASE a material : material anweisung
+ CASE a page0, a page1 : page anweisung
+ CASE a pagelength : pagelength anweisung
+ CASE a start : start anweisung
+ CASE a table : table anweisung
+ CASE a tableend : tableend anweisung
+ CASE a clearpos0 : clearpos0 anweisung
+ CASE a clearpos1 : clearpos1 anweisung
+ CASE a lpos, a rpos, a cpos, a dpos
+ : lpos rpos cpos dpos anweisung
+ CASE a bpos : bpos anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a textbegin0 : textbegin0 anweisung
+ CASE a textbegin2 : textbegin2 anweisung
+ CASE a textend : textend anweisung
+ CASE a indentation : indentation anweisung
+ CASE a y tab : y tab anweisung
+ END SELECT
+ PER;
+ loesche anweisungsspeicher;
+
+ . block anweisung :
+ blockmodus := TRUE;
+
+ . columns anweisung :
+ IF anzahl spalten = 1 AND int conversion ok (param1)
+ AND real conversion ok (param2)
+ THEN anzahl spalten := max (1, int param);
+ luecke := x step conversion (real param);
+ FI;
+
+ . columnsend anweisung :
+ anzahl spalten := 1;
+ aktuelle spalte := 1;
+ left margin := x wanted - x start + indentation;
+
+ . free anweisung :
+ IF real conversion ok (param1) THEN a ypos INCR y step conversion (real param) FI;
+
+ . limit anweisung :
+ IF real conversion ok (param1) THEN limit := x step conversion (real param) FI;
+
+ . linefeed anweisung :
+ IF real conversion ok (param1)
+ THEN linefeed faktor := real param;
+ letzte zeilenhoehe := neue zeilenhoehe;
+ FI;
+
+ . material anweisung :
+ material wert := param1;
+
+ . page anweisung :
+ IF seite ist offen
+ THEN IF NOT in letzter spalte
+ THEN neue spalte
+ ELSE schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ papier laenge := maxint;
+ FI;
+ ELSE a ypos := top margin;
+ papier laenge := maxint;
+ FI;
+
+ . pagelength anweisung :
+ IF real conversion ok (param1)
+ THEN pagelength := y step conversion (real param);
+ FI;
+
+ . start anweisung :
+ IF real conversion ok (param1) THEN x wanted := x step conversion (real param) FI;
+ IF real conversion ok (param2) THEN y wanted := y step conversion (real param) FI;
+
+ . table anweisung :
+ tabellenmodus := TRUE;
+
+ . tableend anweisung :
+ tabellenmodus := FALSE;
+
+ . clearpos0 anweisung :
+ loesche tabellenspeicher;
+
+ . clearpos1 anweisung :
+ IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = int param
+ THEN tab typ := leer;
+ delete int (tab liste, tab index);
+ LEAVE clearpos1 anweisung;
+ FI;
+ PER;
+ FI;
+
+ . lpos rpos cpos dpos anweisung :
+ IF real conversion ok (param1)
+ THEN neuer tab eintrag (anweisungs indizes ISUB index, param2) FI;
+
+ . bpos anweisung :
+ IF real conversion ok (param2) CAND real conversion ok (param1)
+ CAND real (param2) > real param
+ THEN neuer tab eintrag (a bpos, param2) FI;
+
+ . fillchar anweisung :
+ fill char := param1;
+
+ . textbegin0 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+
+ . textbegin2 anweisung :
+ aktuelle einrueckbreite := alte einrueckbreite;
+ mark index l := alter mark index l;
+ mark index r := alter mark index r;
+ loesche alte markierung;
+ neuer durchschuss (int (param1), y step conversion (real (param 2)));
+
+ . textend anweisung :
+ alte einrueckbreite := aktuelle einrueckbreite;
+ alter mark index l := mark index l;
+ alter mark index r := mark index r;
+ loesche markierung;
+ loesche durchschuss;
+
+ . indentation anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := x step conversion (real param);
+ left margin INCR (int param - indentation);
+ indentation := int param;
+ FI;
+ *)
+ . y tab anweisung :
+(* IF real conversion ok (param1)
+ THEN int param := y step conversion (real param);
+ IF int param <= seitenlaenge THEN a ypos := int param FI;
+ FI;
+ *)
+ . param1 :
+ IF (params1 zeiger ISUB index) <> 0
+ THEN name (params1, params1 zeiger ISUB index)
+ ELSE ""
+ FI
+
+ . param2 :
+ IF (params2 zeiger ISUB index) <> 0
+ THEN name (params2, params2 zeiger ISUB index)
+ ELSE ""
+ FI
+
+
+.
+ drucke elan listing :
+ initialisiere elan listing;
+ WHILE NOT eof
+ REP next line (zeile);
+ zeilen nr INCR 1;
+ drucke elan zeile;
+ PER;
+ schliesse elan listing ab;
+
+.
+ initialisiere elan listing :
+ open document cmd;
+ hole elan list font;
+ initialisiere variablen;
+ elan fuss und kopf (1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . open document cmd :
+ material wert := "";
+ d token. offset index := 1;
+ erster ypos index d := 0;
+ vor erster seite := FALSE;
+ seite ist offen := FALSE;
+ open (document, x size, y size);
+ vor erster seite := TRUE;
+
+ . hole elan list font :
+ d font := max (1, font ("elanlist"));
+ get replacements (d font, replacements, replacement tabelle);
+ einrueckbreite := indentation pitch (d font) ;
+ font hoehe := font lead (d font) + font height (d font) + font depth (d font);
+
+ . initialisiere variablen :
+ innerhalb der define liste := FALSE;
+ vor erstem packet := TRUE;
+ zeilen nr := 0;
+ y wanted := y size DIV 23;
+ pagelength := y size - y wanted - y wanted;
+ x wanted := (min (x size DIV 10, x step conversion (2.54))
+ DIV einrueckbreite) * einrueckbreite;
+ max zeichen zeile := (x size - x wanted - (x wanted DIV 3)) DIV einrueckbreite;
+ max zeichen fuss := fusszeilenbreite;
+ layout laenge := min (38, max zeichen zeile DIV 3);
+ layout laenge name := layout laenge - zeilen nr laenge - 8;
+ layout blanks := (layout laenge - zeilen nr laenge - 1) * " ";
+ refinement layout zeile := (layout laenge - 1) * " " ;
+ refinement layout zeile CAT "|" ;
+ IF pagelength DIV fonthoehe - 6 < 35 OR max zeichen zeile < 65
+ THEN errorstop ("Schreibfeld fuer 'elan listing' zu klein") FI;
+
+ . fusszeilenbreite :
+ INT CONST dina 4 breite := x step conversion (21.0);
+ IF x size <= dina 4 breite
+ THEN (x size - 2 * x wanted) DIV einrueckbreite
+ ELIF 120 * einrueckbreite <= dina 4 breite - 2 * x wanted
+ THEN (dina 4 breite - 2 * x wanted) DIV einrueckbreite
+ ELSE min (120, (x size - 2 * x wanted) DIV einrueckbreite)
+ FI
+
+.
+ schliesse elan listing ab :
+ elan fuss und kopf (-1,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ close (document, 0);
+
+.
+ drucke elan zeile :
+ IF pos (zeile, "#page#") = 1
+ THEN IF nicht am seiten anfang THEN seiten wechsel FI;
+ ELSE bestimme elan layout;
+ bestimme elan zeile;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ seitenwechsel wenn noetig;
+ FI;
+
+ . nicht am seitenanfang :
+ rest auf seite < pagelength - 3 * font hoehe
+
+ . seiten wechsel :
+ elan fuss und kopf (0,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+.
+ bestimme elan layout :
+ IF pos (zeile, "P") = 0 AND pos (zeile, ":") = 0
+ THEN leeres layout
+ ELSE analysiere elan zeile
+ FI;
+ elan text CAT "|";
+
+ . leeres layout :
+ elan text := text (zeilen nr, zeilen nr laenge);
+ elan text CAT layout blanks;
+
+ . analysiere elan zeile :
+ scan (zeile);
+ next symbol (symbol, symbol type);
+ next symbol (naechstes symbol, naechster symbol type) ;
+ IF packet anfang THEN packet layout
+ ELIF innerhalb der define liste THEN leeres layout; pruefe ende der define liste
+ ELIF proc op anfang THEN proc op layout
+ ELIF refinement anfang THEN refinement layout
+ ELSE leeres layout
+ FI;
+
+ . packet anfang :
+ symbol = "PACKET"
+
+ . proc op anfang :
+ IF proc oder op (symbol)
+ THEN naechster symbol type <> delimiter type
+ ELIF (symbol <> "END") AND proc oder op (naechstes symbol)
+ THEN symbol := naechstes symbol;
+ next symbol (naechstes symbol, naechster symbol type) ;
+ naechster symbol type <> delimiter type
+ ELSE FALSE
+ FI
+
+ . refinement anfang :
+ symbol type = tag type AND naechstes symbol = ":"
+ AND NOT innerhalb der define liste
+
+ . packet layout :
+ IF nicht am seiten anfang AND
+ (NOT vor erstem packet OR gedruckte seiten > 1)
+ THEN seiten wechsel FI;
+ layout (" ", naechstes symbol, "*") ;
+ vor erstem packet := FALSE ;
+ innerhalb der define liste := TRUE;
+ pruefe ende der define liste;
+
+ . pruefe ende der define liste :
+ IF pos (zeile, ":") <> 0
+ THEN scan (zeile);
+ WHILE innerhalb der define liste
+ REP next symbol (symbol);
+ IF symbol = ":" THEN innerhalb der define liste := FALSE FI;
+ UNTIL symbol = "" PER;
+ FI;
+
+ . proc op layout :
+ IF keine vier zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", naechstes symbol, ".");
+
+ . keine vier zeilen mehr :
+ rest auf seite <= 8 * font hoehe
+
+ . refinement layout :
+ IF keine drei zeilen mehr
+ THEN seiten wechsel
+ ELIF nicht am seitenanfang
+ THEN elan text := refinement layout zeile;
+ gib elan text aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI ;
+ layout (" ", symbol, " ");
+
+ . keine drei zeilen mehr :
+ rest auf seite <= 7 * font hoehe
+
+.
+ bestimme elan zeile :
+ IF zeile ist nicht zu lang
+ THEN elan text CAT zeile;
+ ELSE drucke zeile in teilen
+ FI;
+
+ . zeile ist nicht zu lang :
+ zeilen laenge := LENGTH zeile;
+ zeilen laenge <= rest auf zeile
+
+ . rest auf zeile :
+ max zeichen zeile - LENGTH elan text
+
+ . drucke zeile in teilen :
+ zeilen pos := 1;
+ bestimme einrueckung;
+ WHILE zeile noch nicht ganz gedruckt REP teil layout PER;
+
+ . bestimme einrueckung :
+ anzahl einrueck blanks := naechstes nicht blankes zeichen - 1;
+ IF anzahl einrueck blanks > rest auf zeile - 20
+ THEN anzahl einrueck blanks := 0 FI;
+
+ . zeile noch nicht ganz gedruckt :
+ bestimme zeilenteil;
+ NOT zeile ist zu ende
+
+ . bestimme zeilenteil :
+ bestimme laenge;
+ zeilen teil := subtext (zeile, zeilen pos, zeilen pos + laenge - 1);
+ elan text CAT zeilen teil;
+ zeilen pos INCR laenge;
+
+ . zeilen teil : par1
+
+ . bestimme laenge :
+ INT VAR laenge := zeilen laenge - zeilen pos + 1;
+ IF laenge > rest auf zeile
+ THEN laenge := rest auf zeile;
+ WHILE (zeile SUB (zeilen pos + laenge - 1)) <> " "
+ REP laenge DECR 1 UNTIL laenge = 0 PER;
+ IF laenge = 0 THEN laenge := rest auf zeile FI;
+ FI;
+
+ . teil layout :
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ elan text := (zeilen nr laenge - 1) * " ";
+ elan text CAT "+";
+ elan text CAT layout blanks;
+ elan text CAT "|";
+ elan text cat blanks (anzahl einrueck blanks + teil einrueckung);
+
+.
+ seiten wechsel wenn noetig :
+ IF keine zeilen mehr AND NOT eof THEN seiten wechsel FI;
+
+ . keine zeilen mehr :
+ rest auf seite <= 4 * font hoehe
+
+END PROC drucke datei;
+
+
+BOOL PROC real conversion ok (TEXT CONST param) :
+ real param := real (param);
+ last conversion ok AND real param >= 0.0
+END PROC real conversion ok;
+
+
+BOOL PROC int conversion ok (TEXT CONST param) :
+ int param := int (param);
+ last conversion ok AND int param >= 0
+END PROC int conversion ok;
+
+
+PROC neuer tab eintrag (INT CONST typ, TEXT CONST param) :
+
+ suche neuen eintrag;
+ sortiere neue tab position ein;
+ tab typ := typ;
+ tab position := neue tab position;
+ tab param := eventueller parameter;
+
+ . suche neuen eintrag :
+ INT VAR index := 0;
+ REP index INCR 1;
+ IF tab speicher (index). tab typ = leer
+ THEN LEAVE suche neuen eintrag FI;
+ UNTIL index = max tabs PER;
+ LEAVE neuer tab eintrag;
+
+ . sortiere neue tab position ein :
+ INT VAR neue tab position := x step conversion (real param);
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP IF tab position = neue tab position
+ THEN LEAVE neuer tab eintrag
+ ELIF tab position > neue tab position
+ THEN insert int (tab liste, tab index, index);
+ LEAVE sortiere neue tab position ein;
+ FI;
+ PER;
+ tab liste CAT index;
+ tab index := anzahl tabs;
+
+ . eventueller parameter :
+ INT VAR link;
+ SELECT typ OF
+ CASE a dpos : insert (d strings, param, link); link
+ CASE a bpos : x step conversion (real(param))
+ OTHERWISE : 0
+ END SELECT
+
+END PROC neuer tab eintrag;
+
+
+PROC neue spalte :
+ a ypos := top margin;
+ left margin INCR (limit + luecke);
+ aktuelle spalte INCR 1;
+END PROC neue spalte ;
+
+
+BOOL PROC proc oder op (TEXT CONST symbol) :
+
+ symbol = "PROC" OR symbol = "PROCEDURE"
+ OR symbol = "OP" OR symbol = "OPERATOR"
+
+ENDPROC proc oder op ;
+
+
+PROC layout (TEXT CONST pre, TEXT VAR name, TEXT CONST post) :
+
+name := subtext (name, 1, layout laenge name) ;
+elan text := text (zeilen nr, zeilen nr laenge);
+elan text CAT pre;
+elan text CAT name;
+elan text CAT " ";
+generiere strukturiertes layout;
+
+. generiere strukturiertes layout :
+ INT VAR index;
+ FOR index FROM 1 UPTO layout laenge - LENGTH elan text - 1
+ REP elan text CAT post PER;
+
+ENDPROC layout ;
+
+
+PROC elan text cat blanks (INT CONST anzahl) :
+
+ par2 := anzahl * " ";
+ elan text CAT par2;
+
+END PROC elan text cat blanks;
+
+
+(***********************************************************************)
+
+PROC analysiere zeile :
+
+loesche analysespeicher;
+behandle fuehrende blanks;
+pruefe ob anweisungszeile;
+pruefe ob markierung links;
+
+IF tabellen modus
+ THEN analysiere tabellenzeile
+ELIF letzte zeile war absatzzeile
+ THEN analysiere zeile nach absatzzeile
+ ELSE analysiere zeile nach blockzeile
+FI;
+
+pruefe center und right modus;
+pruefe ob tabulation vorliegt;
+werte indexspeicher aus;
+berechne zeilenhoehe;
+pruefe ob markierung rechts;
+
+.
+ analysiere zeile nach absatzzeile :
+ test auf aufzaehlung;
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach absatzzeile
+ ELSE analysiere absatzzeile nach absatzzeile
+ FI;
+.
+ analysiere zeile nach blockzeile :
+ IF zeile muss geblockt werden
+ THEN analysiere blockzeile nach blockzeile
+ ELSE analysiere absatzzeile nach blockzeile
+ FI;
+
+
+.
+ behandle fuehrende blanks :
+ zeilenpos := 1;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN behandle leerzeile;
+ LEAVE analysiere zeile;
+ ELSE letzte zeile war absatzzeile := zeile ist absatzzeile;
+ IF letzte zeile war absatzzeile THEN neue einrueckung FI;
+ initialisiere analyse;
+ FI;
+
+ . behandle leerzeile :
+ a ypos INCR (letzte zeilenhoehe + durchschuss);
+ zeile ist absatzzeile := LENGTH zeile > 0;
+ pruefe ob markierung links;
+ pruefe ob markierung rechts;
+
+ . neue einrueckung :
+ aktuelle einrueckbreite := einrueckbreite;
+
+ . initialisiere analyse :
+ zeile ist absatzzeile := (zeile SUB LENGTH zeile) = blank;
+ zeile muss geblockt werden := block modus AND NOT zeile ist absatzzeile;
+ erstes token der zeile := token index f + 1;
+ groesste fonthoehe := fonthoehe;
+ aktuelle zeilenhoehe := letzte zeilenhoehe;
+ zeilen laenge := laenge der zeile;
+ anzahl einrueck blanks := zeilen pos - 1;
+ anzahl zeichen := anzahl einrueck blanks;
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := 0;
+ letzter font := a font;
+ letzte modifikationen := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+
+ . laenge der zeile :
+ IF zeile ist absatzzeile
+ THEN LENGTH zeile - 1
+ ELSE LENGTH zeile
+ FI
+.
+ pruefe ob anweisungszeile :
+ IF erstes zeichen ist anweisungszeichen
+ THEN REP analysiere anweisung;
+ IF zeile ist zu ende THEN LEAVE analysiere zeile FI;
+ UNTIL zeichen ist kein anweisungs zeichen PER;
+ FI;
+
+ . erstes zeichen ist anweisungszeichen :
+ pos (zeile, anweisungszeichen, 1, 1) <> 0
+
+ . zeichen ist kein anweisungszeichen :
+ pos (zeile, anweisungszeichen, zeilen pos, zeilen pos) = 0
+
+.
+ pruefe ob markierung links :
+ IF markierung links
+ THEN mark token (mark index l). xpos :=
+ left margin - mark token (mark index l). breite;
+ lege markierungs token an (mark index l);
+ erstes token der zeile := token index f + 1;
+ initialisiere tab variablen;
+ FI;
+
+.
+ analysiere tabellenzeile :
+ anfangs blankmodus := doppel blank;
+ alte zeilenpos := zeilen pos;
+ a xpos := 0;
+ FOR tab index FROM 1 UPTO anzahl tabs
+ REP lege fuell token an wenn noetig;
+ initialisiere tab variablen;
+ SELECT tab typ OF
+ CASE a lpos : linksbuendige spalte
+ CASE a rpos : rechtsbuendige spalte
+ CASE a cpos : zentrierte spalte
+ CASE a dpos : dezimale spalte
+ CASE a bpos : geblockte spalte
+ END SELECT;
+ berechne fuell token wenn noetig;
+ tabulation;
+ PER;
+ analysiere rest der zeile;
+
+ . lege fuell token an wenn noetig :
+ IF fill char <> blank
+ THEN fuellzeichen := fill char;
+ fuellzeichen breite := string breite (fuellzeichen);
+ token zeiger := zeilen pos;
+ erstes fuell token := token index f + 1;
+ lege text token an;
+ letztes fuell token := token index f;
+ a modifikationen fuer x move := a modifikationen
+ FI;
+
+ . berechne fuell token wenn noetig :
+ IF erstes fuell token <> leer
+ THEN IF letztes fuell token <> token index f
+ THEN berechne fuell token;
+ ELSE loesche letzte token;
+ FI;
+ erstes fuell token := leer
+ FI;
+
+ . berechne fuell token :
+ INT VAR anzahl fuellzeichen, fuell breite;
+ token index := erstes fuell token;
+ anzahl fuellzeichen := (tab anfang - t. xpos + left margin)
+ DIV fuellzeichen breite;
+ rest := (tab anfang - t. xpos + left margin)
+ MOD fuellzeichen breite;
+ IF anzahl fuell zeichen > 0
+ THEN fuell text := anzahl fuellzeichen * fuellzeichen;
+ fuell breite := anzahl fuellzeichen * fuellzeichen breite;
+ FOR token index FROM erstes fuell token UPTO letztes fuell token
+ REP t. text := fuell text;
+ t. breite := fuell breite;
+ IF erstes fuell token <> erstes token der zeile
+ THEN t. xpos INCR rest DIV 2;
+ t. modifikationen fuer x move := t. modifikationen;
+ FI;
+ PER;
+ FI;
+
+ . fuell text : par1
+
+ . loesche letzte token :
+ FOR token index FROM letztes fuell token DOWNTO erstes fuell token
+ REP loesche letztes token PER;
+
+ . tabulation :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilenlaenge + 1;
+ LEAVE analysiere tabellenzeile;
+ FI;
+ anzahl zeichen INCR zeilenpos - alte zeilenpos;
+
+ . linksbuendige spalte :
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ bestimme token bis terminator oder zeilenende;
+
+ . rechtsbuendige spalte :
+ bestimme token bis terminator oder zeilenende;
+ schreibe zeile rechtsbuendig (tab position);
+
+ . zentrierte spalte :
+ bestimme token bis terminator oder zeilenende;
+ zentriere zeile (tab position);
+
+ . dezimale spalte :
+ d string := name (d strings, tab param);
+ d code 1 := code (d string SUB 1) + 1;
+ d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ bestimme token bis terminator oder zeilenende;
+ zeichenbreiten (d code 1) := d pitch;
+ d code 1 := leer;
+ schreibe zeile rechtsbuendig (tab position);
+ IF zeichen ist dezimal zeichen
+ THEN IF tab position <> zeilen breite
+ THEN a xpos := left margin + tab position;
+ tab anfang := tab position;
+ FI;
+ bestimme token bis terminator oder zeilenende
+ FI;
+
+ . zeichen ist dezimal zeichen :
+ pos (zeile, d string, zeilen pos) = zeilen pos
+
+ . geblockte spalte :
+ blankmodus := einfach blank;
+ a xpos := left margin + tab position;
+ tab anfang := tab position;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende OR naechstes zeichen ist blank
+ THEN blocke spalte wenn noetig;
+ LEAVE geblockte spalte;
+ ELSE dehnbares blank gefunden;
+ FI;
+ PER;
+
+ . blocke spalte wenn noetig :
+ IF letztes zeichen ist kein geschuetztes blank
+ THEN blocke zeile (tab param) FI;
+ blank modus := doppel blank;
+
+ . letztes zeichen ist kein geschuetztes blank :
+ pos (zeile, geschuetztes blank, zeilen pos - 1, zeilen pos - 1) = 0
+ AND NOT within kanji (zeile, zeilen pos - 2)
+
+ . analysiere rest der zeile :
+ blankmodus := keine blankanalyse;
+ zeilen pos := alte zeilenpos;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ test auf aufzaehlung :
+ anfangs blankmodus := einfach blank;
+ bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere zeile nach absatzzeile
+ ELSE aufzaehlung moeglich
+ FI;
+
+ . aufzaehlung moeglich :
+ bestimme letztes zeichen;
+ IF (anzahl zeichen bei aufzaehlung < 2 AND letztes zeichen = "-")
+ OR (anzahl zeichen bei aufzaehlung < 20 AND letztes zeichen = ":")
+ OR (anzahl zeichen bei aufzaehlung < 7
+ AND pos (".)", letztes zeichen) <> 0)
+ OR naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELIF zeile muss geblockt werden
+ THEN dehnbares blank gefunden;
+ FI;
+
+ . bestimme letztes zeichen :
+ token index := token index f;
+ WHILE token index >= erstes token der zeile
+ REP IF token ist text token
+ THEN letztes zeichen := t. text SUB LENGTH t. text;
+ LEAVE bestimme letztes zeichen;
+ FI;
+ token index DECR 1;
+ PER;
+ letztes zeichen := "";
+
+ . letztes zeichen : par1
+
+ . anzahl zeichen bei aufzaehlung :
+ anzahl zeichen - anzahl einrueck blanks
+
+ . token ist text token :
+ t. offset index >= text token
+.
+ analysiere blockzeile nach absatzzeile :
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach absatzzeile
+ ELSE analysiere blank in blockzeile nach absatzzeile
+ FI;
+ PER;
+
+ . analysiere blank in blockzeile nach absatzzeile :
+ IF naechstes zeichen ist blank
+ THEN tabulator position gefunden;
+ ELSE dehnbares blank gefunden;
+ FI;
+
+.
+ analysiere absatzzeile nach absatzzeile :
+ blankmodus := doppel blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN LEAVE analysiere absatzzeile nach absatzzeile
+ ELSE tabulator position gefunden
+ FI;
+ PER;
+
+.
+ analysiere blockzeile nach blockzeile :
+ anfangs blankmodus := einfach blank;
+ REP bestimme token bis terminator oder zeilenende;
+ IF zeile ist zu ende
+ THEN blocke zeile (limit);
+ LEAVE analysiere blockzeile nach blockzeile
+ ELSE dehnbares blank gefunden
+ FI;
+ PER;
+
+.
+ analysiere absatzzeile nach blockzeile :
+ anfangs blankmodus := keine blankanalyse;
+ bestimme token bis terminator oder zeilenende;
+
+.
+ dehnbares blank gefunden :
+ anzahl zeichen INCR 1;
+ zeilenpos INCR 1;
+ a xpos INCR blankbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF NOT a block token
+ THEN anzahl blanks INCR 1;
+ a block token := TRUE;
+ FI;
+.
+ tabulator position gefunden :
+ alte zeilenpos := zeilenpos;
+ zeilenpos := naechstes nicht blankes zeichen;
+ IF zeilenpos = 0
+ THEN zeilenpos := zeilen laenge + 1;
+ ELSE IF erstes token der zeile > token index f
+ THEN token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+ anzahl zeichen INCR (zeilenpos - alte zeilenpos);
+ a xpos := left margin + anzahl zeichen * aktuelle einrueckbreite;
+ a modifikationen fuer x move := a modifikationen;
+ IF zeile muss geblockt werden THEN initialisiere tab variablen FI;
+ FI;
+
+.
+ pruefe center und right modus :
+ IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ IF right modus THEN schreibe zeile rechtsbuendig (limit) FI;
+.
+ pruefe ob tabulation vorliegt:
+ IF analyse speicher ist nicht leer CAND a xpos > tf. xpos + tf. breite
+ THEN a modifikationen fuer x move := a modifikationen;
+ token zeiger := zeilen pos;
+ lege text token an;
+ FI;
+.
+ werte indexspeicher aus :
+ INT VAR index;
+ IF index zaehler > 0
+ THEN FOR index FROM index zaehler DOWNTO 1
+ REP a ypos DECR (verschiebungen ISUB index) PER;
+ stelle neuen font ein (grosse fonts ISUB 1);
+ loesche index speicher;
+ FI;
+.
+ berechne zeilenhoehe :
+ verschiebung := aktuelle zeilenhoehe + durchschuss;
+ a ypos INCR verschiebung;
+ verschiebe token ypos (verschiebung);
+
+.
+ pruefe ob markierung rechts :
+ IF markierung rechts
+ THEN mark token (mark index r). xpos := left margin + limit;
+ lege markierungs token an (mark index r);
+ FI;
+
+END PROC analysiere zeile;
+
+
+PROC blocke zeile (INT CONST rechter rand) :
+
+rest := rechter rand - zeilen breite;
+IF rest > 0 AND anzahl blanks > 0
+ THEN INT CONST schmaler schritt := rest DIV anzahl blanks,
+ breiter schritt := schmaler schritt + 1,
+ anzahl breite schritte := rest MOD anzahl blanks;
+ IF rechts
+ THEN blocke token xpos (breiter schritt, schmaler schritt,
+ anzahl breite schritte);
+ rechts := FALSE;
+ ELSE blocke token xpos (schmaler schritt, breiter schritt,
+ anzahl blanks - anzahl breite schritte);
+ rechts := TRUE;
+ FI;
+ a xpos INCR ( breiter schritt * anzahl breite schritte +
+ schmaler schritt * (anzahl blanks - anzahl breite schritte) );
+FI;
+
+END PROC blocke zeile;
+
+
+PROC zentriere zeile (INT CONST zentrier pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := zentrier pos - tab anfang -
+ (zeilen breite - tab anfang) DIV 2;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+center modus := FALSE;
+
+END PROC zentriere zeile;
+
+
+PROC schreibe zeile rechtsbuendig (INT CONST rechte pos) :
+
+IF erstes tab token <= token index f
+ THEN verschiebung := rechte pos - zeilen breite;
+ verschiebe token xpos (verschiebung);
+ a xpos INCR verschiebung;
+ tab anfang INCR verschiebung;
+FI;
+right modus := FALSE;
+
+
+END PROC schreibe zeile rechtsbuendig;
+
+
+PROC bestimme token bis terminator oder zeilenende :
+
+token zeiger := zeilen pos;
+REP stranalyze (zeichenbreiten, a breite, max breite,
+ zeile, zeilen pos, zeilen laenge,
+ ausgang);
+ zeilen pos INCR 1;
+ IF ausgang = blank ausgang
+ THEN analysiere blank
+ ELIF ausgang = anweisungs ausgang
+ THEN anweisung gefunden
+ ELIF ausgang = d code ausgang
+ THEN analysiere d string
+ ELIF ausgang = erweiterungs ausgang
+ THEN erweiterung gefunden
+ ELSE terminator oder zeilenende gefunden
+ FI;
+PER;
+
+. analysiere blank :
+ IF blankmodus = einfach blank OR
+ (blankmodus = doppel blank AND naechstes zeichen ist blank)
+ THEN terminator oder zeilenende gefunden
+ ELSE a breite INCR blankbreite;
+ zeilenpos INCR 1;
+ FI;
+
+. analysiere d string :
+ IF pos (zeile, d string, zeilen pos) = zeilen pos
+ THEN terminator oder zeilenende gefunden
+ ELSE IF d pitch = maxint
+ THEN erweiterung gefunden
+ ELIF d pitch < 0
+ THEN a breite INCR (d pitch XOR - maxint - 1);
+ zeilen pos INCR 2;
+ ELSE a breite INCR d pitch;
+ zeilenpos INCR 1;
+ FI;
+ FI;
+
+. erweiterung gefunden :
+ a breite INCR extended char pitch (a font, zeile SUB zeilen pos,
+ zeile SUB zeilen pos + 1);
+ zeilen pos INCR 2;
+
+. anweisung gefunden :
+ gegebenfalls neues token gefunden;
+ analysiere anweisung;
+ IF zeile ist zu ende
+ THEN LEAVE bestimme token bis terminator oder zeilenende FI;
+ token zeiger := zeilenpos;
+
+. terminator oder zeilenende gefunden :
+ IF ausgang = null ausgang THEN zeilen laenge DECR 1 FI;
+ gegebenfalls neues token gefunden;
+ LEAVE bestimme token bis terminator oder zeilenende;
+
+ . gegebenfalls neues token gefunden :
+ IF token zeiger < zeilenpos THEN lege text token an FI;
+
+END PROC bestimme token bis terminator oder zeilen ende;
+
+
+PROC analysiere anweisung :
+
+ bestimme anweisung;
+ IF anweisung ist kommando
+ THEN lege kommando token an;
+ ELSE werte anweisung aus;
+ FI;
+
+ . anweisungsanfang : token zeiger
+
+ . anweisungsende : zeilen pos - 2
+
+ . erstes zeichen : par1
+
+. bestimme anweisung :
+ anweisungsanfang := zeilenpos + 1;
+ zeilen pos := pos (zeile, anweisungszeichen, anweisungsanfang, zeilenlaenge);
+ IF zeilenpos = 0
+ THEN zeilenpos := anweisungsanfang - 1;
+ replace (zeile, zeilenpos, geschuetztes anweisungszeichen);
+ LEAVE analysiere anweisung;
+ FI;
+ zeilen pos INCR 1;
+ anweisung := subtext (zeile, anweisungsanfang, anweisungsende);
+ erstes zeichen := anweisung SUB 1;
+
+. anweisung ist kommando :
+ IF erstes zeichen = quote
+ THEN scan (anweisung);
+ next symbol (anweisung, symbol type);
+ next symbol (par2, naechster symbol type);
+ IF symbol type <> text type OR naechster symbol type <> eof type
+ THEN LEAVE analysiere anweisung FI;
+ TRUE
+ ELIF erstes zeichen = druckerkommando zeichen
+ THEN delete char (anweisung, 1);
+ TRUE
+ ELSE FALSE
+ FI
+
+.
+ werte anweisung aus :
+ analyze command (anweisungs liste, anweisung, number type,
+ anweisungs index, anzahl params, par1, par2);
+ SELECT anweisungs index OF
+ CASE a type : type anweisung
+ CASE a on : on anweisung
+ CASE a off : off anweisung
+ CASE a ub, a fb : ub fb anweisung
+ CASE a ue, a fe : ue fe anweisung
+ CASE a center : center anweisung
+ CASE a right : right anweisung
+ CASE a up, a down : index anweisung
+ CASE a end up or down : end index anweisung
+ CASE a bsp : bsp anweisung
+ CASE a fillchar : fillchar anweisung
+ CASE a mark : mark anweisung
+ CASE a markend : markend anweisung
+ OTHERWISE : IF anweisungs index > 0 THEN speichere anweisung FI;
+ END SELECT;
+
+ . type anweisung :
+ change all (par1, " ", "");
+ stelle neuen font ein (font (par1));
+ groesste fonthoehe := max (groesste fonthoehe, fonthoehe);
+ a modifikationen := 0;
+ IF nicht innerhalb eines indexes THEN berechne aktuelle zeilenhoehe FI;
+
+ . nicht innerhalb eines indexes :
+ index zaehler = 0
+
+ . berechne aktuelle zeilenhoehe :
+ IF linefeed faktor >= 1.0
+ THEN aktuelle zeilenhoehe := max (groesste fonthoehe,
+ letzte zeilenhoehe);
+ ELSE aktuelle zeilenhoehe := max (aktuelle zeilenhoehe,
+ letzte zeilenhoehe);
+ FI;
+
+ . on anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN set bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . off anweisung :
+ par1 := par1 SUB 1;
+ IF pos (modifikations liste, par1) > 0
+ THEN reset bit (a modifikationen, pos (modifikations liste, par1) - 1 );
+ FI;
+
+ . ub fb anweisung :
+ IF anweisungs index = a ub
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ on anweisung;
+
+ . ue fe anweisung :
+ IF anweisungs index = a ue
+ THEN par1 := "u"
+ ELSE par1 := "b"
+ FI;
+ off anweisung;
+
+ . center anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ AND NOT right modus
+ THEN center modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . right anweisung :
+ IF NOT zeile muss geblockt werden AND NOT tabellen modus
+ THEN IF center modus THEN zentriere zeile (limit DIV 2) FI;
+ right modus := TRUE;
+ blankmodus := keine blankanalyse;
+ initialisiere tab variablen;
+ FI;
+
+ . index anweisung :
+ INT CONST grosser font := a font, grosse fonthoehe := fonthoehe;
+ INT VAR kleiner font;
+ IF next smaller font exists (grosser font, kleiner font)
+ THEN stelle neuen font ein (kleiner font) FI;
+ IF font hoehe < grosse fonthoehe
+ THEN berechne verschiebung fuer kleinen font
+ ELSE berechne verschiebung fuer grossen font
+ FI;
+ a ypos INCR verschiebung;
+ merke grossen font und verschiebung;
+
+ . berechne verschiebung fuer kleinen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 15 PROZENT grosse fonthoehe;
+ ELSE verschiebung := - ( 9 PROZENT grosse fonthoehe )
+ - (grosse fonthoehe - fonthoehe);
+ FI;
+
+ . berechne verschiebung fuer grossen font :
+ IF anweisungs index = a down
+ THEN verschiebung := 25 PROZENT fonthoehe;
+ ELSE verschiebung := - (50 PROZENT fonthoehe);
+ FI;
+
+ . merke grossen font und verschiebung :
+ index zaehler INCR 1;
+ grosse fonts CAT grosser font;
+ verschiebungen CAT verschiebung;
+ IF index zaehler = 1
+ THEN alter blankmodus := blankmodus;
+ blankmodus := keine blankanalyse;
+ FI;
+
+ . end index anweisung :
+ IF index zaehler > 0
+ THEN schalte auf groesseren font zurueck;
+ FI;
+
+ . schalte auf groesseren font zurueck :
+ a ypos DECR (verschiebungen ISUB index zaehler);
+ stelle neuen font ein (grosse fonts ISUB index zaehler);
+ IF index zaehler = 1
+ THEN blankmodus := alter blankmodus;
+ FI;
+ index zaehler DECR 1;
+ verschiebungen := subtext (verschiebungen, 1, 2 * index zaehler);
+ grosse fonts := subtext (grosse fonts, 1, 2 * index zaehler);
+
+ . bsp anweisung :
+ INT VAR breite davor, breite dahinter;
+ IF anweisungs anfang - 2 >= 1 AND anweisungs ende + 2 <= zeilen laenge
+ THEN IF is kanji esc (zeile SUB anweisungs anfang - 3)
+ THEN zeichen davor := subtext (zeile, anweisungs anfang - 3,
+ anweisungs anfang - 2);
+ ELSE zeichen davor := zeile SUB anweisungs anfang - 2;
+ FI;
+ IF is kanji esc (zeile SUB anweisungs ende + 2)
+ THEN zeichen dahinter := subtext (zeile, anweisungs ende + 2,
+ anweisungs ende + 3 );
+ ELSE zeichen dahinter := zeile SUB anweisungs ende + 2;
+ FI;
+ IF pos (" #", zeichen davor) = 0 AND pos (" #", zeichen dahinter) = 0
+ THEN breite davor := char pitch (a font, zeichen davor);
+ breite dahinter := char pitch (a font, zeichen dahinter);
+ IF breite davor < breite dahinter THEN vertausche zeichen FI;
+ lege token fuer zeichen dahinter an;
+ a xpos INCR (breite davor - breite dahinter) DIV 2;
+ FI;
+ FI;
+
+ . zeichen davor : par1
+ . zeichen dahinter : par2
+
+ . vertausche zeichen :
+ change (zeile, anweisungs anfang - 2 - LENGTH zeichen davor + 1,
+ anweisungs anfang - 2, zeichen dahinter);
+ change (zeile, anweisungs ende + 2,
+ anweisungs ende + 2 + LENGTH zeichen dahinter - 1, zeichen davor);
+ change (tf. text, LENGTH tf. text - LENGTH zeichen davor + 1,
+ LENGTH tf. text, zeichen dahinter);
+ tf. breite INCR (breite dahinter - breite davor);
+ a xpos INCR (breite dahinter - breite davor);
+ int param := breite davor;
+ breite davor := breite dahinter;
+ breite dahinter := int param;
+
+ . lege token fuer zeichen dahinter an :
+ token zeiger := zeilen pos;
+ a breite := breite dahinter;
+ zeilen pos INCR LENGTH zeichen dahinter;
+ a xpos DECR (breite davor + breite dahinter) DIV 2;
+ lege text token an;
+ anzahl zeichen DECR 1;
+
+ . fillchar anweisung :
+ IF par1 = "" THEN par1 := " " FI;
+ fill char := par1;
+ speichere anweisung;
+
+ . mark anweisung :
+ IF par1 <> ""
+ THEN mark index l := (alter mark index l MOD 2) + 1;
+ neue markierung (par1, mark index l);
+ ELSE mark index l := 0;
+ FI;
+ IF par2 <> ""
+ THEN mark index r := (alter mark index r MOD 2) + 3;
+ neue markierung (par2, mark index r);
+ ELSE mark index r := 0;
+ FI;
+
+ . markend anweisung :
+ loesche markierung;
+
+ . speichere anweisung :
+ anweisungs zaehler INCR 1;
+ anweisungs indizes CAT anweisungs index;
+ IF par1 <> ""
+ THEN insert (params1, par1);
+ params1 zeiger CAT highest entry (params1);
+ ELSE params1 zeiger CAT 0;
+ FI;
+ IF par2 <> ""
+ THEN insert (params2, par2);
+ params2 zeiger CAT highest entry (params2);
+ ELSE params2 zeiger CAT 0;
+ FI;
+
+END PROC analysiere anweisung;
+
+
+PROC stelle neuen font ein (INT CONST font nr ) :
+
+ IF font nr <> a font THEN neuer font FI;
+
+ . neuer font :
+ a font := max (1, font nr);
+ get font (a font, einrueckbreite, font durchschuss, font hoehe, font tiefe,
+ zeichenbreiten);
+ font hoehe INCR (font durchschuss + font tiefe);
+ letzte zeilenhoehe := neue zeilenhoehe;
+ blankbreite := zeichenbreiten (blank code 1);
+ zeichenbreiten (blank code 1) := blank ausgang;
+ zeichenbreiten (anweisungs zeichen code 1) := anweisungs ausgang;
+ font offsets := y offsets (a font);
+ offsets := LENGTH font offsets > 2;
+ IF d code 1 <> leer
+ THEN d pitch := zeichenbreiten (d code 1);
+ zeichenbreiten (d code 1) := d code ausgang;
+ FI;
+
+END PROC stelle neuen font ein;
+
+
+INT OP PROZENT (INT CONST prozent, wert) :
+
+ (wert * prozent + 99) DIV 100
+
+END OP PROZENT;
+
+
+PROC neue markierung (TEXT CONST text, INT CONST mark index) :
+
+ mark token (mark index). text := text;
+ mark token (mark index). breite := string breite (text);
+ mark token (mark index). font := a font;
+ mark token (mark index). modifikationen := a modifikationen;
+
+END PROC neue markierung;
+
+
+INT PROC string breite (TEXT CONST string) :
+
+ INT VAR summe := 0, pos := 1;
+ REP stranalyze (zeichenbreiten, summe, max breite, string, pos, maxint, ausgang);
+ IF ausgang = erweiterungs ausgang
+ THEN summe INCR extended char pitch (a font,
+ string SUB pos+1, string SUB pos+2);
+ pos INCR 3;
+ ELIF ausgang = blank ausgang
+ THEN summe INCR blankbreite;
+ pos INCR 2;
+ ELIF ausgang = anweisungs ausgang
+ THEN summe INCR char pitch (a font, anweisungszeichen);
+ pos INCR 2;
+ ELSE LEAVE string breite WITH summe
+ FI;
+ PER;
+ 0
+
+END PROC string breite;
+
+(*******************************************************************)
+
+PROC lege text token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage text token (tf);
+ IF offsets THEN lege offsets an (font offsets) FI;
+ stranalyze (zeichen zaehler, anzahl zeichen, max int,
+ zeile, token zeiger, zeilen pos - 1, ausgang);
+ a xpos INCR a breite;
+ a breite := 0;
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege text token an;
+
+
+PROC uebertrage text token (TOKEN VAR tf) :
+
+ tf. text := subtext (zeile, token zeiger, zeilenpos - 1);
+ tf. xpos := a xpos;
+ tf. breite := a breite;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := text token;
+ tf. block token := a block token;
+
+END PROC uebertrage text token;
+
+
+PROC lege kommando token an :
+
+ aktuelle ypos := a ypos + (font offsets ISUB 1);
+ neuer token index;
+ uebertrage kommando token (tf);
+ a modifikationen fuer x move := 0;
+ a block token := FALSE;
+
+END PROC lege kommando token an;
+
+
+PROC uebertrage kommando token (TOKEN VAR tf) :
+
+ tf. text := anweisung;
+ tf. breite := 0;
+ tf. xpos := a xpos;
+ tf. font := a font;
+ tf. modifikationen := a modifikationen;
+ tf. modifikationen fuer x move := a modifikationen fuer x move;
+ tf. offset index := kommando token;
+ tf. block token := a block token;
+
+END PROC uebertrage kommando token;
+
+
+PROC lege markierungs token an (INT CONST mark index) :
+
+ aktuelle ypos := a ypos + (mark font offsets ISUB 1);
+ neuer token index;
+ tf := mark token (mark index);
+ IF mark offsets THEN lege offsets an (mark font offsets) FI;
+
+ . mark font offsets : y offsets (mark token (mark index). font)
+
+ . mark offsets : LENGTH mark font offsets > 2
+
+END PROC lege markierungs token an;
+
+
+PROC lege offsets an (TEXT CONST offsets) :
+
+ INT CONST anzahl offsets := LENGTH offsets DIV 2;
+ offset token := tf;
+ offset token. block token := FALSE;
+ reset bit (offset token. modifikationen, underline bit);
+ FOR index FROM 2 UPTO anzahl offsets
+ REP aktuelle ypos := a ypos + (offsets ISUB index);
+ neuer token index;
+ tf := offset token;
+ tf. offset index := index;
+ PER;
+
+END PROC lege offsets an;
+
+
+PROC neuer token index :
+
+IF erster ypos index a = 0
+ THEN erste ypos
+ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei gleicher ypos
+ ELSE fuege neue ypos ein
+FI;
+
+ . erste ypos :
+ ypos index f INCR 1;
+ erster ypos index a := ypos index f;
+ letzter ypos index a := ypos index f;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := 0;
+ erstes token bei neuer ypos;
+
+ . fuege neue ypos ein :
+ letztes token bei gleicher ypos;
+ IF ya. ypos > aktuelle ypos
+ THEN richtige ypos ist oberhalb
+ ELSE richtige ypos ist unterhalb
+ FI;
+
+ . richtige ypos ist oberhalb :
+ REP ypos index a := ya. vorheriger ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos vor erstem ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist oberhalb;
+ ELIF ya. ypos < aktuelle ypos
+ THEN fuege ypos nach ypos index ein;
+ LEAVE richtige ypos ist oberhalb;
+ FI;
+ PER;
+
+ . richtige ypos ist unterhalb :
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN fuege ypos nach letztem ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos = aktuelle ypos
+ THEN neues token bei neuer ypos;
+ LEAVE richtige ypos ist unterhalb;
+ ELIF ya. ypos > aktuelle ypos
+ THEN fuege ypos vor ypos index ein;
+ LEAVE richtige ypos ist unterhalb;
+ FI;
+ PER;
+
+ . fuege ypos vor erstem ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := 0;
+ yf. naechster ypos index := erster ypos index a;
+ erster ypos index a := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach ypos index ein :
+ ypos index f INCR 1;
+ yf. vorheriger ypos index := ypos index a;
+ yf. naechster ypos index := ya. naechster ypos index;
+ ya. naechster ypos index := ypos index f;
+ ypos index a := yf. naechster ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos vor ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := ypos index a;
+ yf. vorheriger ypos index := ya. vorheriger ypos index;
+ ya. vorheriger ypos index := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+ . fuege ypos nach letztem ypos index ein :
+ ypos index f INCR 1;
+ yf. naechster ypos index := 0;
+ yf. vorheriger ypos index := letzter ypos index a;
+ letzter ypos index a := ypos index f;
+ ypos index a := yf. vorheriger ypos index;
+ ya. naechster ypos index := ypos index f;
+ erstes token bei neuer ypos;
+
+END PROC neuer token index;
+
+
+PROC erstes token bei neuer ypos :
+ token index f INCR 1;
+ ypos index a := ypos index f;
+ ya. erster token index := token index f;
+ ya. ypos := aktuelle ypos;
+END PROC erstes token bei neuer ypos;
+
+
+PROC neues token bei neuer ypos :
+ token index f INCR 1;
+ ya. ypos := aktuelle ypos;
+ token index := ya. letzter token index;
+ t. naechster token index := token index f;
+END PROC neues token bei neuer ypos;
+
+
+PROC neues token bei gleicher ypos :
+ tf. naechster token index := token index f + 1;
+ token index f INCR 1;
+END PROC neues token bei gleicher ypos;
+
+
+PROC letztes token bei gleicher ypos :
+ tf. naechster token index := 0;
+ ya. letzter token index := token index f;
+END PROC letztes token bei gleicher ypos;
+
+
+PROC loesche letztes token :
+
+ IF token index f = ya. erster token index
+ THEN loesche ypos
+ ELSE token index f DECR 1;
+ FI;
+
+ . loesche ypos :
+ kette vorgaenger um;
+ kette nachfolger um;
+ bestimme letzten ypos index;
+
+ . kette vorgaenger um :
+ ypos index := ya. vorheriger ypos index;
+ IF ypos index = 0
+ THEN erster ypos index a := ya. naechster ypos index;
+ ELSE y. naechster ypos index := ya. naechster ypos index;
+ FI;
+
+ . kette nachfolger um :
+ ypos index := ya. naechster ypos index;
+ IF ypos index = 0
+ THEN letzter ypos index a := ya. vorheriger ypos index;
+ ELSE y. vorheriger ypos index := ya. vorheriger ypos index;
+ FI;
+
+ . bestimme letzten ypos index :
+ IF ypos index a = ypos index f THEN ypos index f DECR 1 FI;
+ token index f DECR 1;
+ ypos index a := letzter ypos index a;
+ WHILE ypos index a <> 0
+ CAND ya. letzter token index <> token index f
+ REP ypos index a := ya. vorheriger ypos index PER;
+
+END PROC loesche letztes token;
+
+
+PROC blocke token xpos (INT CONST dehnung 1, dehnung 2,
+ anzahl dehnungen fuer dehnung 1 ) :
+
+ INT VAR dehnung := 0, anzahl dehnungen := 0;
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP erhoehe token xpos bei block token;
+ t. xpos INCR dehnung;
+ token index INCR 1;
+ PER;
+
+ . erhoehe token xpos bei block token :
+ IF t. block token
+ THEN IF anzahl dehnungen < anzahl dehnungen fuer dehnung 1
+ THEN anzahl dehnungen INCR 1;
+ dehnung INCR dehnung 1;
+ ELSE dehnung INCR dehnung 2;
+ FI;
+ FI;
+
+END PROC blocke token xpos;
+
+
+PROC verschiebe token xpos (INT CONST verschiebung) :
+
+ token index := erstes tab token;
+ WHILE token index <= token index f
+ REP t. xpos INCR verschiebung;
+ token index INCR 1;
+ PER;
+
+END PROC verschiebe token xpos;
+
+
+PROC verschiebe token ypos (INT CONST verschiebung) :
+
+ ypos index := erster ypos index a;
+ WHILE ypos index <> 0
+ REP y. ypos INCR verschiebung;
+ ypos index := y. naechster ypos index;
+ PER;
+
+END PROC verschiebe token ypos;
+
+
+PROC sortiere neue token ein :
+
+IF analysespeicher ist nicht leer
+ THEN IF druckspeicher ist nicht leer
+ THEN sortiere neue token in sortierte liste ein
+ ELSE sortierte liste ist leer
+ FI;
+FI;
+
+. sortierte liste ist leer :
+ IF erster ypos index a <> 0
+ THEN erster ypos index d := erster ypos index a;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ FI;
+
+. sortiere neue token in sortierte liste ein :
+ gehe zum ersten neuen token;
+ bestimme erste einsortierposition;
+ WHILE es gibt noch neue token
+ REP IF ypos index d = 0
+ THEN haenge neue token ans ende der sortierten liste
+ ELIF ya. ypos > yd. ypos
+ THEN naechste ypos der sortierten liste
+ ELIF ya. ypos = yd. ypos
+ THEN neues token auf gleicher ypos
+ ELSE neue token vor ypos
+ FI;
+ PER;
+
+ . gehe zum ersten neuen token :
+ ypos index a := erster ypos index a;
+
+ . bestimme erste einsortierposition :
+ WHILE ypos index d <> 0 CAND ya. ypos < yd. ypos
+ REP ypos index d := yd. vorheriger ypos index PER;
+ IF ypos index d = 0 THEN erste neue token vor listen anfang FI;
+
+ . erste neue token vor listen anfang :
+ ypos index d := erster ypos index d;
+ erster ypos index d := erster ypos index a;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE erste neue token vor listen anfang
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE erste neue token vor listen anfang
+ FI;
+ PER;
+
+ . es gibt noch neue token :
+ ypos index a <> 0
+
+ . haenge neue token ans ende der sortierten liste :
+ ypos index d := letzter ypos index d;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ letzter ypos index d := letzter ypos index a;
+ ypos index d := letzter ypos index a;
+ ypos index a := 0;
+
+ . naechste ypos der sortierten liste :
+ ypos index d := yd. naechster ypos index;
+
+ . neues token auf gleicher ypos :
+ token index := yd. letzter token index;
+ t . naechster token index := ya. erster token index;
+ yd. letzter token index := ya. letzter token index;
+ ypos index a := ya. naechster ypos index;
+ ypos index d := yd. naechster ypos index;
+ IF ypos index d = 0 THEN ypos index d := letzter ypos index d FI;
+
+ . neue token vor ypos :
+ verkette ya mit vorherigem yd;
+ REP ypos index a := ya. naechster ypos index;
+ IF ypos index a = 0
+ THEN verkette letztes ya mit yd;
+ LEAVE sortiere neue token in sortierte liste ein
+ ELIF ya. ypos = yd. ypos
+ THEN verkette ya mit yd;
+ LEAVE neue token vor ypos
+ ELIF ya. ypos > yd. ypos
+ THEN verkette vorheriges ya mit yd;
+ ypos index d := yd. naechster ypos index;
+ LEAVE neue token vor ypos
+ FI;
+ PER;
+
+
+. verkette ya mit vorherigem yd :
+ index := ypos index d;
+ ypos index d := yd. vorheriger ypos index;
+ yd. naechster ypos index := ypos index a;
+ ya. vorheriger ypos index := ypos index d;
+ ypos index d := index;
+
+. verkette letztes ya mit yd :
+ ypos index a := letzter ypos index a;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := 0;
+
+. verkette vorheriges ya mit yd :
+ index := ypos index a;
+ ypos index a := ya. vorheriger ypos index;
+ yd. vorheriger ypos index := ypos index a;
+ ya. naechster ypos index := ypos index d;
+ ypos index a := index;
+
+. verkette ya mit yd :
+ verkette vorheriges ya mit yd;
+ neues token auf gleicher ypos;
+
+END PROC sortiere neue token ein;
+
+(***************************************************************)
+
+PROC drucke tokenspeicher
+ (INT CONST max ypos,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF druckspeicher ist nicht leer
+ THEN gehe zur ersten ypos;
+ WHILE yd. ypos <= max ypos
+ REP drucke token bei ypos;
+ gehe zur naechsten ypos;
+ PER;
+ loesche gedruckte token;
+FI;
+
+. gehe zur ersten ypos :
+ ypos index d := erster ypos index d;
+
+. drucke token bei ypos :
+ IF yd. ypos >= - y start
+ THEN druck durchgang;
+ IF bold pass THEN fett durchgang FI;
+ IF underline pass THEN unterstreich durchgang FI;
+ FI;
+
+ . bold pass : bit (pass, bold bit)
+
+ . underline pass : bit (pass, underline bit)
+
+. gehe zur naechsten ypos :
+ IF ypos index d = letzter ypos index d
+ THEN loesche druckspeicher;
+ LEAVE drucke tokenspeicher;
+ FI;
+ ypos index d := yd. naechster ypos index;
+
+. loesche gedruckte token :
+ erster ypos index d := ypos index d;
+ yd. vorheriger ypos index := 0;
+
+.
+ druck durchgang :
+ verschiebung := yd. ypos - d ypos;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ gehe zum ersten token dieser ypos;
+ REP drucke token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . drucke token :
+ IF NOT token passt in zeile THEN berechne token teil FI;
+ font wechsel wenn noetig;
+ x move mit modifikations ueberpruefung;
+ IF token ist text token
+ THEN gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ ELSE gib kommando token aus
+ FI;
+
+ . gib kommando token aus :
+ execute (write cmd, d token. text, 1, LENGTH d token. text)
+
+ . berechne token teil :
+ INT CONST fuenf punkte := 5 * char pitch (d token. font, punkt);
+ INT VAR token pos, token breite, anzahl punkte, zeichen laenge, zeichen breite;
+ IF d token. xpos < - x start
+ AND d token. xpos + d token. breite > - x start
+ THEN berechne token teil von links
+ ELIF d token. xpos < papierbreite
+ AND d token. xpos + d token. breite > papierbreite
+ THEN berechne token teil nach rechts
+ ELSE LEAVE drucke token
+ FI;
+
+ . berechne token teil von links :
+ rest := min (x size, d token. xpos + d token. breite + x start);
+ d token. xpos := - x start;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := LENGTH d token. text + 1;
+ token breite := fuenf punkte;
+ berechne token teil breite von hinten;
+ change (d token. text, 1, token pos - 1, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von hinten :
+ WHILE naechstes zeichen passt noch davor
+ REP token breite INCR zeichen breite;
+ token pos DECR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch davor :
+ IF within kanji (d token. text, token pos - 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos - zeichen laenge, token pos - 1));
+ token breite + zeichen breite < rest
+
+ . berechne token teil nach rechts :
+ rest := papier breite - d token. xpos;
+ IF rest <= fuenf punkte
+ THEN anzahl punkte := rest DIV char pitch (d token. font, punkt);
+ d token. text := anzahl punkte * punkt;
+ d token. breite := anzahl punkte * char pitch (d token. font, punkt);
+ ELSE token pos := 0;
+ token breite := fuenf punkte;
+ berechne token teil breite von vorne;
+ change (d token. text, token pos + 1, LENGTH d token. text, 5 * punkt);
+ d token. breite := token breite;
+ FI;
+
+ . berechne token teil breite von vorne :
+ WHILE naechstes zeichen passt noch dahinter
+ REP token breite INCR zeichen breite;
+ token pos INCR zeichen laenge;
+ PER;
+
+ . naechstes zeichen passt noch dahinter :
+ IF is kanji esc (d token. text SUB token pos + 1)
+ THEN zeichen laenge := 2
+ ELSE zeichen laenge := 1
+ FI;
+ zeichen breite := char pitch (d token. font,
+ subtext (d token. text, token pos + 1, token pos + zeichen laenge));
+ token breite + zeichen breite < rest
+
+.
+ fett durchgang :
+ reset bit (pass, bold bit);
+ gehe zum ersten token dieser ypos;
+ REP gib token nochmal aus UNTIL kein token mehr vorhanden PER;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+
+ . gib token nochmal aus :
+ INT CONST min verschiebung := bold offset (d token. font);
+ d token. xpos INCR min verschiebung;
+ IF bit (d token. modifikationen, bold bit) AND
+ token passt in zeile AND token ist text token
+ THEN verschiebung := d token. xpos - d xpos;
+ font wechsel wenn noetig;
+ schalte italics ein wenn noetig;
+ x move wenn noetig;
+ gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d token. xpos DECR min verschiebung;
+
+ . schalte italics ein wenn noetig :
+ IF bit (d token. modifikationen, italics bit)
+ THEN neue modifikationen := modifikations werte (italics bit + 1);
+ schalte modifikationen ein wenn noetig;
+ ELSE schalte modifikationen aus wenn noetig;
+ FI;
+
+.
+ unterstreich durchgang :
+ INT VAR l xpos := 0;
+ reset bit (pass, underline bit);
+ schalte modifikationen aus wenn noetig;
+ gehe zum ersten token dieser ypos;
+ REP unterstreiche token UNTIL kein token mehr vorhanden PER;
+ gib cr aus;
+
+ . unterstreiche token :
+ IF token muss unterstrichen werden AND
+ token passt in zeile AND token ist text token
+ THEN font wechsel wenn noetig;
+ berechne x move laenge;
+ x move wenn noetig;
+ berechne unterstreich laenge;
+ unterstreiche;
+ FI;
+ l xpos := d token. xpos + d token. breite;
+
+ . token muss unterstrichen werden :
+ bit (d token. modifikationen, underline bit) OR
+ bit (d token. modifikationen fuer x move, underline bit)
+
+ . berechne x move laenge :
+ IF bit (d token. modifikationen fuer x move, underline bit)
+ THEN verschiebung := l xpos - d xpos
+ ELSE verschiebung := d token. xpos - d xpos
+ FI;
+
+ . berechne unterstreich laenge :
+ INT VAR unterstreich verschiebung;
+ IF bit (d token. modifikationen, underline bit)
+ THEN unterstreich verschiebung := d token. xpos +
+ d token. breite - d xpos
+ ELSE unterstreich verschiebung := d token. xpos - d xpos
+ FI;
+
+
+. gehe zum ersten token dieser ypos :
+ token index := yd. erster token index;
+ d token := t;
+
+. kein token mehr vorhanden :
+ token index := d token. naechster token index;
+ IF token index = 0
+ THEN TRUE
+ ELSE d token := t;
+ FALSE
+ FI
+
+. token ist text token :
+ d token. offset index >= text token
+
+. token passt in zeile :
+ d token. xpos >= - x start AND
+ d token. xpos + d token. breite <= papier breite
+
+. font wechsel wenn noetig :
+ IF d token. font <> d font
+ THEN font wechsel (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. schalte modifikationen aus wenn noetig :
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. x move wenn noetig :
+ IF verschiebung <> 0
+ THEN x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) FI;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+.
+ x move mit modifikations ueberpruefung :
+ verschiebung := d token. xpos - d xpos;
+ IF verschiebung <> 0
+ THEN neue modifikationen := d token. modifikationen fuer x move;
+ schalte modifikationen ein wenn noetig;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ neue modifikationen := d token. modifikationen;
+ schalte modifikationen ein wenn noetig;
+
+.
+ unterstreiche :
+ IF unterstreich verschiebung > 0
+ THEN disable stop;
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN unterstreiche nach cr;
+ FI;
+ enable stop;
+ FI;
+
+ . unterstreiche nach cr :
+ clear error;
+ d xpos DECR unterstreich verschiebung;
+ verschiebung := d xpos;
+ gib cr aus;
+ x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ d xpos INCR unterstreich verschiebung;
+ execute (draw, "", unterstreich verschiebung, 0);
+ IF is error
+ THEN clear error;
+ d xpos DECR unterstreich verschiebung;
+ gib cr aus;
+ LEAVE unterstreich durchgang;
+ FI;
+
+END PROC drucke tokenspeicher;
+
+PROC y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ IF verschiebung <> 0
+ THEN disable stop;
+ d ypos INCR verschiebung;
+ execute (move, "", 0, verschiebung);
+ IF is error
+ THEN clear error;
+ d ypos DECR verschiebung;
+ verschiebung := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC y move;
+
+
+PROC x move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d xpos INCR verschiebung;
+ execute (move, "", verschiebung, 0);
+ IF is error
+ THEN fuehre x move nach cr aus
+ FI;
+
+ . fuehre x move nach cr aus :
+ clear error;
+ schalte modifikationen aus wenn noetig;
+ gib cr aus;
+ IF d xpos <> 0
+ THEN execute (move, "", d xpos, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI
+ FI;
+ schalte modifikationen ein wenn noetig;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos - verschiebung, 0);
+
+ . schalte modifikationen aus wenn noetig :
+ neue modifikationen := d modifikationen;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . schalte modifikationen ein wenn noetig :
+ IF d modifikationen <> neue modifikationen
+ THEN schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+END PROC x move;
+
+
+PROC schalte modifikationen ein
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ IF d modifikationen <> 0
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ d modifikationen := neue modifikationen;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss eingeschaltet werden
+ FI;
+ PER;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss eingeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (on, "", modifikations werte (index), 0);
+ IF is error
+ THEN clear error;
+ reset bit (modifikations modus, modifikations bit);
+ set bit (pass, modifikations bit);
+ FI;
+ ELSE set bit (pass, modifikations bit);
+ FI;
+
+END PROC schalte modifikationen ein;
+
+
+PROC schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ INT VAR index;
+ FOR index FROM 1 UPTO anzahl modifikationen
+ REP IF bit (d modifikationen, modifikations bit)
+ THEN modifikation muss ausgeschaltet werden
+ FI;
+ PER;
+ d modifikationen := 0;
+
+ . modifikations bit : index - 1
+
+ . modifikation muss ausgeschaltet werden :
+ IF bit (modifikations modus, modifikations bit)
+ THEN execute (off, "", modifikations werte (index), 0);
+ IF is error THEN clear error FI;
+ FI;
+
+END PROC schalte modifikationen aus;
+
+
+PROC font wechsel
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ disable stop;
+ d font := d token. font;
+ get replacements (d font, replacements, replacement tabelle);
+ execute (type, "", d font, 0);
+ IF is error THEN font wechsel nach cr FI;
+ enable stop;
+
+ . font wechsel nach cr :
+ clear error;
+ verschiebung := d xpos;
+ gib cr aus;
+ execute (type, "", d font, 0);
+ IF NOT is error
+ THEN schalte modifikationen aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ x move
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+
+ . gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+END PROC font wechsel;
+
+
+PROC gib text token aus
+ (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+ INT CONST token laenge := LENGTH d token. text;
+ INT VAR token pos := 1, alte token pos, summe := 0;
+ IF token laenge > 0
+ THEN REP alte token pos := token pos;
+ stranalyze (replacement tabelle, summe, 0,
+ d token. text, token pos, token laenge,
+ ausgang);
+ IF ausgang = 0
+ THEN gib token rest aus;
+ ELSE gib token teil aus;
+ gib ersatzdarstellung aus;
+ FI;
+ PER;
+ FI;
+
+ . gib token rest aus :
+ IF token laenge >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token laenge) FI;
+ d xpos INCR d token. breite;
+ LEAVE gib text token aus;
+
+ . gib token teil aus :
+ IF token pos >= alte token pos
+ THEN execute (write text, d token. text, alte token pos, token pos) FI;
+
+ . gib ersatzdarstellung aus :
+ IF ausgang = maxint
+ THEN ersatzdarstellung := extended replacement (d token. font,
+ d token. text SUB token pos + 1, d token. text SUB token pos + 2);
+ execute (write text, ersatzdarstellung, 1, LENGTH ersatzdarstellung);
+ tokenpos INCR 3;
+ ELSE IF ausgang < 0
+ THEN ausgang := ausgang XOR (-32767-1);
+ token pos INCR 1;
+ FI;
+ execute (write text, replacements, ausgang + 1, ausgang + code (replacements SUB ausgang));
+ token pos INCR 2;
+ FI;
+
+ . ersatzdarstellung : par1
+
+END PROC gib text token aus;
+
+
+PROC schliesse seite ab (PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+enable stop;
+gebe restliche token aus;
+seiten ende kommando;
+
+. gebe restliche token aus :
+ IF erster ypos index d <> 0
+ THEN drucke tokenspeicher (maxint,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ FI;
+ rest := papier laenge - d ypos;
+
+. seiten ende kommando :
+ seite ist offen := FALSE;
+ a ypos := top margin;
+ aktuelle spalte := 1;
+ close (page, rest);
+
+END PROC schliesse seite ab;
+
+
+PROC eroeffne seite (INT CONST x wanted, y wanted,
+ PROC (INT CONST, INT VAR, INT VAR) open ) :
+
+IF vor erster seite THEN eroeffne druck FI;
+seiten anfang kommando;
+initialisiere neue seite;
+
+. eroeffne druck :
+ open (document, x size, y size);
+ vor erster seite := FALSE;
+ d font := -1;
+ d modifikationen := 0;
+
+. seiten anfang kommando :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+
+. initialisiere neue seite :
+ INT CONST dif left margin := x wanted - x start - left margin + indentation,
+ dif top margin := y wanted - y start - top margin;
+ IF dif left margin <> 0
+ THEN erstes tab token := 1;
+ verschiebe token xpos (dif left margin);
+ a xpos INCR dif left margin;
+ left margin INCR dif left margin;
+ FI;
+ IF dif top margin <> 0
+ THEN verschiebe token ypos (dif top margin);
+ a ypos INCR dif top margin;
+ top margin INCR dif top margin;
+ FI;
+ d xpos := 0;
+ d ypos := 0;
+ IF seitenlaenge <= papierlaenge
+ THEN seitenlaenge := top margin + pagelength;
+ ELSE seitenlaenge DECR papierlaenge;
+ FI;
+ papierlaenge := y size - y start;
+ papierbreite := x size - x start;
+
+END PROC eroeffne seite;
+
+(****************************************************************)
+
+PROC elan fuss und kopf (INT CONST fuss oder kopf,
+ PROC (INT CONST, INT CONST) close,
+ PROC (INT CONST, INT VAR, INT VAR) open,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+IF fuss oder kopf <= 0 THEN elan fuss FI;
+IF fuss oder kopf >= 0 THEN elan kopf FI;
+
+.
+ elan fuss :
+ y move zur fusszeile;
+ drucke elan fuss;
+ close page cmd;
+
+. y move zur fusszeile :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+ verschiebung := rest auf seite - font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. drucke elan fuss :
+ IF bottom label = ""
+ THEN seiten nr := ""
+ ELSE seiten nr := bottom label;
+ seiten nr CAT "/";
+ FI;
+ seiten nr CAT text (gedruckte seiten);
+ elan text := seiten nr;
+ elan text CAT " ";
+ elan text cat blanks ((max zeichen fuss - LENGTH dateiname) DIV 2 - LENGTH elan text);
+ elan text CAT dateiname;
+ elan text cat blanks (max zeichen fuss - LENGTH seiten nr - LENGTH elan text - 3);
+ elan text CAT " ";
+ elan text CAT seiten nr;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ . seiten nr : par1
+
+. close page cmd :
+ close (page, papierlaenge - d ypos);
+ seite ist offen := FALSE;
+
+.
+ elan kopf :
+ open page cmd ;
+ y move zur kopfzeile;
+ drucke elan kopf;
+
+. open page cmd :
+ x start := x wanted;
+ y start := y wanted;
+ open (page, x start, y start);
+ IF fuss oder kopf = 1 THEN execute (type, "", d font, 0) FI;
+ gedruckte seiten INCR 1;
+ seite ist offen := TRUE;
+ top margin := y wanted - y start;
+ left margin := x wanted - x start;
+ rest auf seite := pagelength;
+ papierlaenge := y size - y start;
+ d ypos := 0;
+ d xpos := 0;
+
+. y move zur kopf zeile :
+ verschiebung := top margin;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ IF verschiebung = 0 THEN rest auf seite INCR top margin FI;
+
+. drucke elan kopf :
+ elan text := headline pre;
+ elan text CAT date;
+ elan text CAT headline post;
+ elan text CAT datei name;
+ IF LENGTH elan text > max zeichen zeile
+ THEN elan text := subtext (elan text, 1, max zeichen zeile) FI;
+ gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+ cr plus lf (2, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+ENDPROC elan fuss und kopf;
+
+
+PROC gib elan text aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+cr plus lf (1, PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+linker rand wenn noetig;
+d token. breite := LENGTH elan text * einrueckbreite;
+gib text token aus (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+. linker rand wenn noetig :
+ IF left margin > 0
+ THEN disable stop;
+ d xpos := left margin;
+ execute (move, "", left margin, 0);
+ IF is error
+ THEN clear error;
+ d xpos := 0;
+ FI;
+ enable stop;
+ FI;
+
+END PROC gib elan text aus;
+
+
+PROC cr plus lf (INT CONST anzahl,
+ PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute) :
+
+gib cr aus;
+gib lf aus;
+rest auf seite DECR verschiebung;
+
+. gib cr aus :
+ execute (carriage return, "", d xpos, 0);
+ d xpos := 0;
+
+. gib lf aus :
+ verschiebung := anzahl * font hoehe;
+ y move (PROC (INT CONST, TEXT CONST, INT CONST, INT CONST) execute);
+
+END PROC cr plus lf ;
+
+
+END PACKET eumel printer;
|