From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001
From: Lars-Dominik Braun <lars@6xq.net>
Date: Mon, 4 Feb 2019 13:09:03 +0100
Subject: Initial import
---
system/std.zusatz/1.8.7/src/referencer | 1077 ++++++++++++++++++++++++++++++++
1 file changed, 1077 insertions(+)
create mode 100644 system/std.zusatz/1.8.7/src/referencer
(limited to 'system/std.zusatz/1.8.7/src/referencer')
diff --git a/system/std.zusatz/1.8.7/src/referencer b/system/std.zusatz/1.8.7/src/referencer
new file mode 100644
index 0000000..2ee65e4
--- /dev/null
+++ b/system/std.zusatz/1.8.7/src/referencer
@@ -0,0 +1,1077 @@
+(* ------------------- VERSION 10 vom 01.08.86 -------------------- *)
+PACKET referencer errors DEFINES report referencer error:
+
+(* Programm zur Fehlerbehandlung des referencers.
+ Autor: Rainer Hahn *)
+
+TEXT VAR fehlerdummy,
+ message;
+
+PROC report referencer error (INT CONST error nr,
+ INT CONST line nr,
+ TEXT CONST addition):
+
+ einfache fehlermeldung aufbauen;
+ diese auf terminal ausgeben;
+ fehlermeldung in fehlerdatei ausgeben.
+
+einfache fehlermeldung aufbauen:
+ message := "WARNUNG in Zeile ";
+ message CAT text (line nr);
+ message CAT " : ";
+ message CAT simple message.
+
+diese auf terminal ausgeben:
+ line ;
+ putline (message).
+
+fehlermeldung in fehlerdatei ausgeben:
+ note (message);
+ note line ;
+ fehlerdummy := " >>> ";
+ fehlerdummy CAT zusatz;
+ note (fehlerdummy);
+ note line.
+
+simple message:
+ SELECT error nr OF
+ CASE 1: "Text Denoter ueber mehr als eine Zeile"
+ CASE 2: "Nicht beendeter Text Denoter bei Programmende"
+ CASE 3: "Kommentar ueber mehr als eine Zeile"
+ CASE 4: "Nicht beendeter Kommentar bei Programmende"
+ CASE 5: "Ueberdeckung"
+ CASE 6, 9: "Refinement mehrmals eingesetzt"
+ CASE 7, 10: "Refinement wird nicht aufgerufen"
+ CASE 8: "Objekt wird nicht angesprochen"
+ OTHERWISE ""
+ ENDSELECT.
+
+zusatz:
+ SELECT error nr OF
+ CASE 1, 2, 3, 4: "Ueber " + addition + " Zeilen"
+ CASE 5: addition
+ CASE 6, 7, 8: addition
+ CASE 9, 10: addition + " in mindestens einer Prozedur"
+ OTHERWISE "interner Fehler: HRZ Bielefeld benachrichtigen!"
+ END SELECT.
+END PROC report referencer error
+END PACKET referencer errors;
+(************************************************************************)
+
+PACKET name table handling
+ DEFINES NAMETABLE,
+ empty name table,
+ put name,
+ get name,
+ dump table:
+
+(* Programm zur Speicherung von Namen.
+ Autor: Rainer Hahn *)
+
+LET hash table length = 1024,
+ hash table length minus one = 1023,
+ start of name table = 255,
+ name table length = 2000;
+
+TYPE NAMETABLE = STRUCT (INT number of entries,
+ ROW hash table length INT hash table,
+ ROW name table length INT next,
+ ROW name table length TEXT name table);
+
+TEXT VAR dummy, f;
+
+PROC put name (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ INT VAR errechneter index;
+ hash (name, errechneter index);
+ IF noch kein eintrag
+ THEN gaenzlich neuer eintrag
+ ELSE name in vorhandener kette
+ FI.
+
+noch kein eintrag:
+ n . hash table [errechneter index] = 0.
+
+gaenzlich neuer eintrag:
+ n . hash table [errechneter index] := n . number of entries;
+ neuer eintrag (n, name, pointer).
+
+name in vorhandener kette:
+ INT VAR dieser eintrag :: n. hash table [errechneter index];
+ REP
+ IF name ist vorhanden
+ THEN pointer := dieser eintrag;
+ LEAVE put name
+ ELIF kette zu ende
+ THEN neuer eintrag an vorhandene kette anketten;
+ neuer eintrag (n, name, pointer);
+ LEAVE put name
+ ELSE naechster eintrag in der kette
+ FI
+ END REP.
+
+name ist vorhanden:
+ n . name table [dieser eintrag] = name.
+
+kette zu ende:
+ n . next [dieser eintrag] = 0.
+
+neuer eintrag an vorhandene kette anketten:
+ n . next [dieser eintrag] := n . number of entries.
+
+naechster eintrag in der kette:
+ dieser eintrag := n . next [dieser eintrag].
+END PROC put name;
+
+PROC neuer eintrag (NAMETABLE VAR n, TEXT CONST name, INT VAR pointer):
+ n . name table [n . number of entries] := name;
+ n . next [n . number of entries] := 0;
+ pointer := n . number of entries;
+ n . number of entries INCR 1;
+ IF n . number of entries > name table length
+ THEN errorstop ("volle Namenstabelle")
+ FI
+END PROC neuer eintrag;
+
+PROC hash (TEXT CONST name, INT VAR index) :
+ INT VAR i;
+ index := code (name SUB 1);
+ FOR i FROM 2 UPTO length (name) REP
+ addmult cyclic
+ ENDREP.
+
+addmult cyclic :
+ index INCR index ;
+ IF index > hash table length minus one
+ THEN wrap around
+ FI;
+ index := (index + code (name SUB i)) MOD hash table length.
+
+wrap around :
+ index DECR hash table length minus one
+ENDPROC hash ;
+
+PROC get name (NAMETABLE CONST n, INT CONST index, TEXT VAR t):
+ IF index < n . number of entries AND index >= start of name table
+ THEN t := n . name table [index]
+ ELSE errorstop ("Interner Fehler 1")
+ FI
+END PROC get name;
+
+PROC empty name table (NAMETABLE VAR n):
+INT VAR i;
+ n . number of entries := start of name table;
+ FOR i FROM 1 UPTO hash table length REP
+ n . hash table [i] := 0
+ END REP
+END PROC empty name table;
+
+PROC dump table (NAMETABLE CONST n):
+ line ;
+ put ("Bitte Name der Datei, in die die Namenstabelle gehen soll:");
+ getline (f);
+ line ;
+ file assoziieren;
+ dump namens ketten;
+ zusammenfassung.
+
+file assoziieren:
+ FILE VAR file :: sequential file (output, f).
+
+dump namens ketten:
+ INT VAR i,
+ anz hash eintraege :: 0,
+ kette 3 eintraege :: 0;
+ FOR i FROM 1 UPTO hash table length REP
+ IF n . hash table [i] <> 0
+ THEN anz hash eintraege INCR 1;
+ INT VAR naechster eintrag :: n . hash table [i];
+ dump hash eintrag;
+ ketten eintraege
+ FI
+ END REP.
+
+dump hash eintrag:
+ dummy := text (i);
+ WHILE length (dummy) < 4 REP dummy CAT " " END REP;
+ dummy CAT ": ".
+
+ketten eintraege:
+ INT VAR anz eintraege pro kette :: 0;
+ WHILE naechster eintrag > 0 REP
+ anz eintraege pro kette INCR 1;
+ dummy CAT " ";
+ dummy CAT text (naechster eintrag);
+ dummy CAT " -> ";
+ dummy CAT n . name table [naechster eintrag];
+ naechster eintrag := n . next [naechster eintrag];
+ END REP;
+ IF anz eintraege pro kette > 2
+ THEN kette 3 eintraege INCR 1
+ FI;
+ putline (file, dummy).
+
+zusammenfassung:
+ statistik ueberschrift;
+ anzahl hash eintraege;
+ anzahl namens eintraege;
+ verkettungsfaktor;
+ anzahl laengerer ketten.
+
+statistik ueberschrift:
+ line (file, 2);
+ dummy := " ---------- ";
+ dummy CAT "S T A T I S T I K:";
+ dummy CAT " ---------- ";
+ putline (file, dummy);
+ line (file, 2).
+
+anzahl hash eintraege:
+ dummy := "Anzahl Hash-Eintraege (max. ";
+ dummy CAT text (hash table length);
+ dummy CAT "): ";
+ dummy CAT text (anz hash eintraege);
+ putline (file, dummy).
+
+anzahl namens eintraege:
+ dummy := "Anzahl Namen (max. ";
+ dummy CAT text (name table length - start of name table + 1);
+ dummy CAT "): ";
+ dummy CAT text (n . number of entries - start of name table);
+ putline (file, dummy).
+
+verkettungsfaktor:
+ dummy := "Verkettungsfaktor (Anzahl Namen / Anzahl Ketten): ";
+ dummy CAT text (real (n . number of entries - start of name table) /
+ real (anz hash eintraege));
+ putline (file, dummy).
+
+anzahl laengerer ketten:
+ dummy := "Anzahl Ketten > 2 Eintraege: ";
+ dummy CAT text (kette 3 eintraege);
+ putline (file, dummy).
+END PROC dump table;
+END PACKET name table handling;
+(***************************************************************************)
+
+PACKET scanner DEFINES init scanning,
+ init name table with,
+ dump name table,
+ get name,
+ end scanning,
+ line number,
+ symbol:
+
+(* Programm zum scannen von ELAN-Programmen.
+ Autor: Rainer Hahn *)
+
+FILE VAR eingabe;
+
+DATASPACE VAR ds alt := nilspace,
+ ds neu := nilspace;
+
+BOUND NAMETABLE VAR tabelle;
+
+TEXT VAR zeile,
+ zeichen,
+ dummy;
+
+LET end of program = ""30"",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ delimiter = 4,
+ punkt = 46,
+ doppelpunkt = 58,
+ init symbol = 30,
+ assign symbol = 31;
+
+INT VAR zeilen nr,
+ zeichen pos;
+
+PROC init name table with (TEXT CONST worte):
+INT VAR index;
+ forget (ds alt);
+ ds alt := nilspace;
+ tabelle := dsalt;
+ empty name table (CONCR (tabelle));
+ INT VAR anf :: 1,
+ ende :: pos (worte, ",", 1);
+ WHILE ende > 0 REP
+ dummy := subtext (worte, anf, ende - 1);
+ put name (CONCR (tabelle), dummy, index);
+ anf := ende + 1;
+ ende := pos (worte, ",", ende + 1)
+ END REP;
+ dummy := subtext (worte, anf);
+ put name (CONCR (tabelle), dummy, index)
+END PROC init name table with;
+
+PROC init scanning (TEXT CONST f):
+ IF exists (f)
+ THEN namenstabelle holen;
+ erste zeile lesen
+ ELSE errorstop ("Datei existiert nicht")
+ FI.
+
+namenstabelle holen:
+ forget (ds neu);
+ ds neu := ds alt;
+ tabelle := ds neu.
+
+erste zeile lesen:
+ eingabe := sequential file (input, f);
+ IF eof (eingabe)
+ THEN errorstop ("Datei ist leer")
+ ELSE zeile := "";
+ zeilen nr := 0;
+ zeile lesen;
+ naechstes non blank zeichen
+ FI
+END PROC init scanning;
+
+PROC dump name table:
+ dump table (CONCR (tabelle))
+END PROC dump name table;
+
+PROC end scanning (TEXT CONST f):
+ IF anything noted
+ THEN eingabe := sequential file (modify, f);
+ note edit (eingabe)
+ FI
+END PROC end scanning;
+
+PROC get name (INT CONST index, TEXT VAR t):
+ get name (CONCR (tabelle), index, t)
+END PROC get name;
+
+PROC zeile lesen:
+ getline (eingabe, zeile);
+ zeilen nr INCR 1;
+ cout (zeilen nr);
+ zeichen pos := 0
+END PROC zeile lesen;
+
+PROC naechstes non blank zeichen:
+ REP
+ zeichen pos := pos (zeile, ""33"", ""254"", zeichen pos + 1);
+ IF zeichen pos <> 0
+ THEN zeichen := (zeile SUB zeichen pos);
+ LEAVE naechstes non blank zeichen
+ ELIF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes non blank zeichen
+ ELSE zeile lesen
+ FI
+ END REP.
+END PROC naechstes non blank zeichen;
+
+PROC naechstes zeichen:
+ IF zeichen pos > length (zeile)
+ THEN IF eof (eingabe)
+ THEN zeichen := end of program;
+ LEAVE naechstes zeichen
+ ELSE zeile lesen
+ FI
+ FI;
+ zeichenpos INCR 1;
+ zeichen := zeile SUB zeichenpos
+END PROC naechstes zeichen;
+
+INT PROC line number:
+ IF zeichenpos = pos (zeile, ""33"", ""254"", 1)
+ THEN zeilen nr - 1
+ ELSE zeilen nr
+ FI
+END PROC line number;
+
+PROC symbol (INT VAR symb, type):
+ REP
+ suche naechstes checker symbol
+ END REP.
+
+suche naechstes checker symbol:
+ SELECT code (zeichen) OF
+ CASE 30: (* end of programn *)
+ symb := eop;
+ type := eop;
+ LEAVE symbol
+ CASE 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
+ 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122:
+ (* small letters *)
+ identifier aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := identifier;
+ LEAVE symbol
+ CASE 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81,
+ 82, 83, 84, 85, 86, 87, 88, 89, 90: (* large letters *)
+ schluesselwort aufsammeln;
+ put name (CONCR (tabelle), dummy, symb);
+ type := keyword;
+ LEAVE symbol
+ CASE 34: (* " *)
+ skip text denoter
+ CASE 40: (* ( *)
+ IF (zeile SUB zeichen pos + 1) = "*"
+ THEN skip comment
+ ELSE symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol;
+ FI
+ CASE 58: (* : *)
+ IF (zeile SUB zeichenpos + 1) = "="
+ THEN symb := assign symbol;
+ zeichenpos INCR 1
+ ELIF (zeile SUB zeichenpos + 1) = ":"
+ THEN symb := init symbol;
+ zeichenpos INCR 1
+ ELSE symb := doppelpunkt
+ FI;
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ CASE 48, 49, 50, 51, 52, 53, 54, 55, 56, 57: (* 0 - 9 *)
+ int denoter skippen;
+ IF zeichen = "."
+ THEN naechstes non blank zeichen;
+ IF digit
+ THEN real denoter skippen
+ ELSE symb := punkt;
+ type := delimiter;
+ LEAVE symbol
+ FI
+ FI
+ CASE 41, 44, 46, 59, 61: (* ) , . ; = *)
+ symb := code (zeichen);
+ type := delimiter;
+ naechstes non blank zeichen;
+ LEAVE symbol
+ OTHERWISE naechstes non blank zeichen
+ END SELECT.
+END PROC symbol;
+
+PROC real denoter skippen:
+ int denoter skippen;
+ IF zeichen = "e"
+ THEN naechstes non blank zeichen;
+ int denoter skippen
+ FI
+END PROC real denoter skippen;
+
+PROC int denoter skippen:
+ naechstes non blank zeichen;
+ WHILE zeichen >= "0" AND zeichen <= "9" REP
+ naechstes non blank zeichen
+ ENDREP;
+ zeichenpos DECR 1;
+ naechstes non blank zeichen
+END PROC int denoter skippen;
+
+PROC identifier aufsammeln:
+ dummy := zeichen;
+ REP
+ naechstes non blank zeichen;
+ IF small letter or digit
+ THEN dummy CAT zeichen
+ ELSE LEAVE identifier aufsammeln
+ FI
+ END REP
+END PROC identifier aufsammeln;
+
+PROC schluesselwort aufsammeln:
+ dummy := "";
+ sammle schluesselwort;
+ IF dummy = "END"
+ THEN noch einmal
+ FI.
+
+sammle schluesselwort:
+ WHILE large letter REP
+ dummy CAT zeichen;
+ naechstes zeichen
+ END REP;
+ IF zeichen = " "
+ THEN naechstes non blank zeichen
+ FI.
+
+noch einmal:
+ sammle schluesselwort
+END PROC schluesselwort aufsammeln;
+
+PROC skip text denoter:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, """", zeichenpos + 1);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, """");
+ END REP;
+ ende text denoter.
+
+ende text denoter:
+ IF anz zeilen > 1
+ THEN report referencer error (1, zeilen nr, text (anz zeilen))
+ FI;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (2, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip text denoter
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip text denoter;
+
+PROC skip comment:
+ INT VAR anz zeilen :: 0;
+ zeichen pos := pos (zeile, "*)", zeichenpos + 2);
+ WHILE zeichen pos = 0 REP
+ naechste zeile einlesen;
+ zeichen pos := pos (zeile, "*)");
+ END REP;
+ ende comment.
+
+ende comment:
+ IF anz zeilen > 1
+ THEN report referencer error (3, zeilen nr, text (anz zeilen))
+ FI;
+ zeichen pos INCR 2;
+ naechstes non blank zeichen.
+
+naechste zeile einlesen:
+ IF eof (eingabe)
+ THEN report referencer error (4, zeilen nr, text (anz zeilen));
+ zeichen := end of program;
+ LEAVE skip comment
+ ELSE zeile lesen;
+ anz zeilen INCR 1
+ FI.
+END PROC skip comment;
+
+BOOL PROC small letter or digit:
+ (zeichen >= "0" AND zeichen <= "9") OR (zeichen >= "a" AND zeichen <= "z")
+END PROC small letter or digit;
+
+BOOL PROC small letter:
+ zeichen >= "a" AND zeichen <= "z"
+END PROC small letter;
+
+BOOL PROC large letter:
+ zeichen >= "A" AND zeichen <= "Z"
+END PROC large letter;
+
+BOOL PROC digit:
+ zeichen >= "0" AND zeichen <= "9"
+END PROC digit;
+END PACKET scanner;
+(*************************************************************************)
+PACKET referencer2 DEFINES referencer:
+
+(* Programm fuer den 'referencer'
+ Autor: Rainer Hahn *)
+
+INT VAR symb,
+ typ,
+ max index;
+
+TEXT VAR dummy,
+ dummy2,
+ name;
+
+DATASPACE VAR ds;
+
+BOUND ROW max TEXT VAR liste;
+
+FILE VAR f;
+
+BOOL VAR initialisiert :: FALSE,
+ symbol bereits geholt,
+ globale deklarationen;
+
+LET max = 1751,
+ global text = "<--G",
+ local text = "<--L",
+ refinement text = "<--R",
+ procedure text = "<--P",
+ eop = 1,
+ identifier = 2,
+ keyword = 3,
+ init symbol = 30,
+ assign symbol = 31,
+ klammer auf = 40,
+ klammer zu = 41,
+ komma = 44,
+ punkt = 46,
+ doppelpunkt = 58,
+ semikolon = 59,
+ proc symbol = 255,
+ end proc symbol = 256,
+ packet symbol = 257,
+ end packet symbol = 258,
+ type symbol = 259,
+ var symbol = 260,
+ const symbol = 261,
+ let symbol = 262,
+ leave symbol = 263,
+ op symbol = 264,
+ endop symbol = 265,
+ endif symbol = 266,
+ fi symbol = 266;
+
+PROC referencer:
+ referencer (last param)
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file):
+ referencer (check file, check file + ".r")
+END PROC referencer;
+
+PROC referencer (TEXT CONST check file, dump file):
+ IF exists (check file)
+ THEN dump file ggf loeschen
+ ELSE errorstop ("Eingabe-Datei nicht vorhanden")
+ FI;
+ disable stop;
+ start referencing (check file, dump file);
+ forget (ds);
+ enable stop.
+
+dump file ggf loeschen:
+ IF exists (dump file)
+ THEN forget (dump file, quiet)
+ FI.
+END PROC referencer;
+
+PROC start referencing (TEXT CONST check file, dump file):
+ enable stop;
+ ueberschrift;
+ initialisierung;
+ verkuerzte syntax analyse;
+ line ;
+ in dump file kopieren (dump file);
+ line ;
+ end scanning (check file).
+
+ueberschrift:
+ page;
+ put ("REFERENCER:");
+ put (check file);
+ put ("->");
+ putline (dump file).
+
+initialisierung:
+ IF NOT initialisiert
+ THEN init name table with
+("PROC,ENDPROC,PACKET,ENDPACKET,TYPE,VAR,CONST,LET,LEAVE,OP,ENDOP,ENDIF,FI");
+ initialisiert := TRUE
+ FI;
+ ds := nilspace;
+ liste := ds;
+ max index := end op symbol;
+ dummy := checkfile.
+
+verkuerzte syntax analyse:
+ globale deklarationen := TRUE;
+ line ;
+ init scanning (dummy);
+ symbol bereits geholt := FALSE;
+ REP
+ IF symbol bereits geholt
+ THEN symbol bereits geholt := FALSE
+ ELSE symbol (symb, typ)
+ FI;
+ IF typ = keyword
+ THEN nach schluesselwort verarbeiten
+ ELIF symb = punkt
+ THEN ggf refinement aufnehmen
+ ELIF typ = identifier
+ THEN identifier aufnehmen und ggf aktuelle parameter liste
+ FI
+ UNTIL typ = eop ENDREP.
+
+identifier aufnehmen und ggf aktuelle parameter liste:
+ in die liste (symb, "");
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN aktuelle parameter aufnehmen
+ ELSE symbol bereits geholt := TRUE
+ FI.
+
+nach schluesselwort verarbeiten:
+ SELECT symb OF
+ CASE let symbol:
+ let deklarationen aufsammeln
+ CASE packet symbol:
+ namen des interface aufsammeln
+ CASE end packet symbol:
+ skip naechstes symbol
+ CASE var symbol, const symbol:
+ datenobjekt deklaration aufnehmen
+ CASE proc symbol:
+ globale deklarationen := FALSE;
+ prozedur name und ggf parameter aufsammeln
+ CASE end proc symbol:
+ globale deklarationen := TRUE;
+ skip naechstes symbol
+ CASE op symbol:
+ globale deklarationen := FALSE;
+ operatornamen skippen und ggf parameter aufsammeln
+ CASE end op symbol:
+ globale deklarationen := TRUE;
+ skip until (semikolon)
+ CASE type symbol:
+ namen der typ definition aufsammeln
+ CASE leave symbol:
+ skip naechstes symbol
+ OTHERWISE:
+ ENDSELECT.
+
+skip naechstes symbol:
+ symbol (symb, typ).
+END PROC start referencing;
+
+PROC aktuelle parameter aufnehmen:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = klammer zu END REP.
+END PROC aktuelle parameter aufnehmen;
+
+PROC ggf refinement aufnehmen:
+ symbol (symb, typ);
+ symbol bereits geholt := TRUE;
+ WHILE typ = identifier REP
+ doppelpunkt oder selektor
+ END REP.
+
+doppelpunkt oder selektor:
+ INT CONST letzter id :: symb;
+ symbol (symb, typ);
+ IF symb = doppelpunkt
+ THEN in die liste (letzter id, refinement text);
+ LEAVE ggf refinement aufnehmen
+ ELSE in die liste (letzter id, "");
+ IF symb = punkt
+ THEN symbol (symb, typ)
+ ELSE LEAVE ggf refinement aufnehmen
+ FI
+ FI
+END PROC ggf refinement aufnehmen;
+
+PROC namen des interface aufsammeln:
+ packet name ueberspringen;
+ namen der schnittstelle aufsammeln.
+
+packet name ueberspringen:
+ symbol (symb, typ).
+
+namen der schnittstelle aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = doppelpunkt END REP.
+END PROC namen des interface aufsammeln;
+
+PROC let deklarationen aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN let name aufnehmen
+ ELIF typ = keyword
+ THEN bis zum komma oder semikolon
+ FI;
+ UNTIL symb = semikolon END REP.
+
+let name aufnehmen:
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, "")
+ FI;
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, "")
+ FI
+ UNTIL symb = komma OR symb = semikolon END REP.
+END PROC let deklarationen aufsammeln;
+
+PROC namen der typ definition aufsammeln:
+ REP
+ symbol (symb, typ);
+ bis zum komma oder semikolon
+ UNTIL symb = semikolon END REP
+END PROC namen der typ definition aufsammeln;
+
+PROC bis zum komma oder semikolon:
+ INT VAR anz klammern :: 0;
+ REP
+ symbol (symb, typ); (* fields aufnehmen weggelassen *)
+ IF symb = klammer auf
+ THEN anz klammern INCR 1
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1
+ FI
+ UNTIL (symb = komma AND anz klammern = 0) OR symb = semikolon ENDREP.
+END PROC bis zum komma oder semikolon;
+
+PROC datenobjekt deklaration aufnehmen:
+ symbol (symb, typ);
+ REP
+ IF globale deklarationen
+ THEN in die liste (symb, global text)
+ ELSE in die liste (symb, local text)
+ FI;
+ skip ggf initialisierung;
+ IF symb = komma
+ THEN symbol (symb, typ)
+ FI
+ UNTIL symb = semikolon OR symb = punkt END REP.
+
+skip ggf initialisierung:
+ symbol (symb, typ);
+ IF symb = init symbol OR symb = assign symbol
+ THEN initialisierung skippen
+ FI.
+
+initialisierung skippen:
+ INT VAR anz klammern :: 0;
+ REP
+ INT CONST vorheriges symbol :: symb,
+ vorheriger typ :: typ;
+ symbol (symb, typ);
+ IF symb = klammer auf
+ THEN anz klammern INCR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF symb = klammer zu
+ THEN anz klammern DECR 1;
+ IF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ ELIF vorheriger typ = identifier AND symb = doppelpunkt
+ THEN in die liste (vorheriges symbol, refinement text);
+ LEAVE datenobjekt deklaration aufnehmen
+ ELIF vorheriger typ = identifier
+ THEN in die liste (vorheriges symbol, "")
+ FI
+ UNTIL (symb = komma AND anz klammern = 0)
+ OR symb = semikolon OR symb = end proc symbol OR
+ symb = end op symbol OR symb = endif symbol OR symb = fi symbol
+ END REP.
+END PROC datenobjekt deklaration aufnehmen;
+
+PROC prozedur name und ggf parameter aufsammeln:
+ prozedurname aufsammeln;
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI.
+
+prozedurname aufsammeln:
+ symbol (symb, typ);
+ in die liste (symb, procedure text).
+END PROC prozedurname und ggf parameter aufsammeln;
+
+PROC operatornamen skippen und ggf parameter aufsammeln:
+ symbol (symb, typ);
+ IF symb <> doppelpunkt
+ THEN formale parameter aufsammeln
+ FI
+END PROC operatornamen skippen und ggf parameter aufsammeln;
+
+PROC formale parameter aufsammeln:
+ REP
+ symbol (symb, typ);
+ IF typ = identifier
+ THEN in die liste (symb, local text);
+ FI
+ UNTIL symb = doppelpunkt END REP
+END PROC formale parameter aufsammeln;
+
+PROC skip until (INT CONST zeichencode):
+ skip until (zeichencode, 0)
+END PROC skip until;
+
+PROC skip until (INT CONST z1, z2):
+ REP
+ symbol (symb, typ)
+ UNTIL symb = z1 OR symb = z2 END REP
+END PROC skip until;
+
+PROC in die liste (INT CONST index, TEXT CONST zusatz):
+ IF index > max index
+ THEN listenelemente initialisieren;
+ FI;
+ IF aktueller eintrag = ""
+ THEN namens eintrag
+ FI;
+ aktueller eintrag CAT " ";
+ aktueller eintrag CAT text (line number);
+ aktueller eintrag CAT zusatz.
+
+aktueller eintrag:
+ liste [index].
+
+listenelemente initialisieren:
+ INT VAR i;
+ FOR i FROM max index + 1 UPTO index REP
+ liste [i] := ""
+ END REP;
+ max index := index.
+
+namens eintrag:
+ get name (index, aktueller eintrag);
+ WHILE length (aktueller eintrag) < 15 REP
+ aktueller eintrag CAT " "
+ END REP;
+ aktueller eintrag CAT ":".
+END PROC in die liste;
+
+TEXT VAR zeile;
+
+PROC in dump file kopieren (TEXT CONST dump file):
+ putline ("Ausgabedatei erstellen");
+ f := sequential file (output, dump file);
+ INT VAR i;
+ kopieren und ggf fehlermeldung;
+ modify (f);
+ ggf sortieren;
+ zeile ggf aufspalten;
+ modify (f);
+ to line (f, 1).
+
+kopieren und ggf fehlermeldung:
+ FOR i FROM fi symbol UPTO max index REP
+ cout (i);
+ zeile := liste [i];
+ IF zeile <> ""
+ THEN ausgabe der referenz und ggf fehlermeldung
+ FI
+ ENDREP.
+
+ausgabe der referenz und ggf fehlermeldung:
+ putline (f, zeile);
+ ggf referencer fehlermeldung.
+
+ggf sortieren:
+ IF yes (dump file + " sortieren")
+ THEN sort (dump file);
+ FI.
+
+zeile ggf aufspalten:
+ i := 0;
+ to line (f, 1);
+ WHILE NOT eof (f) REP
+ i INCR 1;
+ cout (i);
+ read record (f, zeile);
+ ggf aufspalten
+ END REP.
+
+ggf aufspalten:
+INT VAR anf :: 1, ende :: pos (zeile, " ", 72);
+ IF ende > 0
+ THEN dummy := subtext (zeile, 1, ende - 1);
+ write record (f, dummy);
+ spalte bis restzeile auf;
+ dummy CAT subtext (zeile, anf);
+ write record (f, dummy);
+ FI;
+ down (f).
+
+spalte bis restzeile auf:
+ REP
+ dummy := " ";
+ anf := ende + 1;
+ ende := pos (zeile, " ", ende + 55);
+ down (f);
+ insert record (f);
+ IF ende <= 0
+ THEN LEAVE spalte bis restzeile auf
+ FI;
+ dummy CAT subtext (zeile, anf, ende - 1);
+ write record (f, dummy);
+ END REP.
+END PROC in dump file kopieren;
+
+PROC ggf referencer fehlermeldung:
+ name := subtext (zeile, 1, min( pos(zeile, " "), pos(zeile, ":")) - 1);
+ dummy := subtext (zeile, pos (zeile, ": ") + 2);
+ ueberdeckungs ueberpruefung;
+ not used ueberpruefung;
+ IF pos (dummy, "R") > 0
+ THEN refinement mehr als zweimal verwendet
+ FI.
+
+ueberdeckungs ueberpruefung:
+ IF pos (dummy, global text) > 0 AND pos (dummy, local text) > 0
+ THEN dummy2 := "und Zeile ";
+ dummy2 CAT text (nr (pos (dummy, local text)));
+ dummy2 CAT ": ";
+ dummy2 CAT name;
+ report referencer error
+ (5, nr (pos (dummy, global text)), dummy2)
+ FI.
+
+not used ueberpruefung:
+ IF pos (dummy, " ") = 0 AND
+ (pos (dummy, global text) > 0 OR pos (dummy, local text) > 0 OR
+ pos (dummy, refinement text) > 0)
+ THEN not used fehlermeldung
+ FI.
+
+not used fehlermeldung:
+ report referencer error
+ (8, nr (length (dummy) - length (local text) + 1), name).
+
+refinement mehr als zweimal verwendet:
+ INT VAR refinement deklarationen :: 0,
+ refinement aufrufe :: 0,
+ anf :: 1;
+ WHILE pos (dummy,"R", anf) > 0 REP
+ refinement deklarationen INCR 1;
+ anf := pos (dummy, "R", anf) + 1
+ END REP;
+ anf := 1;
+ WHILE pos (dummy, " ", anf) > 0 REP
+ refinement aufrufe INCR 1;
+ anf := pos (dummy, " ", anf) + 1
+ END REP;
+ IF refinement deklarationen = 1
+ THEN IF refinement aufrufe > 1
+ THEN report referencer error
+ (6, nr (pos (dummy, refinement text)), name)
+ ELIF refinement aufrufe = 0
+ THEN report referencer error
+ (7, nr (pos (dummy, refinement text)), name)
+ FI
+ ELIF refinement deklarationen > 1
+ THEN IF 2 * refinement deklarationen - 1 > refinement aufrufe
+ THEN report referencer error (9, 0, name)
+ ELIF 2 * refinement deklarationen - 1 < refinement aufrufe
+ THEN report referencer error (10, 0, name)
+ FI
+ FI.
+END PROC ggf referencer fehlermeldung;
+
+INT PROC nr (INT CONST ende):
+ INT VAR von :: ende - 1;
+ WHILE von > 0 AND ((dummy SUB von) >= "0" AND (dummy SUB von) <= "9") REP
+ von DECR 1
+ END REP;
+ int (subtext (dummy, von + 1, ende - 1))
+END PROC nr;
+END PACKET referencer2;
+
+(*
+REP
+ referencer ("ref fehler");
+ edit ("ref fehler.r");
+UNTIL no ("nochmal") END REP*)
+
--
cgit v1.2.3