(* ------------------- VERSION 406 vom 28.05.86 ----(1.7.5)------------- *)
PACKET liner DEFINES line form,
autoform,
hyphenation width,
additional commands:
(* Programm zur Zeilenformatierung mit unterschiedlichen Schriftypen
Autor: Rainer Hahn
Stand: 1.7.1 Febr. 1984
1.7.3 Juli 1984
1.7.4 Juni 1985
1.7.5 ab Okt. 1985
*)
(********************* form deklarationen ********************)
TEXT VAR zeichen,
aufzaehlungszeichen,
par 1,
par 2,
kommando,
command store,
zielreferenzen,
herkunftsreferenzen,
aktuelle referenz,
alter schriftname,
dummy,
fehlerdummy,
footdummy,
scan symbol,
font table name :: "",
trennwort,
trennwort ohne komm,
wort1,
wort1 ohne komm,
wort2,
font nr speicher,
modifikations speicher,
mod zeilennr speicher,
index speicher,
ind zeilennr speicher,
counter numbering store,
counter reference store,
trennsymbol,
puffer,
neue zeile,
zeile,
einrueckung zweite zeile,
aktuelle blanks,
alte blanks,
zusaetzliche commands :: "",
kommando liste;
INT CONST rueckwaerts :: -1,
esc char ohne zweites byte ausgang :: - maxint - 1;
INT VAR anz tabs,
mitzuzaehlende zeichen,
anz blanks freihalten,
kommando index,
scan type,
font nr :: 1,
blankbreite fuer diesen schrifttyp,
aktuelle pitch zeilenlaenge,
eingestellte indentation pitch,
einrueckbreite,
zeilenbreite,
trennbreite in prozent :: 7,
trennbreite,
max trennlaenge,
max trenn laenge ohne komm,
zeichenwert ausgang,
formelbreite,
formelanfang,
zeilennr,
wortanfang,
wortende,
erste fehler zeilennr,
macro kommando ende,
von,
pufferlaenge,
zeichenpos,
zeichenpos bereits verarbeitet;
BOOL VAR ask type and limit,
format file in situ,
lineform mode,
macro works,
kommandos speichern,
letzter puffer war absatz,
in d und e verarbeitung,
in tabelle,
in foot uebertrag,
in foot;
LET hop = ""1"",
rechts = ""2"",
cl eol = ""5"",
links = ""8"",
return = ""13"",
begin mark = ""15"",
end mark = ""14"",
escape = ""27"",
trennzeichen = ""221"",
trenn k = ""220"",
blank = " ",
bindestrich = "-",
buchstaben =
"abcdefghijklmnopqrstuvwxyzüäößABCDEFGHIJKLMNOPQRSTUVWXYZÄÜö",
kommando zeichen = "#",
max tabs = 30,
extended char ausgang = 32767,
blank ausgang = 32766,
kommando ausgang = 32765,
such ausgang = 32764,
zeilenende ausgang = 0,
vorwaerts = 1,
type1 = 1,
linefeed = 3,
limit = 4,
free = 5,
page command0= 6,
page command1= 7,
on = 8,
off = 9,
page nr = 10,
pagelength = 11,
start = 12,
foot = 13,
end = 14,
head = 15,
headeven = 16,
headodd = 17,
bottom = 18,
bottomeven = 19,
bottomodd = 20,
block = 21,
material = 22,
columns = 23,
columnsend = 24,
ib0 = 25,
ib1 = 26,
ib2 = 27,
ie0 = 28,
ie1 = 29,
ie2 = 30,
topage = 31,
goalpage = 32,
count0 = 33,
count1 = 34,
setcount = 35,
value0 = 36,
value1 = 37,
table = 38,
table end = 39,
r pos = 40,
l pos = 41,
c pos = 42,
d pos = 43,
b pos = 44,
clear pos0 = 45,
clear pos1 = 46,
right = 47,
center = 48,
skip = 49,
skip end = 50,
u command = 51,
d command = 52,
e command = 53,
head on = 54,
head off = 55,
bottom on = 56,
bottom off = 57,
count per page=58,
fillchar = 59,
mark command = 60,
mark end = 61,
pageblock = 62,
bsp = 63,
counter1 = 64,
counter2 = 65,
setcounter = 66,
putcounter0 = 67,
putcounter1 = 68,
storecounter = 69,
ub = 70,
ue = 71,
fb = 72,
fe = 73;
REAL VAR limit in cm :: 16.0,
fehler wert :: -1.0;
FILE VAR eingabe,
ausgabe,
file;
FRANGE VAR alter bereich;
DATASPACE VAR ds;
ROW 256 INT VAR pitch table;
ROW max tabs TEXT VAR tab zeichen;
ROW max tabs ROW 3 INT VAR tabs;
(* 1. Eintrag: Position
2. Eintrag: Art
3. Eintrag: Bis-Position
*)
(************************** liner state-Routinen **********************)
TYPE LINERSTATE =
STRUCT (INT position, from,
BOOL in macro,
TEXT buffer line, next line,
old blanks, actual blanks,
new line);
LINERSTATE VAR before macro state,
before foot state;
PROC get liner state (LINERSTATE VAR l):
l . position := zeichenpos;
l . from := von;
l . in macro := macro works;
l . buffer line := puffer;
l . next line := zeile;
l . old blanks := alte blanks;
l . actualblanks:= aktuelle blanks;
l . new line := neue zeile;
END PROC get liner state;
PROC put liner state (LINERSTATE CONST l):
zeichenpos := l . position;
von := l . from;
macro works := l . in macro;
puffer := l . buffer line ;
zeile := l . next line ;
alte blanks := l . old blanks;
aktuelle blanks := l . actual blanks;
neue zeile := l . new line ;
pufferlaenge := length (puffer);
END PROC put liner state;
(*********************** Utility Routinen **************************)
PROC delete int (TEXT VAR resultat, INT CONST delete pos) :
change (resultat, delete pos * 2 - 1, delete pos * 2, "")
END PROC delete int;
OP CAT (TEXT VAR resultat, INT CONST zahl) :
resultat CAT " ";
replace (resultat, LENGTH resultat DIV 2, zahl);
END OP CAT;
PROC conversion (REAL VAR cm, INT VAR pitches):
disable stop;
INT VAR i :: x step conversion (cm);
IF is error
THEN dummy := error message;
clear error;
dummy CAT " -> ";
dummy CAT text (cm);
fehler (38, dummy);
cm := fehler wert
ELIF i < 0
THEN fehler (38, "negativ");
cm := fehler wert
ELSE pitches := i
FI;
enable stop
END PROC conversion;
(************************** Fehlermeldungen **********************)
PROC fehler (INT CONST nr, TEXT CONST addition):
fehler melden;
meldung auf terminal ausgeben und ggf zeilennummer merken.
fehler melden:
report text processing error (nr, zeilen nr, fehlerdummy, addition).
END PROC fehler;
PROC warnung (INT CONST nr, TEXT CONST addition):
warnung melden;
meldung auf terminal ausgeben und ggf zeilennummer merken.
warnung melden:
report text processing warning (nr, zeilennr, fehlerdummy, addition).
END PROC warnung;
PROC meldung auf terminal ausgeben und ggf zeilennummer merken:
IF online
THEN line ;
out (fehlerdummy);
line ;
FI;
IF erste fehler zeilennr = 0
THEN erste fehler zeilennr := zeilennr
FI
END PROC meldung auf terminal ausgeben und ggf zeilennummer merken;
(*********************** Macro-Bearbeitung ***********************)
PROC fuehre initialisierung fuer macro aus:
get liner state (before macro state);
get macro line (puffer);
pufferlaenge := length (puffer);
get macro line (zeile);
zeichenpos := 1;
von := 1;
macro works := TRUE.
END PROC fuehre initialisierung fuer macro aus;
PROC macro end command:
kommando := subtext (kommando, 2);
scan (kommando);
next symbol (scan symbol, scan type);
IF NOT macro works
THEN fehler (40, kommando);
LEAVE macro end command
ELIF scan symbol <> "macroend"
THEN fehler (33, kommando)
ELSE put liner state (before macro state);
FI
END PROC macro end command;
(************************** Schrifttyp einstellen *********************)
PROC stelle font ein:
IF alter schriftname = par1
THEN IF zeilen nr > 2
THEN warnung (8, par1)
ELSE LEAVE stelle font ein
FI
ELIF font exists (par1)
THEN font nr := font (par1);
ELSE fehler (1, par1);
par1 := font (1);
font nr := 1
FI;
alter schriftname := par1;
hole font und stelle trennbreite ein
END PROC stelle font ein;
PROC hole font:
INT VAR x; (* height Werte *)
get font (font nr, eingestellte indentation pitch, x, x, x, pitch table);
pitch table [code (kommandozeichen) + 1] := kommando ausgang;
blankbreite fuer diesen schrifttyp := pitch table [code (blank) + 1]
END PROC hole font;
PROC hole font und stelle trennbreite ein:
hole font;
trennbreite setzen
END PROC hole font und stelle trennbreite ein;
PROC trennbreite setzen:
trennbreite := berechnete trennbreite.
berechnete trennbreite:
INT VAR eingestellte trennbreite;
conversion (limit in cm, eingestellte trennbreite);
eingestellte trennbreite := eingestellte trennbreite
DIV 100 * trennbreite in prozent;
IF eingestellte trennbreite <= zweimal blankbreite
THEN zweimal blankbreite
ELSE eingestellte trennbreite
FI.
zweimal blankbreite:
2 * eingestellte indentation pitch.
END PROC trennbreite setzen;
PROC hyphenation width (INT CONST prozente):
IF prozente < 4 OR prozente > 20
THEN putline ("Fehler: Einstellbare Trennbreite zwischen 4 und 20%")
ELSE trennbreite in prozent := prozente
FI
END PROC hyphenation width;
(************************** kommando verarbeitung ****************)
PROC additional commands (TEXT CONST k):
zusaetzliche commands := k
END PROC additional commands;
TEXT PROC additional commands:
zusaetzliche commands
END PROC additional commands;
BOOL PROC hinter dem kommando steht nix (INT CONST komm ende):
komm ende = pufferlaenge OR absatz hinter dem kommando.
absatz hinter dem kommando:
komm ende + 1 = pufferlaenge AND puffer hat absatz.
END PROC hinter dem kommando steht nix;
PROC verarbeite kommando und neue zeile auffuellen:
neue zeile auffuellen (von, zeichenpos - 1);
von := zeichenpos;
verarbeite kommando;
neue zeile auffuellen (von, zeichenpos - 1);
von := zeichenpos
END PROC verarbeite kommando und neue zeile auffuellen;
PROC speichere kommando:
command store CAT "#";
command store CAT kommando;
command store CAT "#"
END PROC speichere kommando;
PROC execute stored commands:
IF length (command store) <> 0
THEN kommandos speichern := FALSE;
dummy := puffer;
INT VAR zpos := zeichenpos;
zeichenpos := 1;
puffer := command store;
pufferlaenge := length (puffer);
execute commands;
puffer := dummy;
pufferlaenge := length (puffer);
zeichenpos := zpos;
command store := "";
FI;
kommandos speichern := TRUE.
execute commands:
WHILE zeichenpos < pufferlaenge REP
verarbeite kommando
END REP.
END PROC execute stored commands;
PROC verarbeite kommando:
INT VAR anz params,
intparam,
kommando ende;
REAL VAR realparam;
zeichenpos INCR 1;
kommando ende := pos (puffer, kommando zeichen, zeichenpos);
IF kommando ende <> 0
THEN kommando oder kommentar kommando verarbeiten;
zeichenpos := kommando ende + 1
ELSE fehler (2, "")
FI.
kommando oder kommentar kommando verarbeiten:
kommando := subtext (puffer, zeichenpos, kommando ende - 1);
TEXT CONST erstes kommandozeichen :: (kommando SUB 1);
IF pos ("-/"":*", erstes kommandozeichen) = 0
THEN scanne kommando und fuehre es aus
ELSE restliche kommandos
FI.
restliche kommandos:
IF erstes kommandozeichen = "-" OR erstes kommandozeichen = "/"
THEN
ELIF erstes kommandozeichen = """"
THEN scan (kommando);
next symbol (scan symbol, scan type);
INT VAR scan type2;
next symbol (scan symbol, scan type2);
IF scan type <> 4 OR scan type2 <> 7
THEN fehler (58, kommando)
FI
ELIF erstes kommandozeichen = "*"
THEN zeichenpos := kommando ende + 1;
macroend command;
LEAVE verarbeite kommando
ELIF erstes kommandozeichen = ":"
THEN disable stop;
delete char (kommando, 1);
INT CONST line no before do := line no (eingabe);
do (kommando);
to line (eingabe, line no before do);
IF is error
THEN dummy := error message;
clear error;
dummy CAT " -> ";
dummy CAT kommando;
fehler (9, dummy)
FI;
enable stop
FI.
scanne kommando und fuehre es aus:
analyze command (kommando liste, kommando, 3,
kommando index, anz params, par1, par2);
disable stop ;
command error ;
IF is error
THEN dummy := error message;
clear error;
dummy CAT " -> ";
dummy CAT kommando;
fehler (22, dummy);
enable stop;
LEAVE scanne kommando und fuehre es aus
FI;
enable stop;
setze kommando um.
setze kommando um:
SELECT kommando index OF
CASE type1:
stelle font ein;
modifikations speicher := "";
mod zeilennr speicher := ""
CASE limit:
realparam := real (par1);
IF kommandos speichern
THEN speichere kommando
ELIF last conversion ok AND pos (par1, ".") <> 0
THEN IF realparam = 0.0
THEN fehler (37, "")
ELSE conversion (realparam, aktuelle pitch zeilenlaenge);
IF realparam <> fehlerwert
THEN limit in cm := realparam;
trennbreite setzen
FI
FI
ELSE fehler (4, par1);
FI
CASE on, ub, fb:
TEXT VAR mod zeichen;
IF kommando index = ub
THEN mod zeichen := "u"
ELIF kommando index = fb
THEN mod zeichen := "b"
ELSE mod zeichen := (par1 SUB 1);
FI;
INT VAR position :: pos (modifikations speicher, mod zeichen);
IF position <> 0
THEN dummy := mod zeichen + " in Zeile ";
dummy CAT text (mod zeilennr speicher ISUB position);
fehler (54, dummy);
replace (mod zeilennr speicher, position, zeilennr);
ELSE modifikations speicher CAT mod zeichen;
mod zeilennr speicher CAT zeilennr
FI
CASE off, fe, ue:
IF kommando index = ue
THEN mod zeichen := "u"
ELIF kommando index = fe
THEN mod zeichen := "b"
ELSE mod zeichen := (par1 SUB 1);
FI;
position := pos (modifikations speicher, mod zeichen);
IF position = 0
THEN fehler (55, mod zeichen)
ELSE delete char (modifikations speicher, position);
delete int (mod zeilennr speicher, position)
FI
CASE pagenr, pagelength, start, block, material, setcount, right, center,
linefeed:
CASE head, headodd, headeven, bottom, bottomodd, bottomeven, end, free,
page command0, page command1, columns, columnsend:
IF NOT hinter dem kommando steht nix (kommando ende)
THEN fehler (19, kommando)
ELIF kommando ende = pufferlaenge
THEN IF (neue zeile SUB length (neue zeile)) = blank
THEN delete char (neue zeile, length (neue zeile))
FI;
puffer CAT blank;
pufferlaenge := length (puffer)
FI;
in foot := FALSE
CASE foot:
IF in foot uebertrag
THEN zeilenbreite := aktuelle pitch zeilenlaenge + 1
ELIF in foot
THEN fehler (3, "")
ELSE fuelle ggf zeile vor foot auf (kommando ende)
FI
CASE ib0, ib1, ib2:
TEXT VAR ind zeichen;
IF kommando index = ib0
THEN ind zeichen:= "1"
ELSE ind zeichen := par1
FI;
position := pos (index speicher, ind zeichen);
IF position <> 0
THEN dummy := ind zeichen + " in Zeile ";
dummy CAT text (ind zeilennr speicher ISUB position);
fehler (56, dummy);
replace (ind zeilennr speicher, position, zeilennr)
ELSE index speicher CAT ind zeichen;
ind zeilennr speicher CAT zeilennr
FI
CASE ie0, ie1, ie2:
IF kommando index = ie0
THEN ind zeichen := "1"
ELSE ind zeichen := par1
FI;
position := pos (index speicher, ind zeichen);
IF position = 0
THEN fehler (57, ind zeichen)
ELSE delete char (index speicher, position);
delete int (ind zeilennr speicher, position)
FI
CASE topage, count1:
herkunftsreferenzen speichern;
zeilenbreite um blankbreite erhoehen (3)
CASE count0:
zeilenbreite um blankbreite erhoehen (3)
CASE value0, value1:
IF anz params <> 0
THEN zielreferenzen speichern ohne warnung
FI;
zeilenbreite um blankbreite erhoehen (3)
CASE goalpage:
zielreferenzen speichern
CASE table:
IF in tabelle
THEN fehler (41, "")
ELSE IF hinter dem kommando steht nix (kommando ende)
THEN zeichenpos := pufferlaenge;
neue zeile auffuellen und ausgabe bei zeilenende
ELSE neue zeile auffuellen (von, kommando ende);
puffer := subtext (puffer, kommandoende + 1);
schreibe und initialisiere neue zeile
FI;
verarbeite tabelle;
LEAVE verarbeite kommando
FI
CASE table end:
IF NOT in tabelle
THEN fehler (59, "")
FI
CASE r pos:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition eintragen (r pos)
FI
CASE l pos:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition eintragen (l pos)
FI
CASE c pos:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition eintragen (c pos)
FI
CASE d pos:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition eintragen (d pos)
FI
CASE b pos:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition eintragen (b pos)
FI
CASE clear pos0:
IF kommandos speichern
THEN speichere kommando
ELSE anz tabs := 0;
FI
CASE clear pos1:
IF kommandos speichern
THEN speichere kommando
ELSE tabulatorposition loeschen
FI
CASE skip:
IF hinter dem kommando steht nix (kommando ende)
THEN neue zeile auffuellen und ausgabe bei zeilenende
ELSE neue zeile auffuellen (von, kommandoende);
puffer := subtext (puffer, kommandoende + 1);
schreibe und initialisiere neue zeile
FI;
skip zeilen verarbeiten;
kommando ende := zeichenpos;
CASE skip end:
CASE u command, d command:
INT VAR next smaller font;
speichere font nr;
IF next smaller font exists (font nr, next smaller font)
THEN font nr := next smaller font
FI;
hole font und stelle trennbreite ein;
IF NOT in d und e verarbeitung
THEN verarbeite index und exponenten;
LEAVE verarbeite kommando
FI
CASE e command:
entspeichere font nr
CASE head on, head off, bottom on, bottom off, count per page, fillchar,
mark command, markend, pageblock:
CASE bsp:
zeichenpos DECR 2;
IF kommandoende = length (puffer) OR
(puffer SUB kommandoende + 1) = kommandozeichen OR
zeichenpos < 1 OR
(puffer SUB zeichenpos) = kommandozeichen
THEN fehler (28, "");
LEAVE setze kommando um
FI;
begin of this char (puffer, zeichenpos);
kommandoende INCR 1;
INT VAR diese breite :: breite (puffer, zeichenpos),
naechste breite :: breite (puffer, kommandoende);
IF in d und e verarbeitung
THEN formelbreite DECR diese breite;
formelbreite INCR max (diese breite, naechste breite)
ELSE zeilenbreite DECR diese breite;
zeilenbreite INCR max (diese breite, naechste breite)
FI;
zeichenpos := kommandoende;
char pos move (vorwaerts);
LEAVE verarbeite kommando
CASE counter1, counter2:
dummy := "#";
dummy CAT par1;
dummy CAT "#";
IF pos (counter numbering store, dummy) = 0
THEN fehler (34, par1);
FI;
IF kommando index = counter1
THEN par2 := "0"
FI;
anz blanks freihalten := 3 + 2 * int (par2);
zeilenbreite um blankbreite erhoehen (anz blanks freihalten)
CASE set counter:
dummy := "#";
dummy CAT par1;
dummy CAT "#";
IF pos (counter numbering store, dummy) = 0
THEN counter numbering store CAT dummy
ELSE warnung (15, par1)
FI
CASE put counter0:
zeilenbreite um blankbreite erhoehen (anz blanks freihalten)
CASE put counter1:
dummy := "#";
dummy CAT par1;
dummy CAT "#";
INT VAR begin pos :: pos (counter reference store, dummy);
IF begin pos = 0
THEN counter reference store CAT "u";
counter reference store CAT dummy
ELIF (counter reference store SUB begin pos - 1) <> "u"
THEN insert char (counter reference store,"u", max (begin pos, 1))
FI;
zeilenbreite um blankbreite erhoehen (5)
CASE store counter:
dummy := "#";
dummy CAT par1;
dummy CAT "#";
begin pos := pos (counter reference store, dummy);
IF begin pos <> 0
THEN IF (counter reference store SUB begin pos - 1) = "i" OR
(counter reference store SUB begin pos - 2) = "i"
THEN fehler (35, par1)
ELIF (counter reference store SUB begin pos - 1) = "u"
THEN insert char (counter reference store, "i",
max (begin pos - 1, 1))
ELSE insert char (counter reference store, "i",
max (begin pos, 1))
FI
ELSE counter reference store CAT "i";
counter reference store CAT dummy
FI
OTHERWISE
IF macro command and then process parameters (kommando)
THEN IF macro works
THEN fehler (15, kommando)
ELSE zeichenpos := kommando ende + 1;
neue zeile auffuellen (von, zeichenpos - 1);
von := zeichenpos;
fuehre initialisierung fuer macro aus;
LEAVE verarbeite kommando
FI
ELIF zusaetzliche commands <> ""
THEN analyze command (zusaetzliche commands, kommando, 3,
kommando index, anz params, par1, par2);
IF kommando index = 0
THEN fehler (8, kommando)
FI
ELSE fehler (8, kommando)
FI;
END SELECT.
END PROC verarbeite kommando;
(************************* Indizes und Exponenten **********************)
PROC zeilenbreite um blankbreite erhoehen (INT CONST anz):
INT CONST blankbreite mal anz :: anz * eingestellte indentation pitch;
IF in d und e verarbeitung
THEN formelbreite INCR blankbreite mal anz
ELSE zeilenbreite INCR blankbreite mal anz
FI;
mitzuzaehlende zeichen INCR anz
END PROC zeilenbreite um blankbreite erhoehen;
PROC speichere font nr:
IF index oder exponent anfang
THEN suche wortanfang in neuer zeile;
zeilenbreite DECR formelbreite
FI;
font nr speicher CAT " ";
font nr speicher CAT text (font nr).
index oder exponent anfang:
font nr speicher = "".
suche wortanfang in neuer zeile:
auf das letzte zeichen stellen;
WHILE NOT wortanfang vor formel REP
formelbreite INCR breite (neue zeile, formelanfang);
IF formelanfang = 1
THEN LEAVE suche wortanfang in neuer zeile
FI;
char pos move (neue zeile, formelanfang, rueckwaerts);
END REP;
char pos move (neue zeile, formelanfang, vorwaerts).
wortanfang vor formel:
pos (" #", neue zeile SUB formelanfang) <> 0.
auf das letzte zeichen stellen:
formelanfang := length (neue zeile);
formelbreite := 0;
IF formelanfang > 0
THEN begin of this char (neue zeile, formelanfang);
ELSE formelanfang := 1;
LEAVE suche wortanfang in neuer zeile
FI
END PROC speichere font nr;
PROC verarbeite index und exponenten:
in d und e verarbeitung := TRUE;
zeichenpos := pos (puffer, kommandozeichen, zeichenpos) + 1;
INT VAR altes zeichenpos := zeichenpos;
verarbeite index oder exponenten zeichen;
fehler (52, "");
entspeichere font nr.
verarbeite index oder exponenten zeichen:
REP
stranalyze (pitch table, formelbreite,
aktuelle pitch zeilenlaenge - zeilenbreite,
puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
IF zeichenwert ausgang = kommando ausgang
THEN verarbeite zeichen vor kommando;
verarbeite kommando und neue zeile auffuellen;
IF NOT in d und e verarbeitung
THEN zeilenbreite INCR formelbreite;
LEAVE verarbeite index und exponenten
FI;
altes zeichenpos := zeichenpos
ELIF zeichenwert ausgang = extended char ausgang
THEN char pos move (vorwaerts);
zeilenbreite INCR breite (puffer, zeichenpos);
char pos move (vorwaerts)
ELIF zeichenpos >= pufferlaenge
AND formelbreite + zeilenbreite < aktuelle pitch zeilenlaenge
THEN LEAVE verarbeite index oder exponenten zeichen
ELIF formelanfang <= 1
THEN fehler (53, "");
formelbreite := 0;
ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN fehler (23, "");
LEAVE verarbeite index oder exponenten zeichen
ELSE schreibe neue zeile vor formelanfang
FI
END REP.
verarbeite zeichen vor kommando:
mitzuzaehlende zeichen INCR
number chars (puffer, altes zeichenpos, zeichenpos);
IF (puffer SUB zeichenpos) <> blank
THEN aufzaehlungszeichen := (puffer SUB zeichenpos)
FI;
char pos move (vorwaerts).
schreibe neue zeile vor formelanfang:
dummy := subtext (neue zeile, formelanfang);
neue zeile := subtext (neue zeile, 1, formelanfang - 1);
loesche nachfolgende blanks;
schreibe und initialisiere neue zeile;
neue zeile CAT dummy;
formelanfang := 1;
char pos move (vorwaerts)
END PROC verarbeite index und exponenten;
PROC entspeichere font nr:
INT VAR index := length (font nr speicher);
IF index <= 1
THEN fehler (51, "")
ELSE suche nr anfang;
entspeichere;
FI.
suche nr anfang:
WHILE (font nr speicher SUB index) <> " " AND index <> 0 REP
index DECR 1
END REP.
entspeichere:
font nr := int (subtext (font nr speicher, index + 1));
IF index <= 1
THEN font nr speicher := "";
in d und e verarbeitung := FALSE
ELSE font nr speicher := subtext (font nr speicher, 1, index - 1)
FI;
hole font und stelle trennbreite ein
END PROC entspeichere font nr;
(*************************** skip zeilen ****************************)
PROC skip zeilen verarbeiten:
REP
IF dateiende
THEN errorstop ("Dateiende während skip-Anweisung")
ELIF skip ende kommando
THEN LEAVE skip zeilen verarbeiten
FI;
neue zeile auffuellen und ausgabe bei zeilenende
END REP.
dateiende:
pufferlaenge = 0.
skip ende kommando:
TEXT VAR kliste :: "skipend:1.0", k;
INT VAR k anf :: pos (puffer, kommandozeichen),
kende, anz params, kindex;
WHILE noch ein kommando vorhanden REP
kindex := 0;
analysiere das kommando
END REP;
FALSE.
noch ein kommando vorhanden:
kanf <> 0.
analysiere das kommando:
kende := pos (puffer, kommandozeichen, kanf + 1);
IF kende = 0
THEN fehler (2, "");
LEAVE skip ende kommando WITH FALSE
FI;
k := subtext (puffer, kanf + 1, kende - 1);
analyze command (kliste, k, 3, kindex, anz params, par1, par2);
IF kindex = 1
THEN zeichenpos := kende;
LEAVE skip ende kommando WITH TRUE
FI;
kanf := pos (puffer, kommandozeichen, kende + 1).
END PROC skip zeilen verarbeiten;
(**************** sonderbehandlung von zeilen vor foot *******************)
PROC fuelle ggf zeile vor foot auf (INT VAR com ende):
IF foot am zeilenende ohne absatz AND NOT macro works
THEN letzter puffer war absatz := TRUE;
IF text vor foot AND NOT zeile hat richtige laenge
THEN INT VAR foot zeilennr := line no (eingabe);
INT CONST x1 := com ende;
in foot uebertrag := TRUE;
get liner state (before foot state);
formatiere diese zeile;
to line (eingabe, foot zeilennr);
footdummy := neue zeile;
put liner state (before foot state);
neue zeile := footdummy;
com ende := x1;
in foot uebertrag := FALSE
FI
ELIF NOT hinter dem kommando steht nix (com ende)
THEN fehler (19, kommando);
LEAVE fuelle ggf zeile vor foot auf
FI;
in foot := TRUE.
foot am zeilenende ohne absatz:
com ende = pufferlaenge.
text vor foot:
pos (neue zeile, ""33"", ""255"", 1) <> 0.
formatiere diese zeile:
foot anweisung entfernen;
lese eingabe datei bis end kommando;
zeile nach end in zeile;
formatiere;
schreibe die veraenderte zeile nach end.
foot anweisung entfernen:
zeichenpos := com ende;
ueberspringe das kommando (puffer, zeichenpos, rueckwaerts);
zeichenpos DECR 1;
puffer := subtext (puffer, 1, zeichenpos);
WHILE NOT within kanji (puffer, zeichenpos) AND
(puffer SUB zeichenpos) = blank AND foot stand nicht am zeilenanfang
REP
zeilenbreite DECR breite (blank);
delete char (puffer, zeichenpos);
delete char (neue zeile, length (neue zeile));
zeichenpos DECR 1
END REP;
pufferlaenge := length (puffer).
foot stand nicht am zeilenanfang:
zeichenpos > 0.
lese eingabe datei bis end kommando:
TEXT VAR kliste :: "end:1.0";
dummy := zeile;
WHILE NOT foot ende kommando REP
IF eof (eingabe)
THEN LEAVE formatiere diese zeile
FI;
read record (eingabe, dummy);
down (eingabe);
ENDREP;
INT CONST zeile nach end := line no (eingabe);
IF NOT end kommando steht am zeilenende
THEN LEAVE formatiere diese zeile
FI.
end kommando steht am zeilenende:
k ende = length (dummy) OR k ende + 1 = length (dummy).
foot ende kommando:
INT VAR k anf, k ende :: 0, anz params, k index;
WHILE noch ein kommando vorhanden REP
k ende := pos (dummy, kommandozeichen, k anf + 1);
IF k ende = 0
THEN LEAVE foot ende kommando WITH FALSE
ELSE kommando := subtext (dummy, k anf + 1, k ende - 1);
FI;
analyze command (kliste, kommando, 3, kindex, anz params, par1, par2);
IF k index = 1
THEN LEAVE foot ende kommando WITH TRUE
FI;
END REP;
FALSE.
noch ein kommando vorhanden:
k anf := pos (dummy, kommandozeichen, k ende + 1);
k anf <> 0.
zeile nach end in zeile:
read record (eingabe, zeile);
INT VAR text anf := pos (zeile, ""33"", ""255"", 1);
IF zeile nach end ist leerzeile
THEN LEAVE formatiere diese zeile
ELSE IF text anf > 1
THEN aktuelle blanks := subtext (zeile, 1, text anf - 1);
zeile := subtext (zeile, text anf)
FI;
FI.
zeile nach end ist leerzeile:
text anf <= 0.
formatiere:
IF foot stand nicht am zeilenanfang
THEN verarbeite letztes zeichen von puffer
ELSE puffer CAT zeile;
pufferlaenge := length (puffer)
FI;
REP
stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
IF zeichenwert ausgang = kommando ausgang
THEN zeichenpos INCR 1;
neue zeile auffuellen (von, zeichenpos - 1);
von := zeichenpos;
INT VAR ende der neuen zeile := length (neue zeile),
zpos davor := zeichenpos;
verarbeite kommando;
neue zeile auffuellen (von, zeichenpos - 1);
von := zeichenpos;
IF kommando index = foot
THEN behandlung der zeile vor foot;
LEAVE formatiere
ELIF zeichenpos >= pufferlaenge
OR zeilenbreite > aktuelle pitch zeilenlaenge
THEN ende einer neuen zeile;
LEAVE formatiere
FI
ELIF zeichenwert ausgang = extended char ausgang
THEN char pos move (vorwaerts);
zeilenbreite INCR breite (puffer, zeichenpos);
char pos move (vorwaerts)
ELIF zeichenwert ausgang = zeilenende ausgang
OR zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN up (eingabe);
delete record (eingabe);
neue zeile auffuellen;
IF zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN fehler (23, "")
FI;
LEAVE formatiere diese zeile
ELSE ende einer neuen zeile;
LEAVE formatiere
FI
END REP.
behandlung der zeile vor foot:
neue zeile := subtext (neue zeile, 1, ende der neuen zeile);
zeichenpos := zpos davor.
schreibe die veraenderte zeile nach end:
to line (eingabe, zeile nach end);
dummy := (text anf - 1) * blank;
dummy CAT subtext (puffer, zeichenpos);
IF format file in situ
THEN insert record (eingabe)
FI;
write record (eingabe, dummy).
END PROC fuelle ggf zeile vor foot auf;
(*************** Tabulator- und Tabellen verarbeitung ******************)
PROC tabulatorposition eintragen (INT CONST tab type):
ROW 3 INT VAR akt tab pos;
IF anz tabs >= max tabs
THEN fehler (32, "")
ELIF tab in cm umwandeln (par1, tab pos in pitches)
THEN IF tab type = b pos AND tab in cm umwandeln (par2, bis tab)
THEN
ELSE bis tab := 0
FI;
TEXT VAR zentrierzeichen;
IF tab type = d pos
THEN zentrierzeichen := par2
ELSE zentrierzeichen := ""
FI;
tabs sortiert eintragen
FI.
tabs sortiert eintragen:
INT VAR i;
type tab := tab type;
FOR i FROM 1 UPTO anz tabs REP
IF tab pos in pitches = tabs [i] [1]
THEN fehler (42, par1);
LEAVE tabulatorposition eintragen
ELIF tabs [i] [1] > tab pos in pitches
THEN vertauschen
FI;
IF ueberschneidende bpos
THEN fehler (12, text (xstepconversion (tab pos in pitches)))
FI;
END REP;
anz tabs INCR 1;
tabs [anz tabs] := akt tab pos;
tab zeichen [anz tabs] := zentrierzeichen.
ueberschneidende bpos:
tabs [i] [2] = bpos AND naechste anfang pos liegt in diesem bpos bereich.
naechste anfang pos liegt in diesem bpos bereich:
tab pos in pitches <= tabs [i] [3].
vertauschen:
ROW 3 INT CONST hilf1 :: tabs [i];
TEXT CONST thilf :: tab zeichen [i];
tabs [i] := akt tab pos;
tab zeichen [i] := zentrierzeichen;
akt tab pos := hilf1;
zentrierzeichen := thilf.
tab pos in pitches:
akt tab pos [1].
type tab:
akt tab pos [2].
bis tab:
akt tab pos [3].
END PROC tabulatorposition eintragen;
BOOL PROC tab in cm umwandeln (TEXT CONST text wert, INT VAR f breite):
REAL VAR cm := real (text wert);
IF last conversion ok AND pos (text wert, ".") <> 0
THEN umwandeln
ELSE fehler (4, par1);
TRUE
FI.
umwandeln:
conversion (cm, f breite);
IF f breite > aktuelle pitch zeilenlaenge
THEN fehler (39, par1)
ELIF cm = fehlerwert
THEN
ELSE LEAVE tab in cm umwandeln WITH TRUE
FI;
FALSE
END PROC tab in cm umwandeln;
PROC cm angabe der druckposition in dummy (INT CONST nr):
dummy := text (x step conversion (tabs [nr] [1]));
IF (dummy SUB length (dummy)) = "."
THEN dummy CAT "0"
FI;
dummy CAT " cm"
END PROC cm angabe der druckposition in dummy;
PROC tabulator position loeschen:
INT VAR tab pos in pitches;
IF tab in cm umwandeln (par1, tab pos in pitches)
THEN versuche zu loeschen
FI.
versuche zu loeschen:
INT VAR i;
FOR i FROM 1 UPTO anz tabs REP
IF tab pos in pitches = tabs [i] [1]
THEN verschiebe eintraege nach unten;
LEAVE tabulator position loeschen
FI
END REP;
fehler (43, par1).
verschiebe eintraege nach unten:
INT VAR k;
FOR k FROM i UPTO anz tabs - 1 REP
tabs [k] := tabs [k + 1];
tab zeichen [k] := tab zeichen [k + 1];
END REP;
anz tabs DECR 1.
END PROC tabulatorposition loeschen;
PROC verarbeite tabelle:
in tabelle := TRUE;
pitch table auf blank ausgang setzen;
verarbeite tabellenzeilen;
pitch table auf blank setzen;
IF suchausgang gesetzt
THEN pitch table [pos tab zeichen in pitch table] :=
breite erstes dezimalzeichen;
suchausgang gesetzt := FALSE;
FI;
in tabelle := FALSE.
verarbeite tabellenzeilen:
WHILE pufferlaenge <> 0 REP
ueberpruefe tabellenzeile;
zeichenpos := pufferlaenge;
neue zeile auffuellen und ausgabe bei zeilenende
END REP;
puffer := " ";
pufferlaenge := 1;
zeichenpos := 1;
fehler (49, "").
ueberpruefe tabellenzeile:
(* Achtung: Zeilenbreite ist Spaltenbreite;
tab zeilen breite ist Summe der Spalten und Positionen *)
INT VAR tab zeilen breite :: 0,
tab no :: 1;
WHILE noch tab positionen OR only command line (puffer) REP
positioniere auf naechste spalte;
errechne spaltenbreite;
IF anz tabs > 0
THEN ueberpruefe ob es passt;
FI;
tab no INCR 1
END REP;
IF tabellenzeile breiter als limit
THEN warnung (10, "")
ELIF noch mehr spaltentexte AND anz tabs <> 0
THEN warnung (11, subtext (puffer, zeichenpos))
FI.
noch tab positionen:
tab no <= anz tabs.
positioniere auf naechste spalte:
zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
IF leerzeile oder rest der zeile ist leer
THEN IF NOT only command line (puffer) AND pufferlaenge > 1
THEN warnung (14, "")
FI;
LEAVE ueberpruefe tabellenzeile
FI.
leerzeile oder rest der zeile ist leer:
zeichenpos <= 0.
errechne spaltenbreite:
zeilenbreite := 0;
BOOL VAR suchausgang gesetzt :: FALSE;
IF diese position ist dezimal pos
THEN setze dezimalzeichen auf suchausgang
FI;
REP
stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
zeichenpos INCR 1;
IF zeichenwert ausgang = blank ausgang
THEN behandele dieses blank
ELIF zeichenwert ausgang = kommando ausgang
THEN verarbeite das kommando
ELIF zeichenwert ausgang = extended char ausgang
THEN char pos move (vorwaerts);
zeilenbreite INCR breite (puffer, zeichenpos);
char pos move (vorwaerts)
ELIF zeichenwert ausgang = such ausgang
THEN verarbeite ersten teil der dezimal zentrierung
ELIF zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN fehler (23, "");
LEAVE ueberpruefe tabellenzeile
ELIF zeilenbreite + zeichenwert ausgang > aktuelle pitch zeilenlaenge
THEN fehler (36, "");
LEAVE ueberpruefe tabellenzeile
ELSE tabellenzeile ohne absatz
FI
END REP.
diese position ist dezimal pos:
tabs [tab no] [2] = dpos.
setze dezimalzeichen auf suchausgang:
INT CONST pos tab zeichen in pitch table ::
code (tab zeichen [tab no] SUB 1) + 1;
INT VAR breite erstes dezimalzeichen :=breite (tab zeichen [tab no] SUB 1),
breite excl dezimalzeichen := 0;
suchausgang gesetzt := TRUE;
pitch table [pos tab zeichen in pitch table] := such ausgang.
verarbeite ersten teil der dezimal zentrierung:
IF pos (puffer, tab zeichen [tab no], zeichenpos) = zeichenpos
THEN pitch table [pos tab zeichen in pitch table] :=
breite erstes dezimalzeichen;
suchausgang gesetzt := FALSE;
breite excl dezimalzeichen := zeilenbreite
FI;
zeilenbreite INCR breite (puffer SUB zeichenpos);
zeichenpos INCR 1.
behandele dieses blank:
IF doppelblank OR absatz
THEN LEAVE errechne spaltenbreite
ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp;
zeichenpos INCR 1
FI.
doppelblank:
(puffer SUB zeichenpos + 1) = blank.
verarbeite das kommando:
pitch table auf blank setzen;
verarbeite kommando und neue zeile auffuellen;
pitch table auf blank ausgang setzen;
IF kommando index = table end
THEN LEAVE verarbeite tabellenzeilen
ELIF suchausgang gesetzt AND
pitch table [pos tab zeichen in pitch table] <> suchausgang
THEN pitch table [pos tab zeichen in pitch table] := suchausgang
FI.
tabellenzeile ohne absatz:
IF zeilenende eines macros
THEN zeile in puffer und zeile lesen;
zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
ELSE LEAVE errechne spaltenbreite
FI.
zeilenende eines macros:
zeichenwert ausgang = zeilenende ausgang AND macro works.
ueberpruefe ob es passt:
INT CONST akt tab pos :: tabs [tab no] [1];
IF vorherige spalte ueberschreibt tabulator position
THEN cm angabe der druckposition in dummy (tab no - 1);
fehler (44, dummy);
tab zeilenbreite := akt tab pos
ELIF only command line (puffer)
THEN
ELSE ueberpruefe nach art des tabulators
FI.
ueberpruefe nach art des tabulators:
IF tabs [tab no] [2] = r pos
THEN nach links schreibend
ELIF tabs [tab no] [2] = l pos
THEN nach rechts schreibend
ELIF tabs [tab no] [2] = b pos
THEN nach rechts blockend schreibend
ELIF tabs [tab no] [2] = c pos
THEN zentrierend
ELSE zentrierend um zeichen
FI.
vorherige spalte ueberschreibt tabulator position:
tab zeilenbreite > akt tab pos.
nach links schreibend:
IF tab zeilenbreite + zeilenbreite > akt tab pos
THEN cm angabe der druckposition in dummy (tab no);
fehler (45, dummy);
FI;
tab zeilenbreite := akt tab pos.
nach rechts schreibend:
tab zeilenbreite := akt tab pos + zeilenbreite.
nach rechts blockend schreibend:
IF akt tab pos + zeilenbreite > tabs [tab no] [3]
THEN cm angabe der druckposition in dummy (tab no);
fehler (48, dummy)
FI;
tab zeilenbreite := tabs [tab no] [3].
zentrierend:
IF tab zeilenbreite + (zeilenbreite DIV 2) > akt tab pos
THEN cm angabe der druckposition in dummy (tab no);
fehler (46, dummy)
FI;
tab zeilenbreite := akt tab pos + (zeilenbreite DIV 2).
zentrierend um zeichen:
IF breite excl dezimalzeichen = 0
THEN cm angabe der druckposition in dummy (tab no);
fehler (50, dummy)
ELIF tab zeilenbreite + breite excl dezimalzeichen > akt tab pos
THEN cm angabe der druckposition in dummy (tab no);
fehler (47, dummy)
FI;
IF suchausgang gesetzt
THEN pitch table [pos tab zeichen in pitch table] :=
breite erstes dezimalzeichen;
suchausgang gesetzt := FALSE;
FI;
tab zeilenbreite := akt tab pos +
(zeilenbreite - breite excl dezimalzeichen).
tabellenzeile breiter als limit:
tab zeilenbreite > aktuelle pitch zeilenlaenge + einrueckbreite.
noch mehr spaltentexte:
pos (puffer, ""33"", ""255"", zeichenpos) <> 0.
END PROC verarbeite tabelle;
(*********************** referenzen ueberpruefen **********************)
PROC aktuelle referenz erstellen:
aktuelle referenz := "#";
aktuelle referenz CAT par1;
aktuelle referenz CAT "#";
END PROC aktuelle referenz erstellen;
PROC zielreferenzen speichern ohne warnung:
aktuelle referenz erstellen;
IF pos (zielreferenzen, aktuelle referenz) = 0
THEN delete char (aktuelle referenz, 1);
zielreferenzen CAT aktuelle referenz
FI
END PROC zielreferenzen speichern ohne warnung;
PROC zielreferenzen speichern:
aktuelle referenz erstellen;
IF pos (zielreferenzen, aktuelle referenz) <> 0
THEN warnung (9, par1)
ELSE delete char (aktuelle referenz, 1);
zielreferenzen CAT aktuelle referenz
FI
END PROC zielreferenzen speichern;
PROC herkunftsreferenzen speichern:
aktuelle referenz erstellen;
IF pos (herkunftsreferenzen, aktuelle referenz) = 0
THEN delete char (aktuelle referenz, 1);
herkunftsreferenzen CAT aktuelle referenz
FI
END PROC herkunftsreferenzen speichern;
PROC referenzen ueberpruefen:
ueberpruefe zielreferenzen;
ueberpruefe restliche herkunftsreferenzen.
ueberpruefe zielreferenzen:
REP
hole naechste zielreferenz;
IF pos (herkunfts referenzen, aktuelle referenz) = 0
THEN change all (aktuelle referenz,"#", "");
warnung (3, aktuelle referenz)
ELSE delete char (aktuelle referenz, length (aktuelle referenz));
change (herkunftsreferenzen, aktuelle referenz, "");
FI
END REP.
hole naechste zielreferenz:
IF length (zielreferenzen) > 1
THEN aktuelle referenz :=
subtext (zielreferenzen, 1, pos (zielreferenzen, "#", 2));
zielreferenzen :=
subtext (zielreferenzen, pos (zielreferenzen, "#", 2))
ELSE LEAVE ueberpruefe zielreferenzen
FI.
ueberpruefe restliche herkunftsreferenzen:
WHILE length (herkunftsreferenzen) > 1 REP
aktuelle referenz :=
subtext (herkunftsreferenzen, 1, pos (herkunftsreferenzen, "#", 2) - 1);
change (herkunftsreferenzen, aktuelle referenz, "");
delete char (aktuelle referenz, 1);
warnung (4, aktuelle referenz)
END REP.
END PROC referenzen ueberpruefen;
(*************************** Utilities *******************************)
INT PROC breite (TEXT CONST z):
INT VAR b;
IF z = ""
THEN display and pause (1)
ELIF z = kommandozeichen
THEN display and pause (2); b := 1
ELSE b := pitch table [code (z) + 1]
FI;
IF zeilenbreite > maxint - b
THEN display and pause (3); b := 1
FI;
b.
END PROC breite;
INT PROC breite (TEXT CONST ein text, INT CONST zpos):
TEXT CONST z :: ein text SUB zpos;
INT VAR zeichen breite;
IF z = ""
THEN display and pause (4); zeichen breite := 1
ELIF z = kommandozeichen
THEN display and pause (6); zeichen breite := 1
ELSE zeichen breite := pitch table [code (z) + 1]
FI;
IF zeichen breite = extended char ausgang
THEN zeichen breite := extended char pitch (font nr,
ein text SUB zpos, ein text SUB zpos + 1)
FI;
zeichen breite
END PROC breite;
PROC char pos move (INT CONST richtung):
char pos move (zeichenpos, richtung)
END PROC char pos move;
PROC char pos move (INT VAR zpos, INT CONST richtung):
char pos move (puffer, zpos, richtung)
END PROC char pos move;
BOOL PROC absatz:
zeichenpos = pufferlaenge AND puffer hat absatz
END PROC absatz;
BOOL PROC puffer hat absatz:
NOT within kanji (puffer, pufferlaenge) AND
(puffer SUB pufferlaenge) = blank
END PROC puffer hat absatz;
PROC pitch table auf blank ausgang setzen:
IF pitch table [code (blank) + 1] <> blank ausgang
THEN blank breite fuer diesen schrifttyp := breite (blank);
pitch table [code (blank) + 1] := blank ausgang
FI
END PROC pitch table auf blank ausgang setzen;
PROC pitch table auf blank setzen:
pitch table [code (blank) + 1] := blank breite fuer diesen schrifttyp
END PROC pitch table auf blank setzen;
(*PROC zustands test (TEXT CONST anf):
line ;put(anf);
line ;put("zeilenbreite, aktuelle pitch zeilenlaenge:");
put(zeilenbreite);put(aktuelle pitch zeilenlaenge);
line ;put("zeichenpos, pufferlaenge, ausgang, zeichen:");
put(zeichenpos);put(pufferlaenge);
IF zeichenwert ausgang = blank ausgang
THEN put ("blank")
ELIF zeichenwert ausgang = kommando ausgang
THEN put ("kommando")
ELIF zeichenwert ausgang = such ausgang
THEN put ("such")
ELIF zeichenwert ausgang = zeilenende ausgang
THEN put ("zeilenende")
ELSE put(zeichenwert ausgang);
FI; put ("ausgang");
out(">");out(puffer SUB zeichenpos);out("<");
line ;out("puffer >");
IF length (puffer) > 65
THEN outsubtext (puffer, 1, 65);
line ; outsubtext (puffer, 66)
ELSE out(puffer);
FI;
out("<");
line ;out("zeile >");
IF length (zeile) > 65
THEN outsubtext (zeile, 1, 65);
line ; outsubtext (zeile, 66)
ELSE out (zeile);
FI;
out("<");
line ;out("neue zeile >");
IF length (neue zeile) > 65
THEN outsubtext (neue zeile, 1, 65);
line ; outsubtext (neue zeile, 66)
ELSE out(neue zeile);
FI;
out("<");
line ;
END PROC zustands test;*)
(*************************** eigentliche form routine ********************)
PROC zeilen form (TEXT CONST datei):
enable stop;
form initialisieren (datei);
formiere absatzweise;
letzte neue zeile ausgeben.
formiere absatzweise:
REP
letzter puffer war absatz := FALSE;
einrueckbreite := eingestellte indentation pitch;
IF einfacher absatz nach absatz
THEN gebe einfachen absatz aus
ELSE verarbeite abschnitt nach absatz
FI
UNTIL pufferlaenge = 0 END REP.
einfacher absatz nach absatz:
absatz.
gebe einfachen absatz aus:
neue zeile := blank;
ausgabe bei zeilenende.
verarbeite abschnitt nach absatz:
berechne erste zeile nach absatz;
IF NOT letzter puffer war absatz
THEN formiere
FI.
formiere:
INT VAR letzte zeilennr;
REP
stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
IF zeichenwert ausgang = kommando ausgang
THEN zeichenpos INCR 1;
verarbeite kommando und neue zeile auffuellen;
IF letzter puffer war absatz
THEN ausgabe bei zeilenende;
LEAVE verarbeite abschnitt nach absatz
ELIF zeichenpos > pufferlaenge OR absatz
THEN letzte zeilennr := zeilennr;
verarbeite letztes zeichen von puffer;
IF neue zeile ausgeloest
THEN LEAVE verarbeite abschnitt nach absatz
ELSE letzter puffer war absatz := FALSE
FI
FI
ELIF zeichenwert ausgang = extended char ausgang
THEN char pos move (vorwaerts);
zeilenbreite INCR breite (puffer, zeichenpos);
char pos move (vorwaerts)
ELIF zeichenwert ausgang = zeilenende ausgang
OR zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN letzte zeilennr := zeilennr;
verarbeite letztes zeichen von puffer;
IF zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN fehler (23, "")
FI;
IF neue zeile ausgeloest
THEN LEAVE verarbeite abschnitt nach absatz
ELSE letzter puffer war absatz := FALSE
FI
ELSE ende einer neuen zeile
FI;
UNTIL pufferlaenge = 0 END REP.
neue zeile ausgeloest:
letzte zeilennr < zeilennr.
END PROC zeilen form;
PROC berechne erste zeile nach absatz:
INT CONST anz einrueckungszeichen :: zeilenbreite DIV einrueckbreite;
INT VAR anz zeichen fuer einzeilige einrueckung :: 0,
anz zeichen :: 0,
schlepper zeichenpos :: 1,
letzte zeilennr;
BOOL CONST puffer hatte anfangs absatz :: puffer hat absatz;
BOOL VAR noch kein blank gewesen :: TRUE;
pitch table auf blank ausgang setzen;
berechne erste zeile;
pitch table auf blank setzen.
berechne erste zeile:
REP
stranalyze (pitch table, zeilenbreite, aktuelle pitch zeilenlaenge,
puffer, zeichenpos, pufferlaenge, zeichenwert ausgang);
IF zeichenwert ausgang = blank ausgang
THEN verarbeite text
ELIF zeichenwert ausgang = extended char ausgang
THEN char pos move (vorwaerts);
zeilenbreite INCR breite (puffer, zeichenpos);
char pos move (vorwaerts)
ELIF zeichenwert ausgang = kommando ausgang
THEN verarbeite dieses kommando
ELIF zeichenwert ausgang = zeilenende ausgang
OR zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN behandele zu kurze zeile
ELSE behandele zu lange zeile
FI
END REP.
verarbeite dieses kommando:
textzeichen mitzaehlen;
IF pos (" #", (puffer SUB zeichenpos)) = 0
THEN aufzaehlungszeichen := (puffer SUB zeichenpos)
FI;
char pos move (vorwaerts);
mitzuzaehlende zeichen := 0;
pitch table auf blank setzen;
verarbeite kommando und neue zeile auffuellen;
pitch table auf blank ausgang setzen;
IF letzter puffer war absatz
THEN neue zeile auffuellen und ausgabe bei zeilenende;
LEAVE berechne erste zeile
ELIF zeichenpos > pufferlaenge OR absatz
THEN letzte zeilennr := zeilennr;
verarbeite letztes zeichen von puffer;
IF neue zeile ausgeloest
THEN LEAVE berechne erste zeile
ELSE letzter puffer war absatz := FALSE
FI
ELIF anweisung erlaubt keine aufzaehlung
THEN LEAVE berechne erste zeile
FI;
anz zeichen INCR mitzuzaehlende zeichen;
schlepper zeichenpos := zeichenpos.
neue zeile ausgeloest:
letzte zeilennr < zeilennr.
anweisung erlaubt keine aufzaehlung:
kommando index = center OR kommando index = right.
verarbeite text:
char pos move (vorwaerts);
IF absatz
THEN verarbeite letztes zeichen von puffer;
LEAVE berechne erste zeile
ELIF zeilenbreite + blankbreite fuer diesen schrifttyp >
aktuelle pitch zeilenlaenge
THEN behandele zu lange zeile
ELIF mehrfaches blank
THEN positionierung mit doppelblank
ELIF noch kein blank gewesen AND
anz zeichen +
number chars (puffer, schlepper zeichenpos, zeichenpos) <= 20
THEN ggf aufzaehlung aufnehmen
ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp
FI;
noch kein blank gewesen := FALSE;
zeichenpos INCR 1.
mehrfaches blank:
(puffer SUB zeichenpos + 1) = blank.
positionierung mit doppelblank:
WHILE NOT within kanji (puffer, zeichenpos + 1) AND
(puffer SUB zeichenpos + 1) = blank REP
zeichenpos INCR 1
END REP;
textzeichen mitzaehlen;
pruefe auf ueberschreibung
(zeilenbreite, anz zeichen + anz einrueckungszeichen).
ggf aufzaehlung aufnehmen:
IF NOT within kanji (puffer, zeichenpos - 1) AND
(puffer SUB zeichenpos - 1) <> kommandozeichen
THEN aufzaehlungszeichen := (puffer SUB zeichenpos - 1);
FI;
textzeichen mitzaehlen;
IF aufzaehlungszeichen = ":"
OR (aufzaehlungszeichen = "-" AND anz zeichen <= 2)
OR (anz zeichen <= 7 AND ( aufzaehlungszeichen = ")"
OR aufzaehlungszeichen = "."))
THEN anz zeichen fuer einzeilige einrueckung := anz zeichen;
pruefe auf ueberschreibung
(zeilenbreite, anz zeichen + anz einrueckungszeichen)
ELSE zeilenbreite INCR blankbreite fuer diesen schrifttyp
FI.
textzeichen mitzaehlen:
anz zeichen INCR number chars (puffer, schlepper zeichenpos, zeichenpos);
IF is kanji esc (puffer SUB zeichenpos)
THEN schlepper zeichenpos := zeichenpos + 2
ELSE schlepper zeichenpos := zeichenpos + 1
FI.
behandele zu kurze zeile:
textzeichen mitzaehlen;
IF zeichenwert ausgang = esc char ohne zweites byte ausgang
THEN fehler (23, "");
neue zeile auffuellen;
schreibe und initialisiere neue zeile;
zeichenpos := 1;
LEAVE berechne erste zeile
FI;
letzte zeilennr := zeilennr;
verarbeite letztes zeichen von puffer;
IF neue zeile ausgeloest
THEN LEAVE berechne erste zeile
FI;
schlepper zeichenpos := 1.
behandele zu lange zeile:
pitch table auf blank setzen;
IF zeilenende bei erstem zeichen
THEN loesche nachfolgende blanks;
schreibe und initialisiere neue zeile;
zeichenpos := 1;
LEAVE berechne erste zeile
ELIF (puffer SUB zeichenpos) = kommandozeichen
THEN zeichenpos INCR 1
ELSE zeilenbreite DECR breite (puffer, zeichenpos)
FI;
IF puffer hatte anfangs absatz
THEN einrueckung gemaess pufferanfang
FI;
LEAVE berechne erste zeile.
zeilenende bei erstem zeichen:
zeichenpos < 1.
einrueckung gemaess pufferanfang:
alte blanks :=
(anz einrueckungszeichen + anz zeichen fuer einzeilige einrueckung) * blank.
END PROC berechne erste zeile nach absatz;
PROC pruefe auf ueberschreibung (INT CONST aufzaehlungsbreite,
anz aufzaehlungszeichen):
IF ueberschreibung
THEN fehlende blanks errechnen;
INT VAR aufzaehlungsende :: zeichenpos - 1;
WHILE (puffer SUB aufzaehlungsende) = blank REP
aufzaehlungsende DECR 1
END REP;
dummy := ">";
dummy CAT subtext (puffer,
aufzaehlungsende - 15, aufzaehlungsende);
dummy CAT "< Fehlende Blanks: ";
dummy CAT text (anz fehlende blanks);
warnung (12, dummy)
FI;
zeilenbreite := anz aufzaehlungszeichen * einrueckbreite.
ueberschreibung:
INT CONST anz zeichen mal einrueckbreite ::
anz aufzaehlungszeichen * einrueckbreite,
min zwischenraum :: (einrueckbreite DIV 4);
aufzaehlungsbreite + min zwischenraum > anz zeichen mal einrueckbreite.
fehlende blanks errechnen:
INT VAR anz fehlende blanks ::
(aufzaehlungsbreite + min zwischenraum
- anz zeichen mal einrueckbreite + einrueckbreite - 1)
DIV einrueckbreite.
END PROC pruefe auf ueberschreibung;
(********************** eingabe routinen **************************)
PROC zeile lesen:
alte blanks := aktuelle blanks;
hole zeile;
behandele einrueckung.
hole zeile:
IF macro works
THEN get macro line (zeile);
ELIF eof (eingabe)
THEN zeile := "";
LEAVE zeile lesen
ELSE lesen
FI;
IF zeile = ""
THEN zeile := blank
ELIF (zeile SUB length (zeile) - 1) = blank
THEN ggf ueberfluessige leerzeichen am ende entfernen
FI.
lesen:
IF format file in situ
THEN read record (eingabe, zeile);
delete record (eingabe)
ELSE read record (eingabe, zeile);
down (eingabe)
FI.
ggf ueberfluessige leerzeichen am ende entfernen:
WHILE NOT within kanji (zeile, length (zeile) - 1) AND
subtext (zeile, length (zeile) - 1) = " " REP
delete char (zeile, length (zeile))
END REP.
behandele einrueckung:
aktuelle blanks := "";
IF zeile <> blank
THEN INT VAR einrueckung := pos (zeile, ""33"", ""255"", 1);
IF einrueckung > 1
THEN aktuelle blanks := subtext (zeile, 1, einrueckung - 1);
zeile := subtext (zeile, einrueckung)
FI
FI
END PROC zeile lesen;
PROC zeile in puffer und zeile lesen:
puffer := zeile;
zeichenpos := 1;
von := 1;
zeile lesen;
pufferlaenge := length (puffer);
ggf absatz an puffer anfuegen;
END PROC zeile in puffer und zeile lesen;
PROC ggf absatz an puffer anfuegen:
IF (zeile ist nur absatz AND NOT puffer hat absatz)
OR (NOT puffer hat absatz AND only command line (puffer)
AND only command line (zeile))
THEN puffer CAT blank;
pufferlaenge := length (puffer)
ELIF puffer ist nur absatz AND (zeile SUB length (zeile)) <> " " AND
only command line (zeile)
THEN zeile CAT " "
FI.
puffer ist nur absatz:
puffer = blank.
zeile ist nur absatz:
zeile = blank.
END PROC ggf absatz an puffer anfuegen;
(****************** routinen fuer zeilenende behandlung ***********)
PROC verarbeite letztes zeichen von puffer:
zeichenpos := length (puffer);
begin of this char (puffer, zeichenpos);
zeichen := puffer SUB zeichenpos;
IF trennung vorhanden
THEN IF zeile hat richtige laenge
THEN neue zeile auffuellen und ausgabe bei zeilenende
ELSE getrennte zeilen zusammenziehen
FI
ELSE neue zeile auffuellen;
IF absatz
THEN letzter puffer war absatz := TRUE;
IF letztes kommando war macro AND macro hat absatz getaetigt
THEN zeile in puffer und zeile lesen;
initialisiere neue zeile;
ELSE ausgabe bei zeilenende;
FI
ELSE neue zeile ggf weiterfuehren
FI
FI.
neue zeile ggf weiterfuehren:
IF macro end in dieser oder naechster zeile
THEN
ELIF zeile = ""
THEN schreibe und initialisiere neue zeile;
letzter puffer war absatz := TRUE
ELIF zeilenbreite + blank breite fuer diesen schrifttyp >
aktuelle pitch zeilenlaenge
THEN loesche nachfolgende blanks;
schreibe und initialisiere neue zeile
ELIF in neuer zeile steht etwas
THEN neue zeile CAT blank;
zeilenbreite INCR blank breite fuer diesen schrifttyp
FI;
zeile in puffer und zeile lesen.
macro end in dieser oder naechster zeile:
macro works AND (pos (puffer, "#*") <> 0 OR pos (zeile, "#*") <> 0).
in neuer zeile steht etwas:
pos (neue zeile, ""33"", ""255"", 1) <> 0.
letztes kommando war macro:
pos (kommando, "macro") <> 0.
macro hat absatz getaetigt:
NOT in neuer zeile steht etwas.
END PROC verarbeite letztes zeichen von puffer;
PROC getrennte zeilen zusammenziehen:
zeichen := puffer SUB pufferlaenge;
IF NOT within kanji (puffer, pufferlaenge) AND zeichen = trennzeichen
THEN zeilenbreite DECR breite (trennzeichen);
delete char (puffer, pufferlaenge);
pufferlaenge := length (puffer);
IF ((puffer SUB pufferlaenge) = trenn k) AND ((zeile SUB 1) = "k")
THEN replace (puffer, pufferlaenge, "c");
zeilenbreite DECR breite ("k");
zeilenbreite INCR breite ("c");
FI;
zeichenpos := pufferlaenge + 1
FI;
puffer CAT zeile;
zeile lesen;
pufferlaenge := length (puffer);
ggf absatz an puffer anfuegen;
END PROC getrennte zeilen zusammenziehen;
BOOL PROC trennung vorhanden:
IF within kanji (puffer, pufferlaenge)
THEN LEAVE trennung vorhanden WITH FALSE
FI;
zeichen := puffer SUB pufferlaenge;
zeichen = trennzeichen OR wort mit bindestrich.
wort mit bindestrich:
zeichen = bindestrich AND kein leerzeichen davor
AND NOT naechstes wort ist konjunktion AND kein loser gedankenstrich.
kein leerzeichen davor:
NOT within kanji (puffer, pufferlaenge - 1) AND
(puffer SUB pufferlaenge - 1) <> blank.
naechstes wort ist konjunktion:
pos (zeile, "und") = 1
OR pos (zeile, "oder") = 1
OR pos (zeile, "bzw") = 1
OR pos (zeile, "sowie") = 1.
kein loser gedankenstrich:
pufferlaenge > 1.
END PROC trennung vorhanden;
BOOL PROC zeile hat richtige laenge:
zeilenbreite > aktuelle pitch zeilenlaenge - trennbreite
END PROC zeile hat richtige laenge;
(*********************** ausgabe routinen *******************)
PROC ende einer neuen zeile:
IF zeichenpos > 0
THEN begin of this char (puffer, zeichenpos);
FI;
zeichen := puffer SUB zeichenpos;
zeichenpos bereits verarbeitet := 0;
IF naechstes zeichen ist absatz
THEN zeichenpos := pufferlaenge;
verarbeite letztes zeichen von puffer;
LEAVE ende einer neuen zeile
ELIF zeichen = blank
THEN neue zeile auffuellen (von, zeichenpos - 1);
zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos);
von := zeichenpos;
ELIF nach zeichenpos beginnt ein neues wort
THEN neue zeile auffuellen (von, zeichenpos);
zeichenpos := pos (puffer, ""33"", ""255"", zeichenpos + 1);
von := zeichenpos
ELIF letzter puffer passte genau
THEN (* erstes zeichen des neuen puffers > zeilenbreite *)
zeichenpos := 1;
von := 1
ELSE zeichenpos bereits verarbeitet := zeichenpos;
trennung eventuell vornehmen;
IF erstes wort auf der absatzzeile laesst sich nicht trennen
THEN alte blanks := aktuelle blanks
FI
FI;
loesche nachfolgende blanks;
IF NOT in foot uebertrag
THEN schreibe und initialisiere neue zeile;
zeilenbreite und zeichenpos auf das bereits verarbeitete
zeichen setzen;
FI.
erstes wort auf der absatzzeile laesst sich nicht trennen:
pos (neue zeile, ""33"", ""255"", 1) = 0 AND (*keine buchstaben*)
length (neue zeile) > 1 AND (*einrueckung*)
(neue zeile SUB length (neue zeile)) = blank. (* Absatz *)
naechstes zeichen ist absatz:
zeichenpos + 1 = pufferlaenge AND puffer hat absatz.
nach zeichenpos beginnt ein neues wort:
(pufferlaenge > zeichenpos + 2) AND (puffer SUB zeichenpos + 1) = blank.
letzter puffer passte genau:
zeichenpos <= 0.
zeilenbreite und zeichenpos auf das bereits verarbeitete zeichen setzen:
IF zeichenpos bereits verarbeitet <> 0
THEN INT VAR bis := zeichenpos, einfuege pos := bis;
zeilenbreite um die bereits verarbeiteten zeichen erhoehen;
zeichenpos := zeichenpos bereits verarbeitet;
IF einfuege pos > 1
THEN insert char (puffer, blank, einfuege pos);
pufferlaenge := length (puffer);
von := einfuege pos + 1;
char pos move (vorwaerts)
FI;
char pos move (vorwaerts);
FI.
zeilenbreite um die bereits verarbeiteten zeichen erhoehen:
zeichenpos := zeichenpos bereits verarbeitet;
WHILE (puffer SUB bis) = kommandozeichen REP
bis := pos (puffer, kommandozeichen, bis + 1) + 1
END REP;
begin of this char (puffer, zeichenpos);
WHILE zeichenpos >= bis REP
IF (puffer SUB zeichenpos) = kommandozeichen
THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts)
ELSE zeilenbreite INCR breite (puffer, zeichenpos);
FI;
IF zeichenpos <= 1
THEN LEAVE zeilenbreite um die bereits verarbeiteten zeichen erhoehen
FI;
char pos move (rueckwaerts)
END REP.
END PROC ende einer neuen zeile;
PROC loesche nachfolgende blanks:
WHILE NOT within kanji (neue zeile, length (neue zeile)) AND
(neue zeile SUB length (neue zeile)) = blank REP
delete char (neue zeile, length (neue zeile))
END REP
END PROC loesche nachfolgende blanks;
PROC neue zeile auffuellen:
dummy := subtext (puffer, von);
neue zeile CAT dummy
END PROC neue zeile auffuellen;
PROC neue zeile auffuellen (INT CONST from, to):
dummy := subtext (puffer, from, to);
neue zeile CAT dummy
END PROC neue zeile auffuellen;
PROC schreibe neue zeile:
IF macro works
THEN IF alte neue zeile einschliesslich macro ist auszugeben
THEN schreibe textteil einschliesslich macro;
FI
ELSE schreibe;
pruefe auf abbruch
FI.
alte neue zeile:
before macro state . new line.
alter puffer:
before macro state . buffer line.
alte neue zeile einschliesslich macro ist auszugeben:
INT VAR text anf :: pos (alte neue zeile, ""33"", ""255"", 1);
text anf <> 0.
schreibe textteil einschliesslich macro:
dummy := neue zeile;
neue zeile := alte neue zeile;
IF macro hatte absatz danach
THEN neue zeile CAT " "
ELSE zeilennr INCR 1
FI;
schreibe;
neue zeile := dummy;
alte neue zeile := subtext (alte neue zeile, 1, text anf - 1).
macro hatte absatz danach:
length (alter puffer) - 1 = length (alte neue zeile) AND
(alter puffer SUB length (alter puffer)) = " ".
pruefe auf abbruch:
IF incharety = escape
THEN errorstop ("Abbruch mit ESC")
FI.
END PROC schreibe neue zeile;
PROC schreibe:
IF format file in situ
THEN insert record (eingabe);
write record (eingabe, neue zeile);
down (eingabe)
ELSE insert record (ausgabe);
write record (ausgabe, neue zeile);
down (ausgabe);
speicher ueberlauf
FI;
execute stored commands;
IF (neue zeile SUB length (neue zeile)) = blank
THEN einrueckbreite := eingestellte indentation pitch
FI.
speicher ueberlauf:
INT VAR size, used;
storage (size, used);
IF used > size
THEN errorstop ("Speicherengpaß")
FI.
END PROC schreibe;
PROC schreibe und initialisiere neue zeile:
schreibe neue zeile;
initialisiere neue zeile
END PROC schreibe und initialisiere neue zeile;
PROC ausgabe bei zeilenende:
schreibe und initialisiere neue zeile;
zeile in puffer und zeile lesen
END PROC ausgabe bei zeilenende;
PROC neue zeile auffuellen und ausgabe bei zeilenende:
neue zeile auffuellen;
schreibe und initialisiere neue zeile;
zeile in puffer und zeile lesen
END PROC neue zeile auffuellen und ausgabe bei zeilenende;
PROC initialisiere neue zeile:
einrueckung in die neue zeile;
zeilennummer mitzaehlen.
einrueckung in die neue zeile:
IF zeichenpos < pufferlaenge AND
(puffer hat absatz OR foot ohne absatz am zeilenende)
THEN neue zeile := alte blanks
ELSE neue zeile := aktuelle blanks
FI;
zeilenbreite := length (neue zeile) * einrueckbreite;
IF zeilenbreite +trennbreite +einrueckbreite >= aktuelle pitch zeilenlaenge
THEN fehler (10, "");
zeilenbreite := 0;
FI.
foot ohne absatz am zeilenende:
pos (puffer, "#foot#") > 1 AND pos (puffer, "#foot#") = length (puffer) -5.
zeilennummer mitzaehlen:
IF NOT macro works
THEN zeilennr INCR 1;
cout (zeilennr);
FI.
END PROC initialisiere neue zeile;
PROC letzte neue zeile ausgeben:
IF pos (neue zeile, ""33"", ""255"", 1) <> 0
THEN schreibe neue zeile
FI;
offene modifikationen ausgeben;
offene indizes ausgeben;
IF aktueller editor < 1
THEN referenzen ueberpruefen;
offene counter referenzen ausgeben;
FI.
offene modifikationen ausgeben:
WHILE length (modifikations speicher) <> 0 REP
dummy := (modifikations speicher SUB 1);
delete char (modifikations speicher, 1);
dummy CAT " in Zeile ";
dummy CAT text (mod zeilennr speicher ISUB 1);
delete int (mod zeilennr speicher, 1);
warnung (5, dummy)
END REP.
offene indizes ausgeben:
WHILE length (index speicher) <> 0 REP
dummy := (index speicher SUB 1);
delete char (index speicher, 1);
dummy CAT " in Zeile ";
dummy CAT text (ind zeilennr speicher ISUB 1);
delete int (ind zeilennr speicher, 1);
warnung (6, dummy)
END REP.
offene counter referenzen ausgeben:
INT VAR begin pos := pos (counter reference store, "#");
WHILE begin pos > 0 REP
INT VAR end pos := pos (counter reference store, "#", begin pos + 1);
IF (counter reference store SUB begin pos - 1) <> "u"
THEN fehler (60, subtext (counter reference store, begin pos + 1,
end pos - 1))
ELIF (counter reference store SUB begin pos - 2) <> "i"
THEN fehler (61, subtext (counter reference store, begin pos + 1,
end pos - 1))
FI;
begin pos := pos (counter reference store, "#", end pos + 1)
END REP.
END PROC letzte neue zeile ausgeben;
(*********************** silbentrenn routinen *******************)
INT PROC position von (TEXT CONST such zeichen, INT CONST richtung,
INT VAR anz zeich, breite der z):
INT VAR index :: zeichenpos;
TEXT VAR akt z;
anz zeich := 0;
breite der z := 0;
WHILE index > 1 AND index < pufferlaenge REP
akt z := puffer SUB index;
IF akt z = such zeichen
THEN LEAVE position von WITH index
ELIF akt z = kommandozeichen
THEN ueberspringe das kommando (puffer, index, richtung);
IF nur ein kommandozeichen gefunden
THEN gehe nur bis erstes kommandozeichen
ELIF index <= 1 OR index >= pufferlaenge
THEN LEAVE position von WITH index
FI
ELSE anz zeich INCR 1;
breite der z INCR breite (puffer, index)
FI;
char pos move (index, richtung)
END REP;
anz zeich INCR 1;
breite der z INCR breite (puffer, index);
index.
nur ein kommandozeichen gefunden:
(puffer SUB index) <> kommandozeichen.
gehe nur bis erstes kommandozeichen:
index := zeichenpos; anz zeich := 0; breite der z := 0;
WHILE (puffer SUB index) <> kommandozeichen REP
anz zeich INCR 1;
breite der z INCR breite (puffer, index);
char pos move (index, richtung)
END REP;
IF richtung <> rueckwaerts
THEN index DECR 1
FI;
LEAVE position von WITH index.
END PROC position von;
PROC ueberspringe das kommando (TEXT CONST t, INT VAR i, INT CONST richtung):
REP
i INCR richtung;
IF within kanji (t, i)
THEN i INCR richtung
FI
UNTIL (t SUB i) = kommandozeichen OR i <= 1 OR i >= length (t) END REP.
END PROC ueberspringe das kommando;
PROC trennung eventuell vornehmen:
INT VAR xwort1, ywort1,
anz zeichen davor,
breite davor;
IF macro works
THEN fehler (6, "")
FI;
trennsymbol := trennzeichen;
wortanfang := position von
(blank, rueckwaerts, anz zeichen davor, breite davor);
bereite neue zeile bis wortanfang auf;
IF trennung sinnvoll
THEN versuche zu trennen
ELSE zeichenpos := wortanfang
FI.
bereite neue zeile bis wortanfang auf:
IF wortanfang > 1
THEN wortanfang INCR 1
FI;
IF von > wortanfang
THEN eliminiere zeichen in neuer zeile bis wortanfang
ELSE neue zeile auffuellen (von, wortanfang - 1)
FI;
von := wortanfang.
eliminiere zeichen in neuer zeile bis wortanfang:
INT VAR y :: length (neue zeile);
begin of this char (neue zeile, y);
WHILE y >= 1 REP
IF (neue zeile SUB y) = kommandozeichen
THEN ueberspringe das kommando (neue zeile, y, rueckwaerts)
FI;
char pos move (neue zeile, y, rueckwaerts)
UNTIL (neue zeile SUB y) = blank END REP;
neue zeile := subtext (neue zeile, 1, y).
trennung sinnvoll:
anz zeichen davor > 2 AND breite davor > trennbreite.
versuche zu trennen:
INT CONST k := zeichenpos;
naechste zeile ggf heranziehen;
zeichenpos := k;
wortteile holen;
trenn (trennwort ohne komm, wort1 ohne komm, trennsymbol,
max trennlaenge ohne komm);
wort1 mit komm ermitteln;
IF lineform mode
THEN wort2 := subtext (trennwort, length (wort1) + 1, max trennlaenge);
display vorherige zeile bis wortanfang;
schreibe nicht trennbaren teil des trennwortes;
schreibe zeile nach trennwort;
skip input;
interaktive worttrennung
FI;
neue zeile mit trennwort versehen;
IF wort1 <> "" AND NOT lineform mode
THEN note (zeilen nr); note (": ");
note (trennwort);
note (" --> ");
note (wort1); note (trennsymbol);
wort2 := subtext (trennwort, length (wort1) + 1);
note (wort2);
note line
FI.
wortteile holen:
zeichenpos durch trennzeichenbreite verschieben;
wort1 := subtext (puffer, wortanfang, zeichenpos);
max trennlaenge := length (wort1);
wortende ermitteln;
wort2 := subtext (puffer, zeichenpos, wortende);
trennwort := subtext (puffer, wortanfang, wortende);
trennwort ohne komm ermitteln;
wort1 ohne komm := subtext (trennwort ohne komm, 1, anz zeichen davor);
max trenn laenge ohne komm := anz zeichen davor.
trennwort ohne komm ermitteln:
trennwort ohne komm := trennwort;
WHILE pos (trennwort ohne komm, kommando zeichen) <> 0 REP
INT CONST komm anf := pos (trennwort ohne komm, kommando zeichen),
komm ende:= pos (trennwort ohne komm, kommando zeichen,
komm anf + 1);
IF komm ende = 0
THEN LEAVE trennwort ohne komm ermitteln
FI;
dummy := subtext (trennwort ohne komm, komm ende + 1);
trennwort ohne komm := subtext (trennwort ohne komm, 1, komm anf - 1);
trennwort ohne komm CAT dummy;
END REP.
wort1 mit komm ermitteln:
IF length (wort1 ohne komm) = 0
THEN wort1 := "";
LEAVE wort1 mit komm ermitteln
FI;
INT VAR index ohne := 0,
index mit := 0;
REP
index ohne INCR 1;
index mit INCR 1;
WHILE (wort1 SUB index mit) = kommando zeichen REP
index mit := pos (wort1, kommando zeichen, index mit + 1) + 1
END REP;
UNTIL index ohne >= length (wort1 ohne komm) END REP;
wort1 := subtext (wort1, 1, index mit).
zeichenpos durch trennzeichenbreite verschieben:
REP
zeichen := puffer SUB zeichenpos;
IF zeichen = kommandozeichen
THEN ueberspringe das kommando (puffer, zeichenpos, rueckwaerts);
char pos move (rueckwaerts)
ELIF zeichenpos < wortanfang + 1
THEN zeichenpos := wortanfang;
LEAVE trennung eventuell vornehmen
ELSE zeilenbreite DECR breite (puffer, zeichenpos);
anz zeichen davor DECR 1;
char pos move (rueckwaerts);
IF zeilenbreite+breite(trennzeichen) <= aktuellepitchzeilenlaenge
AND (puffer SUB zeichenpos) <> kommandozeichen
THEN LEAVE zeichenpos durch trennzeichenbreite verschieben
FI
FI;
END REP.
wortende ermitteln:
INT VAR x1, x2;
wortende := position von (blank, 1, x1, x2);
IF pufferlaenge > wortende
THEN wortende DECR 1
FI.
display vorherige zeile bis wortanfang:
dummy := neue zeile;
dummy CAT subtext (puffer, von, wortanfang - 2);
line ;
outsubtext (dummy, length (dummy) - 78).
schreibe nicht trennbaren teil des trennwortes:
line ;
get cursor (xwort1, ywort1);
IF length (trennwort) < 70
THEN cursor (max trennlaenge + 4, ywort1);
outsubtext (trennwort, max trennlaenge + 1)
FI.
schreibe zeile nach trennwort:
dummy := subtext (puffer, wortende + 1);
get cursor (trennwort endepos, ywort1);
IF length (trennwort) >= 70
THEN
ELIF length (dummy) > 75 - trennwort ende pos
THEN outsubtext (dummy, 1, 75 - trennwort endepos);
ELSE out (dummy);
IF (dummy SUB length (dummy)) = blank
THEN cursor (78, ywort1);
out (begin mark);
out (end mark)
FI
FI.
trennwort endepos:
xwort1.
interaktive worttrennung:
REP
out (return);
schreibe erstes wort;
get cursor (xwort1, ywort1);
schreibe trennung;
schreibe zweites wort;
schreibe rest bei zu langem trennwort;
cursor (xwort1, ywort1);
hole steuerzeichen und veraendere worte
END REP.
schreibe erstes wort:
out (begin mark);
IF length (trennwort) < 70
THEN out (wort1)
ELSE outsubtext (wort1, length (wort1) - 60)
FI.
schreibe trennung:
IF ck vorhanden
THEN out (links); out ("k");
FI;
out (trennsymbol).
schreibe zweites wort:
IF length (trennwort) < 70
THEN out (wort2)
ELSE outsubtext (wort2, 1, 70 - xwort1);
FI;
out (end mark).
schreibe rest bei zu langem trennwort:
IF length (trennwort) >= 70
THEN INT VAR xakt pos;
out (cl eol);
get cursor (xakt pos, ywort1);
outsubtext (trennwort, max trennlaenge + 1,
max trennlaenge + 1 + (78 - xakt pos))
FI.
ck vorhanden:
(wort1 SUB length (wort1)) = "c" AND
(trennwort SUB (length (wort1) + 1)) = "k".
hole steuerzeichen und veraendere worte:
TEXT VAR steuerzeichen;
inchar (steuerzeichen);
IF steuerzeichen = links
THEN nach links
ELIF steuerzeichen = rechts
THEN nach rechts
ELIF steuerzeichen = hop
THEN sprung
ELIF steuerzeichen = return
THEN line ;
LEAVE interaktive worttrennung
ELIF steuerzeichen = escape
THEN errorstop ("Abbruch mit ESC")
ELIF code (steuerzeichen) < 32
THEN
ELSE trennsymbol := steuerzeichen;
LEAVE hole steuerzeichen und veraendere worte
FI;
IF wort1 = ""
OR (wort1 SUB length (wort1)) = bindestrich
THEN trennsymbol := blank
ELSE trennsymbol := trennzeichen
FI.
nach links:
TEXT VAR ein zeichen;
INT VAR position;
IF length (wort1) <> 0
THEN position := length (wort1);
IF (wort1 SUB position) = kommando zeichen
THEN ueberspringe das kommando (wort1, position, rueckwaerts);
FI;
position DECR 1;
wort1 := subtext (trennwort, 1, position);
wort2 := subtext (trennwort, position + 1, max trennlaenge);
IF rechtes teilwort mit bindestrich
THEN ein zeichen := (wort1 SUB length (wort1));
delete char (wort1, length (wort1));
insert char (wort2, ein zeichen, 1)
FI
FI.
nach rechts:
IF length (wort1) < max trennlaenge
THEN position := length (wort1) + 1;
IF (trennwort SUB position) = kommando zeichen
THEN ueberspringe das kommando (trennwort, position, +1);
FI;
wort1 := subtext (trennwort, 1, position);
wort2 := subtext (trennwort, position + 1, max trennlaenge);
IF rechtes teilwort mit bindestrich
THEN wort1 CAT bindestrich;
delete char (wort2, 1)
FI
FI.
rechtes teilwort mit bindestrich:
(wort2 SUB 1) = bindestrich AND
pos (buchstaben, wort1 SUB length (wort1)) <> 0.
sprung:
inchar(steuerzeichen);
IF steuerzeichen = rechts
THEN wort1 := subtext (trennwort, 1, max trennlaenge);
wort2 := ""
ELIF steuerzeichen = links
THEN wort1 := "";
wort2 := subtext (trennwort, 1, max trennlaenge)
FI.
neue zeile mit trennwort versehen:
IF wort1 = ""
THEN keine trennung
ELSE zeichenpos := wortanfang + length (wort1);
mit trennsymbol trennen;
von := zeichenpos
FI.
keine trennung:
IF wort ist zu lang fuer limit
THEN warnung (7, trennwort);
neue zeile CAT trennwort;
zeichenpos := wortende + 1;
zeichenpos bereits verarbeitet := 0;
von := zeichenpos
ELSE loesche nachfolgende blanks;
zeichenpos := wortanfang
FI.
wort ist zu lang fuer limit:
length (alte blanks) * einrueckbreite + breite davor + trennbreite
>= aktuelle pitch zeilenlaenge.
mit trennsymbol trennen:
IF (wort1 SUB length (wort1)) = "c" AND
(trennwort SUB (length (wort1) + 1)) = "k"
THEN replace (wort1, length (wort1), trenn k)
FI;
neue zeile CAT wort1;
IF trennsymbol <> blank
THEN neue zeile CAT trennsymbol
FI.
END PROC trennung eventuell vornehmen;
PROC naechste zeile ggf heranziehen:
IF puffer hat absatz
OR puffer hat noch mindestens zwei woerter
OR zeile hat eine foot anweisung
OR in foot uebertrag
THEN LEAVE naechste zeile ggf heranziehen
ELIF trennung vorhanden
THEN IF zeichenpos < pufferlaenge
THEN zeilenbreite INCR breite (trennzeichen)
FI;
getrennte zeilen zusammenziehen;
LEAVE naechste zeile ggf heranziehen
FI;
puffer CAT blank;
puffer CAT zeile;
zeile lesen;
pufferlaenge := length (puffer);
ggf absatz an puffer anfuegen.
puffer hat noch mindestens zwei woerter:
INT VAR anz :: 0, i :: zeichenpos;
WHILE pos (puffer, " ", i) > 0 REP
anz INCR 1;
i := pos (puffer, " ", i) + 1
END REP;
anz > 1.
zeile hat eine foot anweisung:
pos (puffer, "#foot") <> 0.
END PROC naechste zeile ggf heranziehen;
(******************** initialisierungs routine *******************)
PROC form initialisieren (TEXT CONST datei):
kommando liste :=
"type:1.1linefeed:3.1limit:4.1free:5.1page:6.01on:8.1off:9.1pagenr:10.2
pagelength:11.1start:12.2foot:13.0end:14.0head:15.0headeven:16.0
headodd:17.0bottom:18.0bottomeven:19.0bottomodd:20.0block:21.0";
kommando liste CAT
"material:22.1columns:23.2columnsend:24.0ib:25.012ie:28.012topage:31.1
goalpage:32.1count:33.01setcount:35.1value:36.01table:38.0tableend:39.0
rpos:40.1lpos:41.1cpos:42.1dpos:43.2bpos:44.2clearpos:45.01right:47.0";
kommando liste CAT
"center:48.0skip:49.0skipend:50.0u:51.0d:52.0e:53.0headon:54.0headoff:55.0
bottomon:56.0bottomoff:57.0countperpage:58.0fillchar:59.1mark:60.2
markend:61.0pageblock:62.0b:63.0counter:64.12setcounter:66.2putcounter:67.01
storecounter:69.1";
kommando liste CAT
"ub:70.0ue:71.0fb:72.0fe:73.0";
line ;
erste fehlerzeilennr := 0;
anz tabs := 0;
zeilennr := 0;
zeilenbreite := 0;
anz blanks freihalten := 3;
herkunftsreferenzen := "#";
zielreferenzen := "#";
aktuelle blanks := "";
font nr speicher := "";
modifikationsspeicher := "";
mod zeilennr speicher := "";
index speicher := "";
ind zeilennr speicher := "";
counter numbering store := "";
counter reference store := "";
command store := "";
kommando := "";
neue zeile := "";
zeile := "";
puffer := " ";
macro works := FALSE;
in tabelle := FALSE;
in d und e verarbeitung := FALSE;
kommandos speichern := TRUE;
in foot := FALSE;
in foot uebertrag := FALSE;
test ob font table vorhanden;
bildschirm initialisieren;
zeile lesen;
zeile in puffer und zeile lesen;
einrueckung zweite zeile := "xxx";
limit und type ggf anfragen;
einrueckbreite := eingestellte indentation pitch ;
initialisiere neue zeile;
IF einrueckung zweite zeile <> "xxx"
THEN aktuelle blanks := einrueckung zweite zeile
FI.
test ob font table vorhanden:
INT VAR xxx :: x step conversion (0.0).
bildschirm initialisieren:
IF online
THEN init
FI.
init:
page;
IF lineform mode
THEN put ("LINEFORM")
ELSE put ("AUTOFORM")
FI;
put ("(für"); put (lines (eingabe)); put ("Zeilen):");
put (datei);
cursor (1, 3).
END PROC form initialisieren;
PROC limit und type ggf anfragen:
conversion (limit in cm, aktuelle pitch zeilenlaenge);
IF ask type and limit
THEN type und limit setzen
ELSE alter schriftname := kein vorhandener schriftname;
stelle font ein
FI;
REAL VAR x :: limit in cm;
conversion (x, aktuelle pitch zeilenlaenge);
IF x = fehler wert
THEN limit in cm := 16.0;
conversion (limit in cm, aktuelle pitch zeilenlaenge)
ELSE limit in cm := x
FI;
trennbreite setzen.
type und limit setzen:
LET type text = "#type (""",
limit text = "#limit (",
kommando ende text = ")#",
kein vorhandener schriftname = "#####";
IF type und limit anweisungen nicht vorhanden
THEN type und limit fragen
ELSE hole font;
alter schriftname := kein vorhandener schriftname
FI.
type und limit fragen:
type anfragen;
type in neue zeile;
limit anfragen;
limit in neue zeile;
IF NOT format file in situ
THEN schreibe neue zeile;
zeilen nr INCR 1
FI;
IF NOT puffer hat absatz
THEN einrueckung zweite zeile := aktuelle blanks;
aktuelle blanks := alte blanks;(* Einrueckung fuer die erste zeile*)
FI;
line.
type und limit anweisungen nicht vorhanden:
(pos (puffer, type text) <> 1 OR pos (puffer, "limit") < 12).
type anfragen:
put ("Bitte Schrifttyp :");
IF font table name = font table
THEN dummy := font (font nr);
ELSE dummy := font (1);
font table name := font table
FI;
REP
editget (dummy);
IF font exists (dummy)
THEN alter schriftname := dummy;
font nr := font (dummy);
hole font;
LEAVE type anfragen
ELSE line ;
put ("ERROR: unbekannter Schrifttyp");
line (2);
put ("Schrifttyp bitte nochmal:")
FI
END REP.
type in neue zeile:
neue zeile := type text;
neue zeile CAT dummy;
neue zeile CAT """";
neue zeile CAT kommando ende text.
limit anfragen:
line ;
put ("Zeilenbreite (in cm):");
dummy := text (limit in cm);
REP
editget (dummy);
limit in cm := real (dummy);
IF last conversion ok AND pos (dummy, ".") <> 0
THEN LEAVE limit anfragen
ELSE line ;
put ("ERROR: Falsche Angabe");
line (2);
put ("Zeilenbreite (in cm) bitte nochmal:");
FI
END REP.
limit in neue zeile:
neue zeile CAT limit text;
neue zeile CAT dummy;
neue zeile CAT kommando ende text;
neue zeile CAT " ".
END PROC limit und type ggf anfragen;
PROC start form (TEXT CONST datei):
IF NOT format file in situ
THEN last param (datei);
FI;
disable stop;
dateien assoziieren;
zeilen form (datei);
IF is error
THEN fehlerbehandlung
ELSE datei neu nach alt kopieren
FI;
zwischendatei loeschen;
enable stop;
col (eingabe, 1);
IF aktueller editor > 0
THEN set range (file, alter bereich)
FI;
IF anything noted
THEN IF aktueller editor = 0
THEN to line (eingabe, erste fehler zeilen nr);
ELSE alles neu
FI;
note edit (eingabe)
ELIF NOT format file in situ
THEN to line (eingabe, 1)
FI.
dateien assoziieren:
IF format file in situ
THEN
ELIF exists (datei)
THEN IF subtext (datei, length (datei) - 1) = ".p"
THEN errorstop
("'.p'-Datei kann nicht mit lineform bearbeitet werden")
FI;
eingabe := sequential file (modify, datei);
ausgabe datei einrichten
ELSE errorstop ("Datei existiert nicht")
FI;
to line (eingabe, 1);
col (eingabe, 1).
ausgabe datei einrichten:
ds := nilspace;
ausgabe := sequential file (modify, ds);
to line (ausgabe, 1);
copy attributes (eingabe, ausgabe).
fehlerbehandlung:
put error;
clear error;
font nr := 1;
font table name := "";
limit in cm := 16.0;
IF format file in situ
THEN insert record (eingabe);
write record (eingabe, neue zeile);
down (eingabe);
insert record (eingabe);
write record (eingabe, puffer);
down (eingabe);
insert record (eingabe);
write record (eingabe, zeile)
FI.
datei neu nach alt kopieren:
IF NOT format file in situ
THEN forget (datei, quiet);
copy (ds, datei);
eingabe := sequential file (modify, datei)
FI.
zwischendatei loeschen:
IF NOT format file in situ
THEN forget (ds)
FI.
END PROC start form;
(************** line/autoform fuer benannte Dateien ******************)
PROC lineform:
IF aktueller editor > 0
THEN IF mark
THEN editor bereich bearbeiten
ELSE errorstop ("kein markierter Bereich")
FI
ELSE lineform (last param)
FI.
editor bereich bearbeiten:
disable stop;
file := editfile;
set marked range (file, alter bereich);
lineform (file);
enable stop;
END PROC lineform;
PROC lineform (TEXT CONST datei):
ask type and limit := TRUE;
lineform mode := TRUE;
format file in situ := FALSE;
start form (datei)
END PROC lineform;
PROC autoform:
IF aktueller editor > 0
THEN IF mark
THEN editor bereich bearbeiten
ELSE errorstop ("kein markierter Bereich")
FI
ELSE auto form (last param)
FI.
editor bereich bearbeiten:
disable stop;
file := editfile;
set marked range (file, alter bereich);
autoform (file);
enable stop
END PROC autoform;
PROC autoform (TEXT CONST datei):
ask type and limit := TRUE;
lineform mode := FALSE;
format file in situ := FALSE;
start form (datei)
END PROC autoform;
(******************** line/autoform fuer files ************************)
PROC lineform (FILE VAR f):
enable stop;
eingabe := f;
format file in situ := TRUE;
ask type and limit := TRUE;
lineform mode := TRUE;
start form ("");
END PROC lineform;
PROC autoform (FILE VAR f):
enable stop;
eingabe := f;
format file in situ := TRUE;
ask type and limit := TRUE;
lineform mode := FALSE;
start form ("");
END PROC autoform;
PROC lineform (FILE VAR f, TEXT CONST type name, REAL CONST file limit):
eingabe := f;
format file in situ := TRUE;
lineform mode := TRUE;
ask type and limit := FALSE;
par1 := type name;
limit in cm := file limit;
start form ("");
END PROC lineform;
PROC autoform (FILE VAR f, TEXT CONST type name, REAL CONST file limit):
eingabe := f;
format file in situ := TRUE;
lineform mode := FALSE;
ask type and limit := FALSE;
par1 := type name;
limit in cm := file limit;
start form ("");
END PROC autoform;
END PACKET liner;
(*
REP
copy("lfehler","zz");
IF yes ("autoform")
THEN autoform ("zz")
ELSE lineform ("zz")
FI;
edit("zz");
forget("zz")
UNTIL yes ("ENDE") ENDREP;
*)