diff options
Diffstat (limited to 'system/multiuser/1.7.5/src/eumel printer')
| -rw-r--r-- | system/multiuser/1.7.5/src/eumel printer | 3066 |
1 files changed, 3066 insertions, 0 deletions
diff --git a/system/multiuser/1.7.5/src/eumel printer b/system/multiuser/1.7.5/src/eumel printer new file mode 100644 index 0000000..94858b5 --- /dev/null +++ b/system/multiuser/1.7.5/src/eumel printer @@ -0,0 +1,3066 @@ +PACKET eumel printer (* Autor : Rudolf Ruland *) + (* Version : 4 *) + (* Stand : 05.05.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) 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, + 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 + + . deklaration : + next symbol (symbol); + symbol = "VAR" OR 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 > 0) + 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; + 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; + |