(* Rainer Kottmann  *) 
(* Klaus Bovermann  *) 
(* Lutz Prechelt    *) 
(* Carsten Weinholz *)
(* 19.06.87         *) 
 
(* Pakete :   1. mpg test elan programs 
              2. mpg archive system    <---  **************************
              3. mpg some              <---  Sind für seperaten Hamster 
              4. mpg dm                <---  notwendig.
              5. mpg tools             <---  **************************
              6. mpg target handling 
              7. mpg print cmd 
              8. edit monitor 
              9. mpg global manager *) 
 
(************************* ELAN TEST ****************************) 
 
PACKET mpg test elan programs DEFINES elan test :

LET  scan end           = 7,
     in comment         = 8,
     in text            = 9,
     bold               = 2,
     char               = 4,
     delimiter          = 6,
     limit              = 77,
     max denoter length = 255,
     end bolds     = "ENDIFIENDSELECTENDREPEATPERENDPROCEDURENDPACKETENDOP",
     w                  = "WARNING: ",
     e                  = "ERROR  : ";

INT  VAR zeile;
FILE VAR err;
TEXT VAR last error;


PROC elan test :
  elan test (last param)
END PROC elan test;

PROC elan test (TEXT CONST datei) :
  INT  VAR byte :: 0, kbyte :: 0, (* Byte/Kilobyte der EUMEL Datei      *)
           sbyte:: 0, skbyte:: 0, (* Byte/Kilobyte des Elan Quelltextes *)
           denoter length :: 0, units :: 0, typ, scan operations :: 0,
           round brackets :: 0, square brackets :: 0; (* Klammerzaehler *) 
  TEXT VAR in, symbol;
  FILE VAR inputfile :: sequential file (input , datei);
  err := note file;
  zeile := 0;
  last error := "";
  scan (""); next symbol (in);
  WHILE NOT eof (inputfile) REP
    naechste zeile;
    analyse;
    in := incharety
  UNTIL in <> "" PER;
  IF in <> ""
  THEN putline (err, "***  ELAN TEST VORZEITIG ABGEBROCHEN ***")  FI;
  last error := "";
  ausgabe der enddaten;
  modify (inputfile);
  note edit (inputfile);
  line.

naechste zeile :
  getline (inputfile , in);
  continue scan (in);
  byte  INCR LENGTH in;
  kbyte INCR byte DIV 1000;
  byte  := byte MOD 1000;
  zeile INCR 1; cout (zeile);
  IF LENGTH in > limit
  THEN error (w + "line exceeding screen")
  FI.

analyse :
  REPEAT
    next symbol (symbol, typ);
    scan operations INCR 1;
    analysiere symbol
  UNTIL typ >= scan end
  PER;
  IF typ = in comment
  THEN error (w + "comment exceeding line")
  FI;
  IF typ = in text
  THEN denoter length INCR LENGTH symbol;
       IF denoter length > max denoter length
       THEN error (e + "text denoter too long (" + text (denoter length) +
                       " characters)")
       ELSE error (w + "text denoter exceeding source line")
       FI
  ELSE denoter length := 0
  FI;
  skbyte INCR sbyte DIV 1000;
  sbyte  := sbyte MOD 1000.

analysiere symbol :
  IF   typ = scan end    THEN test brackets
  ELIF typ = delimiter   THEN delimiters
  ELIF typ = char
  THEN denoter length INCR LENGTH symbol;
       IF denoter length > max denoter length
       THEN error (e + "text denoter too long (" + text (denoter length) +
                       " characters)")
       FI
  ELIF typ = bold CAND pos (endbolds, symbol) <> 0 
  THEN unitend
  FI;
  sbyte INCR LENGTH symbol.

test brackets :
  IF round brackets <> 0
  THEN error (w + text (round brackets) + " ""("" open")
  FI;
  IF square brackets <> 0
  THEN error (w + text (square brackets) + " ""["" open")
  FI.

delimiters :
  IF   symbol = ";" OR (symbol = "." AND is refinement)
  THEN unitend
  ELIF symbol = "(" THEN round  brackets INCR 1
  ELIF symbol = ")" THEN round  brackets DECR 1
  ELIF symbol = "[" THEN square brackets INCR 1
  ELIF symbol = "]" THEN square brackets DECR 1
  FI.

unitend :
  units INCR 1;
  IF round brackets <> 0
  THEN error (e + text (round brackets) + " ""("" open at end of unit");
    round brackets := 0
  FI;
  IF square brackets <> 0
  THEN error (e + text (square brackets) + " ""["" open at end of unit");
    square brackets := 0
  FI.

is refinement :   FALSE.    (* vorlaeufig *)

ausgabe der enddaten :
  line (err);
  putline (err, 77 * "=");
  putline (err, "EUMEL - Datei     :  " + text (zeile) + " Zeilen ,  " +
                bytes (kbyte, byte));
  putline (err, "Elan  - Quelltext :  " + text (units) + " Units  ,  " + 
                bytes (skbyte, sbyte));
  putline (err, text (scan operations) +
                " Scanner - Operationen durchgefuehrt.");
  putline (err, 77 * "=").
END PROC elan test;
 
PROC error (TEXT CONST error message) :
  IF error message = last error
  THEN putline (err, "dito   " + text (zeile));
       IF online THEN put (zeile); putline ("dito")  FI;
       LEAVE error  FI;
  last error := error message;
  putline (err, "EOLN " + text (zeile) + "  " + error message);
  IF online THEN put (zeile); putline (error message)  FI
END PROC error;

TEXT PROC bytes (INT CONST kilobytes, bytes) :
  TEXT VAR t :: text (kilobytes);
  IF   bytes < 10  THEN t CAT "00"
  ELIF bytes < 100 THEN t CAT "0"
  FI;
  t CAT text (bytes);
  t CAT " Byte";
  t
END PROC bytes

END PACKET mpg test elan programs;

(************************* ARCHIV **********************************)
 
PACKET mpg archive system DEFINES reserve, archive, release, 
                                  archiv, archiv name,archiv error,
                                  archiv angemeldet,
                                  from, to,
                                  pla : 
 
 
LET archive 0 code      = 90,
    archive 1 code      = 91,
    altos archive 0     =  0,
    altos archive 1     =  1,
    bicos archive 0     =  2, 
    altos station       =  1, 
    free code           = 20,
    reserve code        = 19, 
    type                = "#type (""micron"")#",
    configurator        = "configurator";

BOOL VAR angemeldet;
TEXT VAR err :: "";

(************************ Standard - Prozeduren ****************************)
(* Erlaubt jedoch nur eine ARCHIVE-Task                                    *)
 
PROC reserve (TASK CONST task): 
  reserve ("", task) 
END PROC reserve; 
 
PROC reserve (TEXT CONST msg, TASK CONST task): 
   IF task = archive 
      THEN angemeldet := TRUE 
   FI; 
   call (reserve code, msg, task) 
END PROC reserve; 
 
PROC archive (TEXT CONST name): 
   reserve (name, archive) 
END PROC archive; 
 
PROC archive (TEXT CONST name, INT CONST station): 
   reserve (name,station/archive) 
END PROC archive; 
 
PROC archive (TEXT CONST name, TASK CONST task): 
   reserve (name, task) 
END PROC archive; 

PROC release (TASK CONST task): 
   call (free code, "", task); 
   IF task = archive 
      THEN angemeldet := FALSE 
   FI 
END PROC release; 
 
PROC release : 
  release (archive);
END PROC release; 

PROC archiv (INT CONST nr): 
   SELECT nr OF 
     CASE altos archive 0, altos archive 1: altos anmelden 
     CASE bicos archive 0                 : archiv
     OTHERWISE unbekannte laufwerksnummer 
   END SELECT. 
 
   altos anmelden: 
     IF station (myself) <> altos station 
        THEN unbekannte laufwerksnummer
     ELSE reserve (archive); 
          SELECT nr OF 
            CASE altos archive 0: call (archive 0 code, "",task(configurator)) 
            CASE altos archive 1: call (archive 1 code, "",task(configurator)) 
          END SELECT; 
          archiv
     FI. 

   unbekannte laufwerksnummer:
     errorstop ("Unbekannte Laufwerksnummer") 
END PROC archiv;

PROC archiv :
  angemeldet := TRUE;
  TEXT CONST name :: archiv name;
  IF err = ""
    THEN display ("Gefundenes Archiv: """ + name + """");
    ELSE errorstop (err)
  FI;
  display (""13""10"").
 
END PROC archiv;
 
BOOL PROC archiv angemeldet: 
   angemeldet 
END PROC archiv angemeldet; 
 
TEXT PROC archiv name: 
  TEXT VAR name :: ""; 
  THESAURUS VAR th;
  IF NOT angemeldet 
   THEN errorstop ("Archiv nicht angemeldet");"" 
   ELSE angemeldet := FALSE;
        err := "";
        disable stop;
        archive ("");
        IF is error 
         THEN err := errormessage; 
              LEAVE archiv name WITH "" 
        FI;
        th := ALL archive; 
        richtigen namen suchen;
        clear error;
        enable stop;
        archive (name); 
        angemeldet := TRUE;
        name
  FI.
 
richtigen namen suchen:
  IF subtext (error message, 1, 13) = "Archiv heisst"
    THEN name := subtext (error message, 16, LENGTH error message - 1)
    ELSE err  := error message
  FI
END PROC archiv name; 
 
TEXT PROC archiv error: 
  err 
END PROC archiv error;
 
PROC from (TEXT CONST name) :
  fetch (name, archive)
END PROC from; 
 
PROC to (TEXT CONST name) : 
  BOOL CONST cd :: command dialogue;
  command dialogue (FALSE);
  save (name, archive);
  command dialogue (cd)
END PROC to;

PROC to : 
  to (last param) 
END PROC to;

PROC from (THESAURUS CONST nameset): 
  fetch (nameset, archive) 
END PROC from; 
 
PROC to (THESAURUS CONST nameset): 
  BOOL CONST cd :: command dialogue;
  command dialogue (FALSE);
  save (nameset, archive);
  command dialogue (cd)
END PROC to; 
 
PROC pla:
  LET dummy name pos = 18;

  FILE VAR listfile;
  INT  VAR i;
  TEXT CONST head :: 70 * "=",
             end  :: 70 * "_";
  TEXT VAR   record;
  WHILE yes ("Archiv eingelegt") REP
    print archive listing
  PER;
  release.

print archive listing:
  archiv;
  listfile := sequential file (output , "PLA");
  list (listfile, archive);
  print head;
  erase dummy names;
  print bottom;
  print and erase listing.

print head :
  modify (listfile);
  to line (listfile, 1);
  FOR i FROM 1 UPTO 6 REP
    insert record (listfile)
  PER;
  to line (listfile, 1);
  write record (listfile, type); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, "ARCHIVNAME: "+headline (listfile) + "  " +
                time of day  +"  " + date ); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, " "); down (listfile);
  write record (listfile, "Date      Store  Contents").

erase dummy names :
  to line (listfile, 6);
  WHILE NOT eof (listfile) REP
    read record (listfile, record);
    IF (record SUB dummy name pos) = "-"
      THEN delete record (listfile)
      ELSE down (listfile) 
    FI 
  PER.

print bottom :
   output (listfile);
   putline (listfile, end).

print and erase listing :
  modify (listfile);
  edit (listfile);
  line (3);
  IF yes ("Archivlisting drucken")
    THEN print ("PLA")
  FI;
  forget ("PLA", quiet)
END PROC pla

END PACKET mpg archive system;
 
(************************ MPG SOME TOOLS *********************) 

PACKET mpg some                      (*************************) 
                                     (* Klaus Bovermann       *) 
                                     (* Andreas Dieckmann     *) 
                                     (* Thomas Clermont       *) 
                                     (* Version 3.2           *) 
                                     (* EUMEL   1.8.1         *) 
                                     (* Datum:  21.10.87      *) 
                                     (*************************) 
  
DEFINES some, SOME,                  (* in mehreren Versionen *) 
        one,                         (* in mehreren Versionen *) 
        inchar,                      (*                       *) 
        center,                      (* Hilfsroutinen         *) 
        invers ,                     (*                       *) 
        edit some,                   (* fuer Anfaenger        *) 
        edit one,                    (* fuer Anfaenger        *) 

        reorganize:                  (* auf Thesaurus         *)
 
LET max bild laenge = 80; 
 
TEXT PROC center (TEXT CONST n): 
  center (n," ",max bild laenge - 1) 
END PROC center; 
 
TEXT PROC center (TEXT CONST n,fuell zeichen,INT CONST max text laenge): 
  TEXT VAR fuell text :: 
       ((max text laenge - length (n)) DIV 2) * fuell zeichen; 
  fuelltext CAT (n + fuelltext); 
  IF (LENGTH fuelltext) - max text laenge = 0 
   THEN fuelltext 
   ELSE fuelltext + fuellzeichen 
  FI 
END PROC center; 
 
TEXT PROC invers (TEXT CONST n): 
  mark ein + n + " " + mark aus 
END PROC invers; 
 
PROC inchar (TEXT VAR t, TEXT CONST allowed chars): 
  enable stop;
  REP getchar (t);                 (* Auslesen nur aus virtuellem Puffer *) 
      IF pos (allowed chars,t) = 0 
         THEN out (""7"") 
      FI 
  UNTIL pos (allowed chars,t) <> 0 PER
END PROC inchar; 
 
(*********************************************************************) 
 
LET min zeilen          =   3,
    bildschirm          =  24, 
    min x size          =  30,
    max entries         = 200; 
 
LET trennzeichen                      = ""222"",   (* ESC # *) 
    zeichenstring                     = ""1""27""3""10""13"x"12"o?"11"", 
    oben unten rubout o return x      = ""3""10""12"o"13"x", 
    q eins neun a return x rubout o s = "q19a"13"x"12"os"; 
 
LET mark ein          = ""15"", 
    mark aus          = ""14""; 
  
LET stdtext1 = "Auswahl einer Datei ",
    stdtext2 = "Auswahl mehrerer Dateien ",
    stdhelp  = "( Bei Unklarheiten bitte <?> )";
 
LET hop   = 1, 
    esc   = 2, 
    obe   = 3, 
    unt   = 4, 
    ank   = 5, 
    ank 1 = 6, 
    aus   = 7, 
    aus 1 = 8, 
    fra   = 9, 
    ins   = 10; 
 
LET filetype = 1003; 
 
INT  VAR anzahl,               begin x,begin y,
         kopf zeilen ,         size  x,size y,
         max eintraege,        
         realc, 
         virtc; 
 
TEXT VAR string, 
         weitertext,
         niltext,
         kopfzeilen text, 
         kz1,  
         kz2;  
 
BOOL VAR raender, 
         auswahlende, 
         abbruch; 
 
ROW max entries TEXT VAR eintrag; 
 
THESAURUS VAR gesamt liste; 
FILE VAR tools info; 
DATASPACE VAR tools info ds; 
 
INITFLAG VAR init tools info; 
 
(******************* Grundlegende Prozedur *************************) 
 
THESAURUS PROC einzelne (THESAURUS CONST t, BOOL CONST viele, 
                         TEXT CONST k1,
                         INT CONST x begin,y begin, 
                                   x size ,y size): 
   begin x    := x begin; 
   begin y    := y begin; 
   size x     := x size;
   size y     := y size;
   kz1        := k1; 
   string     := ""; 
   raender    := FALSE;
   gen kopf zeilen; 
   IF groesster editor > 0 
      THEN INT VAR x,y; 
           get edit cursor (x,y) ; 
           IF bildschirm - kopfzeilen - min zeilen + 1 < y 
              THEN begin y       := 1; 
                   size y        := 24;
                   begin x       := 1;
                   size x        := 79
              ELSE begin y       := y; 
                   size y        := bildschirm - y + 1;
                   max eintraege := size y - min zeilen - kopfzeilen;
                   IF (80 - x) < min x size OR col = 1
                     THEN begin x        := 1; 
                          size x         := 79
                     ELSE raender        := TRUE; 
                          begin x        := x;
                          size x         := 80 - x - 2
                   FI
           FI;
           gen kopfzeilen
   FI; 
   IF (size y - kopf zeilen) < min zeilen OR 
                     begin y < 0          OR 
      (begin y + size y - 1) > bildschirm OR
      (begin x + size x - 1) > 79
      THEN errorstop ("Fenster zu klein") 
   FI; 
   init weitertext;
   init niltext;
   THESAURUS VAR ausgabe :: empty thesaurus; 
   gesamt liste := t; 
   INT VAR i; 
   anzahl := 0; 
   FOR i FROM 1 UPTO highest entry (t) REP 
     IF name (t,i) <> "" 
        THEN anzahl INCR 1; 
             eintrag [anzahl] := name (t,i) 
     FI 
   PER; 
   IF anzahl = 0 THEN LEAVE einzelne WITH ausgabe FI; 
   bild aufbauen; 
   abbruch := FALSE; 
   kreuze an (viele); 
   IF abbruch 
      THEN LEAVE einzelne WITH ausgabe 
   FI; 
   cursor (begin x,begin y + size y - 1); 
   out (niltext); (* Folgende Ausgaben werden sonst unleserlich *) 
   ausgabe erzeugen; 
   ausgabe. 
  
ausgabe erzeugen: 
  TEXT VAR nam; 
  WHILE string <> "" REP 
        nam := subtext (string,1,3); 
        string := subtext (string,5); 
        insert (ausgabe, eintrag [int (nam)]) 
  PER 
END PROC einzelne; 
 
PROC realcursor setzen: 
  cursor (begin x,kopf zeilen + realc + begin y); 
  IF raender
   THEN out ("|")
  FI;
  out (marke (virtc, TRUE) + 6 * ""8"") 
END PROC real cursor setzen; 
 
TEXT PROC marke (INT CONST zeiger, BOOL CONST mit cursor): 
  INT VAR pl :: nr (zeiger); 
  IF pl = 0 
     THEN leer 
     ELSE mit zahl 
  FI. 
 
mit zahl: 
  IF mit cursor 
     THEN (3-length(text(pl))) * "-" + text (pl) + "-> " 
     ELSE text (pl,3) + " > " 
  FI. 
 
leer: 
  IF mit cursor 
     THEN "----> " 
     ELSE 6 * " " 
  FI 
END PROC marke; 
 
PROC init weitertext: 
  weitertext := "----> " + mark ein + "weitere  Eintraege " + mark aus  
                         + ((size x - 27) * "-") 
END PROC init weitertext; 
 
PROC init niltext: 
  IF size x > 78 
    THEN niltext := ""5"" 
    ELSE IF raender 
           THEN niltext := ((size x + 2) * " " + (size x + 2) * ""8"")
           ELSE niltext := (size x * " " + size x * ""8"")
         FI
  FI
END PROC init niltext; 
 
PROC bild (INT CONST anfang): 
  INT VAR i; 
  gib oberlinie aus; 
  FOR i FROM anfang UPTO grenze REP 
     cursor (begin x,kopfzeilen + begin y + i - anfang + 1);
     rand;
     out (marke (i, FALSE)); 
     IF LENGTH ("""" + eintrag [i] + """") <= (size x - 6) 
       THEN out (text ("""" + eintrag [i] + """",size x - 6)) 
       ELSE out (text ("""" + eintrag [i],size x - 10) + " ...")
     FI;
     rand
  PER; 
  gib unterlinie aus; 
  IF grenze < (anfang + max eintraege)
     THEN FOR i FROM 0 UPTO (anfang + max eintraege - anzahl - 1) REP
           cursor (begin x,begin y + kopfzeilen + i +
                           grenze - anfang + min zeilen);
           out (niltext) 
          PER
  FI. 
  
gib oberlinie aus: 
  cursor (begin x,kopfzeilen + begin y); 
  rand;
  IF realc = virtc 
     THEN out (size x * "-") 
     ELSE out (weitertext) 
  FI;
  rand.
  
gib unterlinie aus: 
  cursor (begin x,begin y + grenze - anfang + kopfzeilen + min zeilen - 1);
  rand;
  IF anzahl <= (anfang + max eintraege)
     THEN out (size x * "-") 
     ELSE out (weitertext) 
  FI;
  rand.
 
grenze: 
  min (anzahl,anfang + max eintraege).
 
END PROC bild; 
 
PROC gen kopfzeilen: 
  kopfzeilen := 0; 
  kopfzeilen text := ""; 
  kopfzeilen text CAT code (0);
  IF   pos (kz1,trenn zeichen) > 0 
       THEN analysiere kopfzeile 
  ELIF kz1 <> "" AND length (kz1) <= size x
       THEN kopfzeilen text := kz1 + code (1);
            kopf zeilen := 1 
  ELIF kz1 <> "" 
       THEN analysiere kopfzeile 
  FI; 
  IF kopfzeilen > size y - min zeilen 
     THEN kopfzeilen := size y - min zeilen 
  FI; 
  max eintraege := size y - kopfzeilen - min zeilen.
 
analysiere kopfzeile: 
   kz2 := compress (kz1); 
   BOOL VAR mark is on :: FALSE;
   TEXT VAR einschub;
   REP kopf zeilen INCR 1; 
       kontrolliere pos; 
       einschub := subtext(kz2,1,pos (kz2,trennzeichen)-1);
       kontrolliere auf markiert;
       kopfzeilen text CAT einschub;
       kopfzeilen text CAT code (kopf zeilen);
       kz2 := compress (subtext(kz2,pos (kz2,trennzeichen) + 1));
   UNTIL NOT (length (kz2) > size x OR pos (kz2,trennzeichen) > 0 )PER; 
   IF kz2 <> "" 
      THEN einschub := kz2; 
           kontrolliere auf markiert; 
           kopfzeilen text CAT einschub;
           kopf zeilen INCR 1 
   FI; 
   kopfzeilentext CAT code (kopfzeilen).
 
muss noch getrennt werden: 
 (pos (kz2,trennzeichen) > size x OR  pos (kz2,trennzeichen) = 0)
                                  AND length (kz2) > size x. 

kontrolliere pos: 
  IF muss noch getrennt werden
     THEN trenne kopfzeile
  FI. 
 
trenne kopfzeile: 
  INT VAR i; 
  FOR i FROM size x DOWNTO (size x DIV 2) REP
  UNTIL (kz2 SUB i) = " " PER; 
  kz2 := subtext (kz2,1,i) + trennzeichen + subtext (kz2,i+1).
 
kontrolliere auf markiert: 
  IF mark is on 
    THEN kopfzeilen text CAT mark ein;
         IF pos (einschub,mark aus) > 0 AND pos (einschub,mark ein) = 0
           THEN mark is on := FALSE 
         FI 
    ELSE IF pos (einschub,mark ein) > 0 
           THEN IF pos (einschub,mark aus) = 0 
                  THEN einschub CAT mark aus; 
                       mark is on := TRUE 
                FI
         FI 
  FI. 
 
END PROC gen kopfzeilen; 
 
PROC zeige kopfzeilen:
 INT VAR i; 
 FOR i FROM 1 UPTO kopfzeilen REP 
  cursor (begin x,begin y + i - 1); 
  rand;
  out (niltext);
  out (center (subtext (kopfzeilen text,pre code + 1,post code - 1) 
               ," ",size x));
  rand
 PER. 
 
 post code: 
  pos (kopfzeilen text,code (i)). 
 
 pre code: 
  pos (kopfzeilen text,code (i - 1)). 
 
END PROC zeige kopfzeilen; 
 
PROC  bild aufbauen: 
  zeige kopfzeilen;
  virtc := 1; 
  realc := 1; 
  bild (1);
  realcursor setzen 
END PROC bild aufbauen; 
 
PROC kreuze an (BOOL CONST viele): 
  auswahlende := FALSE; 
  REP zeichen lesen; 
      zeichen interpretieren 
  UNTIL auswahlende 
  PER. 
 
zeichen lesen: 
  TEXT VAR zeichen; 
  inchar (zeichen, zeichenstring). 
 
zeichen interpretieren: 
  SELECT pos (zeichenstring, zeichen) OF 
    CASE hop   : hoppen (viele) 
    CASE esc   : esc kommandos (viele) 
    CASE obe   : nach oben 
    CASE unt   : nach unten 
    CASE ank   : ankreuzen (viele,FALSE); evtl aufhoeren 
    CASE ank 1 : ankreuzen (viele,TRUE ); evtl aufhoeren 
    CASE aus   : auskreuzen 
    CASE aus 1 : auskreuzen       
    CASE fra   : info (viele) 
    CASE ins   : eintrag einfuegen; 
                 IF string <> ""
                    THEN evtl aufhoeren 
                 FI
  END SELECT. 
 
evtl aufhoeren: 
  IF NOT viele 
     THEN LEAVE kreuze an 
  FI 
END PROC kreuze an; 
 
PROC hoppen (BOOL CONST viele): 
  zweites zeichen lesen; 
  zeichen interpretieren. 
 
zweites zeichen lesen: 
  TEXT VAR zz; 
  getchar (zz). 
 
zeichen interpretieren: 
  SELECT pos (oben unten rubout o return x , zz) OF 
    CASE 0   : out (""7"") 
    CASE 1   : hop nach oben 
    CASE 2   : hop nach unten 
    CASE 3,4 : alles loeschen  
    CASE 5   : bild nach oben 
    CASE 6   : IF viele THEN rest ankreuzen ELSE out (""7"") FI 
  END SELECT.  
  
bild nach oben: 
  realc := 1; 
  bild (virtc); 
  realcursor setzen. 
 
rest ankreuzen: 
  INT VAR i; 
  FOR i FROM 1 UPTO anzahl REP 
    IF nr (i) = 0 
       THEN string CAT textstr (i) 
    FI 
  PER; 
  bild aktualisieren;  
  realcursor setzen.  
 
alles loeschen: 
  string := ""; 
  bild aktualisieren; 
  realcursor setzen. 
 
hop nach oben: 
  IF   ganz oben 
       THEN out (""7"") 
  ELIF oben auf der seite 
       THEN raufblaettern 
       ELSE top of page 
  FI. 
 
ganz oben: 
  virtc = 1. 
 
oben auf der seite: 
  realc = 1. 
 
raufblaettern: 
  virtc DECR (max eintraege + 1); 
  virtc := max (virtc, 1); 
  bild (virtc); 
  realcursor setzen. 
 
top of page: 
  loesche marke; 
  virtc DECR (realc - 1); 
  realc := 1; 
  realcursor setzen. 
 
hop nach unten: 
  IF   ganz unten 
       THEN out (""7"") 
  ELIF unten auf der seite 
       THEN runterblaettern 
       ELSE bottom of page 
  FI. 
 
ganz unten: 
  virtc = anzahl. 
 
unten auf der seite: 
  realc > maxeintraege . 
 
runterblaettern: 
  INT VAR alter virtc :: virtc; 
  virtc INCR (max eintraege + 1); 
  virtc := min (virtc, anzahl); 
  realc := virtc - alter virtc; 
  bild (alter virtc + 1); 
  realcursor setzen. 
 
bottom of page: 
  loesche marke; 
  alter virtc := virtc; 
  virtc INCR (max eintraege + 1 - realc); 
  virtc := min (anzahl, virtc); 
  realc INCR (virtc - alter virtc); 
  realcursor setzen 
END PROC hoppen; 
 
PROC esc kommandos (BOOL CONST viele): 
  TEXT VAR zz; 
  getchar (zz);  
  SELECT pos(q eins neun a return x rubout o s, zz) OF 
    CASE 0   : out (""7"") 
    CASE 1   : auswahlende := TRUE 
    CASE 2   : zeige anfang 
    CASE 3   : zeige ende 
    CASE 4   : abbruch := TRUE; auswahlende := TRUE 
    CASE 5,6 : IF viele 
                  THEN ankreuzen bis ende 
                  ELSE out (""7"") 
               FI 
    CASE 7,8 : IF viele 
                  THEN loeschen bis ende 
                  ELSE out (""7"") 
               FI 
    CASE 9   : liste nach nummern ordnen 
  END SELECT. 
  
liste nach nummern ordnen : 
   THESAURUS VAR dummy thesaurus :: empty thesaurus; 
   TEXT VAR nam,dummy string :: ""; 
   cursor (begin x,begin y + screen ende + kopfzeilen + minzeilen - 1);
   rand;
   out (center(invers("Bitte warten !"),"-",size x)); 
   rand;
   i := 0; 
   WHILE string <> "" REP 
       i INCR 1; 
       nam := subtext (string,1,3); 
       string := subtext (string,5); 
       insert (dummy thesaurus, eintrag [int (nam)]); 
       dummy string CAT textstr (i) 
   PER; 
   anzahl := 0; 
   string := dummy string; 
   gesamt liste := dummy thesaurus + gesamt liste; 
   FOR i FROM 1 UPTO highest entry (gesamt liste) REP 
      IF name (gesamt liste,i) <> "" 
         THEN anzahl INCR 1; 
              eintrag [anzahl] := name (gesamt liste,i) 
      FI 
   PER; 
   bild aufbauen. 
 
loeschen bis ende: 
  INT VAR j; 
  FOR j FROM virtc UPTO anzahl REP 
    INT VAR posi :: nr (j); 
    IF posi <> 0 
       THEN rausschmeissen 
    FI 
  PER; 
  bild aktualisieren; 
  realcursor setzen. 
 
rausschmeissen: 
  string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1). 
 
ankreuzen bis ende: 
  INT VAR i; 
  FOR i FROM virtc UPTO anzahl REP 
    IF nr (i) = 0 
       THEN string CAT textstr (i) 
    FI 
  PER; 
  bild aktualisieren;  
  realcursor setzen.  
 
zeige anfang:  
  IF virtc = 1 
     THEN out (""7"") 
     ELIF virtc = realc 
     THEN loesche marke; 
          virtc := 1; 
          realc := 1; 
          realcursor setzen 
     ELSE virtc := 1; 
          realc := 1; 
          bild (1); 
          realcursor setzen 
  FI. 
 
zeige ende: 
  IF   virtc = anzahl 
       THEN out (""7"") 
  ELIF ende auf screen 
       THEN loesche marke;  
            realc INCR (anzahl - virtc);  
            virtc := anzahl; 
            realcursor setzen 
       ELSE virtc := anzahl;        
          realc := max eintraege + 1;                                
          bild (anzahl - maxeintraege); 
          realcursor setzen 
  FI. 
  
ende auf screen: 
  (realc + anzahl - virtc) < maxeintraege + 1. 
 
screen ende:
  min (realc + anzahl - virtc - 1,max eintraege).

END PROC esc kommandos; 
 
PROC ankreuzen (BOOL CONST viele,xo): 
  INT VAR pl :: nr (virtc); 
  IF pl <> 0 
     THEN out (""7""); 
          cursor setzen; 
          LEAVE ankreuzen 
  FI; 
  string CAT textstr (virtc); 
  IF viele 
     THEN cursor setzen 
  FI. 
 
 cursor setzen: 
  IF xo 
   THEN realcursor setzen 
   ELSE IF virtc < anzahl 
         THEN nach unten 
        FI; 
        IF virtc = anzahl 
         THEN realcursor setzen 
        FI 
  FI 
END PROC ankreuzen; 
 
PROC auskreuzen : 
  INT VAR posi :: nr (virtc); 
  IF posi = 0 
     THEN out (""7""); LEAVE auskreuzen 
  FI; 
  rausschmeissen; 
  loesche marke; 
  bild aktualisieren; 
  realcursor setzen. 
 
rausschmeissen: 
  string := subtext (string,1, 4*posi-4) + subtext (string,4*posi+1)  
END PROC auskreuzen; 
 
PROC eintrag einfuegen : 
  IF anzahl = max entries 
     THEN out (""7""); 
          LEAVE eintrag einfuegen 
  FI; 
  mache platz frei; 
  trage ein; 
  baue richtiges bild auf. 
 
mache platz frei: 
  INT VAR i; 
  FOR i FROM anzahl DOWNTO virtc REP 
     eintrag [i+1] := eintrag [i] 
  PER; 
  eintrag [virtc] := """"; 
  ruecke kreuze einen weiter; 
  anzahl INCR 1; 
  string CAT textstr (virtc); 
  baue richtiges bild auf. 
 
trage ein: 
  TEXT VAR exit char;
  realcursor setzen;
  out (marke (virtc,TRUE));
  out ("""");
  push (""11""); 
  editget (ein,max text length,size x - 7,"","",exit char);
  IF (ein SUB length (ein)) = """"
     THEN ein := subtext (ein,1,length (ein) - 1) 
  FI; 
  IF ein = "" 
     THEN auskreuzen; 
          setze eintraege zurueck 
     ELSE realcursor setzen;
          out (6 * ""2"" + text ("""" + ein + """",size x - 7))
  FI.            
 
ein: 
  eintrag [virtc]. 
 
setze eintraege zurueck: 
  FOR i FROM virtc UPTO anzahl-1 REP 
      eintrag [i] := eintrag [i+1]; 
      change (string,textstr (i+1),textstr (i)) 
  PER; 
  anzahl DECR 1. 
 
ruecke kreuze einen weiter: 
  FOR i FROM anzahl DOWNTO virtc REP 
      change (string,textstr (i),textstr (i+1)) 
  PER. 
 
baue richtiges bild auf: 
   bild (virtc - (realc - 1)); 
   realcursor setzen 
END PROC eintrag einfuegen; 
 
PROC bild aktualisieren: 
  INT VAR ob, un, i; 
  ob := virtc - (realc - 1); 
  un := min (ob + max eintraege, anzahl); 
  FOR i FROM ob UPTO un REP 
     cursor (begin x,kopfzeilen + begin y + i - ob + 1);
     rand;
     out (marke (i, FALSE))
  PER 
END PROC bild aktualisieren; 
 
PROC nach oben: 
  IF noch nicht oben   (* virtuell *) 
     THEN gehe nach oben 
     ELSE out (""7"") 
  FI. 
 
noch nicht oben: 
  virtc > 1. 
 
gehe nach oben: 
  IF realc = 1 
     THEN scroll down 
     ELSE cursor up 
  FI. 
 
scroll down: 
  virtc DECR 1; 
  bild (virtc); 
  realcursor setzen. 
 
cursor up: 
  loesche marke; 
  virtc DECR 1; 
  realc DECR 1; 
  realcursor setzen 
END PROC nach oben; 
 
PROC nach unten: 
  IF noch nicht unten  (* virtuell *)  
     THEN gehe nach unten 
     ELSE out (""7"") 
  FI. 
 
noch nicht unten: 
  virtc < anzahl. 
 
gehe nach unten: 
  IF realc > maxeintraege 
     THEN scroll up 
     ELSE cursor down 
  FI. 
 
scroll up: 
  virtc INCR 1; 
  bild (virtc - maxeintraege); 
  realcursor setzen. 
 
cursor down: 
  loesche marke; 
  virtc INCR 1; 
  realc INCR 1; 
  realcursor setzen 
END PROC nach unten; 
 
PROC loesche marke: 
  cursor (begin x,kopf zeilen + realc + begin y); 
  rand;
  out (marke (virtc, FALSE)) 
END PROC loesche marke; 
 
TEXT PROC textstr (INT CONST nr): 
  text (nr,3) + "!" 
END PROC textstr; 
 
INT PROC nr (INT CONST zeiger): 
  IF pos (string, textstr (zeiger)) = 0 
     THEN 0 
     ELSE (pos (string,textstr (zeiger)) DIV 4) + 1 
  FI  
END PROC nr; 
 
PROC rand: 
 IF raender 
   THEN out ("|") 
 FI 
END PROC rand; 
 
PROC info (BOOL CONST mehrere moeglich): 
   IF NOT initialized (init tools info) 
      THEN initialisiere tools info 
   FI; 
   modify (tools info); 
   IF mehrere moeglich 
      THEN head line (tools info," INFO : Auswahl mehrerer Dateien "); 
      ELSE head line (tools info," INFO : Auswahl einer Datei "); 
   FI; 
   to line (tools info,1); 
   col (tools info,1);
   IF raender 
     THEN open editor (groesster editor + 1,tools info,FALSE, 
                                     begin x,begin y,size x + 2,size y) 
     ELSE open editor (groesster editor + 1,tools info,FALSE, 
                                     begin x,begin y,size x,size y)
   FI;
   edit (groesster editor,"q19",PROC (TEXT CONST) std kommando interpreter); 
   zeige kopfzeilen;
   bild (virtc - (realc - 1));
   realcursor setzen
END PROC info;  
 
(******************** Herausgereichte, abgeleitete Prozeduren ***********) 
 
THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start x,start y,x size,y size): 
  einzelne (t,TRUE,kopf zeile,start x,start y,x size,y size) 
END PROC some; 

THESAURUS PROC some (THESAURUS CONST t,
                     INT CONST start x,start y,x size,y size): 
  some  (t,invers (std text 2 + std help),start x,start y,x size,y size) 
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start y,ende y): 
   einzelne (t,TRUE,kopf zeile,1,start y,79,ende y - start y + 1)
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t,INT CONST start y,ende y): 
   some (t,invers(stdtext 2 + std help),1,start y,79,ende y - start y + 1)
END PROC some; 

THESAURUS PROC some (THESAURUS CONST t,TEXT CONST kopf zeile): 
   some (t,kopf zeile,1,bildschirm) 
END PROC some; 
 
THESAURUS PROC some (THESAURUS CONST t): 
  some (t,invers(stdtext 2 + std help),1,bildschirm) 
END PROC some; 
  
THESAURUS PROC some: 
  some (all,invers(stdtext 2 + std help),1,bildschirm) 
END PROC some; 
 
THESAURUS PROC some (TEXT CONST te): 
  some (ALL te) 
END PROC some; 
 
THESAURUS PROC some (TASK CONST quelle): 
  some (ALL quelle) 
END PROC some; 
 
THESAURUS OP SOME (THESAURUS CONST th): 
  some (th) 
END OP SOME; 
 
THESAURUS OP SOME (TASK CONST ta): 
  some (ALL ta) 
END OP SOME; 
 
THESAURUS OP SOME (TEXT CONST te): 
  some (ALL te) 
END OP SOME; 
 
TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile, 
                     INT CONST start x,start y,x size,y size): 
  name(einzelne (t,FALSE,kopf zeile,start x,start y,x size,y size),1) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t,
               INT CONST start x,start y,x size,y size): 
  one (t,invers (std text 1 + std help),start x,start y,x size,y size) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t, TEXT CONST t1, 
               INT CONST start y,ende y): 
  name (einzelne (t,FALSE, t1,1,start y,79,ende y - start y + 1), 1) 
END PROC one; 
 
TEXT PROC one (THESAURUS CONST t, 
               INT CONST start y,ende y): 
  one (t,invers (std text 1+ std help),1,start y,79,ende y - start y + 1) 
END PROC one; 

TEXT PROC one (THESAURUS CONST t,TEXT CONST kopf zeile): 
   one (t,kopf zeile,1,bildschirm) 
END PROC one;

TEXT PROC one (THESAURUS CONST t): 
  one (t,invers(stdtext 1 + std help),1,bildschirm) 
END PROC one; 
  
TEXT PROC one (TASK CONST quelle): 
  one (ALL quelle) 
END PROC one; 
 
TEXT PROC one: 
  one (all) 
END PROC one; 
 
TEXT PROC one (TEXT CONST te): 
  one (ALL te) 
END PROC one; 
   
PROC edit one :
  TEXT CONST datei :: one (all,invers(stdtext 1 + "zum Editieren") 
                               + trennzeichen + stdhelp,
                               1,bildschirm); 
  IF datei <> "" CAND (NOT exists (datei) 
                       COR type (old (datei)) = filetype) 
     THEN IF groesster editor > 0 
              THEN ueberschrift neu; 
                   bild neu
          FI;
          edit (datei) 
  FI  
END PROC edit one; 
 
PROC edit some:
  THESAURUS CONST tt :: some (all,invers(stdtext 2 + "zum Editieren") 
                                  + trennzeichen + stdhelp, 
                                  1,bildschirm); INT VAR i; 
  FOR i FROM 1 UPTO highest entry (tt) REP 
    TEXT VAR datei :: name (tt,i); 
    IF datei <> "" CAND (NOT exists (datei) 
                         COR type (old (datei)) = filetype) 
       THEN IF groesster editor > 0 
              THEN ueberschrift neu; 
                   bild neu                   
            FI; 
            edit (datei) 
    FI 
 PER 
END PROC edit some; 

PROC reorganize (THESAURUS CONST t): 
  page; 
  do (PROC (TEXT CONST) do reorganize,t) 
END PROC reorganize; 
 
PROC do reorganize (TEXT CONST name): 
 IF type (old(name)) = file type 
  THEN put ("Datei " + center (invers("""" + name + """")," ",30) 
                     + " wird reorganisiert :"); 
       FILE VAR file :: sequential file (modify,name);
       IF segments (file) = 1
         THEN put (lines (file))
         ELSE reorganize (name) 
       FI
  ELSE put ("      " + center (invers("""" + name + """")," ",30) 
                     + " ist keine Datei.") 
 FI; 
 line 
END PROC do reorganize ; 
 
PROC initialisiere tools info : 
   tools info ds := nilspace; 
   tools info := sequential file (output, tools info ds); 
   putline (tools info,""15"   Mit den angekreuzten Namen wird die gewaehlte Operation ausgefuehrt     "14"");
      line (tools info); 
   putline (tools info,"        "15"   Positionierungen: "14" "); 
      line (tools info); 
   putline (tools info,"              Oben         : zum vorausgehenden Namen");
   putline (tools info,"              Unten        : zum folgenden Namen    ");
   putline (tools info,"              HOP Oben     : zum ersten  Namen der (vorigen) Seite");
   putline (tools info,"              HOP Unten    : zum letzten Namen der (vorigen) Seite");
   putline (tools info,"              HOP RETURN   : aktuelle Zeile wird erste Zeile");
   putline (tools info,"              ESC 1        : zum ersten  Namen der Liste");
   putline (tools info,"              ESC 9        : zum letzten Namen der Liste");
   putline (tools info,"              ESC s        : Liste nach Nummern ordnen");
      line (tools info); 
   putline (tools info,"        "15"   Auswahl treffen: "14" "); 
      line (tools info); 
   putline (tools info,"              ( Folgende Befehle sind nur bei einer )");
   putline (tools info,"              ( Auswahl von mehreren Namen Möglich. )");
      line (tools info); 
   putline (tools info,"              RETURN bzw. x: diesen Namen ankreuzen     ");
   putline (tools info,"              RUBOUT bzw. o: Kreuz vor dem Namen loeschen");
   putline (tools info,"              HOP x        : alle Namen ankreuzen      ");
   putline (tools info,"              HOP o        : alle Kreuze loeschen     ");
   putline (tools info,"              ESC x        : alle folgenden Namen ankreuzen");
   putline (tools info,"              ESC o        : alle folgenden Kreuze loeschen");
   putline (tools info,"              RUBIN        : einen neuen Namen eintragen");
      line (tools info); 
   putline (tools info,"              ( Nur dieser Befehl kann benutzt werden , wenn )");
   putline (tools info,"              ( die Auswahl eines ! Namens möglich ist.      )");
      line (tools info); 
   putline (tools info,"              RETURN bzw. x: diesen Namen auswaehlen");
      line (tools info); 
   putline (tools info,"         "15"  Auswahl verlassen: "14""); 
      line (tools info); 
   putline (tools info,"                ESC q        : Auswaehlen beenden     ");
   putline (tools info,"                ESC a        : Auswahl abbrechen (ohne Kreuze !)");
      line (tools info); 
   putline (tools info,""15"             Zum Verlassen des Infos bitte 'ESC q' tippen!                 "14"");
END PROC initialisiere tools info; 
 
END PACKET mpg some;

(****************** DATEI MONITOR ********************************) 

PACKET mpg dm DEFINES dm:                (* Klaus Bovermann   *)  
                                         (* Andreas Dieckmann *) 
                                         (* Thomas Clermont   *) 
                                         (* Version 2.1       *) 
                                         (* EUMEL   1.7.5     *) 
                                         (* Datum   06.05.87  *) 
LET mark ein            = ""15"",
    mark aus            = ""14"",
    trennzeichen        = ""222"",
    type                = "#type (""micron"")#",
    dummy name pos      = 18,
    disk zeichenfolge   = "alnfiqushcvd", 
    mana zeichenfolge   = "al   qush v"; 
 
TASK CONST std manager :: task ("PUBLIC"); 
TASK VAR manager; 
 
BOOL VAR archive ist meins :: archiv angemeldet,
         disk ,
         diskette im schacht :: FALSE; 

TEXT VAR aktueller archivename,
         manager name, 
         t1;

PROC dm: 
  TEXT VAR zeichen, alte lernsequenz :: lernsequenz auf taste ("k");
  REP  aktion 
  UNTIL zeichen = "q" PER; 
  lernsequenz auf taste legen ("k",alte lernsequenz).
  
aktion: 
  manager := std manager; 
  vormonitor; 
  IF zeichen <> "q" AND managername <> "" 
     THEN hauptmonitor 
  FI. 
  
zeige vormonitor: 
      managername := name (manager); 
      page; 
      write(27 * " "); write(mark ein); 
      write("V O R M O N I T O R "); write(mark aus); 
      line(4); 
      zeile ("t","Task einstellen, mit der  kommuniziert werden soll"); 
      zeile ("p","Es soll mit 'PUBLIC'      kommuniziert werden"); 
      zeile ("v","Es soll mit der Vatertask kommuniziert werden"); 
      zeile ("a","Es soll mit dem Archiv    kommuniziert werden"); 
      zeile ("q","Programm beenden").

vormonitor:
  IF NOT eingabe von erlaubtem zeichen ("tvapq")
    THEN zeige vormonitor
  FI; 
  line; 
  write ("Bitte Eingabe : "); 
  inchar (zeichen, "tvapq"); 
  out (zeichen); line;
  IF pos ("a",zeichen) = 0 CAND manager = archive 
    THEN automatische freigabe des archives 
  FI; 
  ausfuehren der vorwahl. 
  
ausfuehren der vorwahl: 
  IF pos ("tvap", zeichen) <> 0 
     THEN neue task einstellen  
  FI. 
  
neue task einstellen: 
  managername := ""; 
  IF   zeichen = "a" THEN managername := "ARCHIVE" 
  ELIF zeichen = "p" THEN managername := "PUBLIC" 
  ELIF zeichen = "v" THEN managername := name (father) 
                     ELSE namen holen 
  FI; 
  TEXT VAR mess; 
  BOOL VAR ok :: managername = ""        COR 
                 managername = "PUBLIC"  COR 
                 task ist kommunikativ (managername, mess); 
  IF NOT ok  
     THEN cursor (1,20); putline (""7""15"FEHLER: " + mess + ""14""); 
          pause; 
          managername := ""; 
  FI; 
  IF   managername = ""        THEN manager := std manager 
  ELIF managername = "ARCHIVE" THEN manager := archive 
                               ELSE manager := task (managername) 
  FI. 
  
namen holen: 
  REP
   cursor (1,14); 
   put ("Neue Task:"); 
   editget (managername); line; 
   IF managername = name (myself)
    THEN putline ("Mit der eigenen Task kann nicht kommuniziert werden.")
   FI;
  UNTIL managername <> name (myself) PER;
   lernsequenz auf taste legen ("k",managername).

END PROC dm;  
                        
BOOL PROC task ist kommunikativ (TEXT CONST taskname, TEXT VAR message): 
  disable stop; 
  TASK VAR t :: task (taskname); 
  IF is error 
     THEN message := errormessage; 
          clear error; 
          enable stop; 
          FALSE 
     ELSE task behandlung 
  FI. 
  
  task behandlung: 
    IF taskname <> "ARCHIVE" 
       THEN task kommunikation 
       ELSE archive behandlung 
    FI. 
  
  task kommunikation: 
    IF status (t) <> 2 
       THEN message := "Task ist nicht im Wartezustand"; 
            enable stop; 
            FALSE 
       ELSE versuchen zuzugreifen 
    FI. 
  
  versuchen zuzugreifen: 
    INT CONST listcode :: 15; 
    DATASPACE VAR dummy :: nilspace; 
    call (listcode, "", dummy, t); 
    forget (dummy); 
    IF is error  
       THEN message := errormessage; 
            clear error; 
            enable stop; 
            FALSE 
       ELSE message := ""; 
            enable stop; 
            TRUE 
    FI. 
  
  archive behandlung: 
    IF status (archive) <> 2 
       THEN message := "ARCHIVE ist nicht im Wartezustand"; 
            LEAVE archive behandlung WITH FALSE
    FI; 
    archive (""); 
    IF is error 
       THEN message := errormessage; 
            clear error; 
            enable stop; 
            FALSE  
       ELSE enable stop; 
            archive ist meins := TRUE; 
            diskette im schacht := FALSE;
            message := ""; 
            TRUE 
    FI 
END PROC task ist kommunikativ; 
 
PROC hauptmonitor:  
  disk := (manager = archive); 
  TEXT VAR zeichenfolge; 
  IF disk 
     THEN zeichenfolge := disk zeichenfolge 
     ELSE zeichenfolge := mana zeichenfolge 
  FI; 
  TEXT VAR   taste; 
  INT VAR    stelle; 
  diskette im schacht   := FALSE; 
  IF disk 
     THEN reservieren des archives 
  FI; 
  disable stop;
  REP 
    IF NOT eingabe von erlaubtem zeichen (zeichenfolge)
      THEN zeige menue 
    FI; 
    line;  
    write ("Bitte Eingabe : "); 
    inchar (taste,zeichenfolge);
    out (taste + "   Bitte warten..."); 
    stelle := pos (disk zeichenfolge, taste); (*!! ACHTUNG !!*) 
    IF         stelle > 6
       AND NOT diskette im schacht 
       AND     disk
     THEN line; 
          putline (" Erst Diskette einlegen !");pause (100) 
     ELIF taste <> " " 
     THEN menue auswerten (stelle)
    FI; 
    IF is error 
      THEN IF disk 
             THEN melde archiveerror (errormessage) 
             ELSE melde error (errormessage)
           FI;
           clear error 
    FI 
   UNTIL taste = "q" PER; 
   IF archiv angemeldet
      THEN automatische freigabe des archives 
   FI.  
 
  zeige menue: 
    page; 
    write(24 * " "); write(mark ein); 
    write("D A T E I M O N I T O R "); write(mark aus); 
    line(3); 
    zeile ("a","Auflisten aller Dateien in dieser Task"); 
    zeile ("l","Loeschen    von Dateien in dieser Task"); 
    line(2); 
    write( 15 * " "); 
    IF disk 
       THEN write("Archiv: ")  
       ELSE write("Task  : ") 
    FI;  
    IF disk 
       THEN IF diskette im schacht 
             THEN IF length(aktueller archivename) > 40  
                   THEN write ("'" + subtext (aktueller archivename,1,40) + " ...")
                   ELSE write (invers(""""+ aktueller archivename + """"))
                  FI  
             FI
       ELSE write (invers("""" + managername + """")) 
    FI; 
    line(2);  
    TEXT VAR zielname 1, zielname 2, zielname 3; 
    IF disk 
       THEN zielname 1 := "des Archivs"; 
            zielname 2 := "zum Archiv"; 
            zielname 3 := "vom Archiv" 
       ELSE zielname 1 := "in  " + managername; 
            zielname 2 := "zu  " + managername; 
            zielname 3 := "von " + managername 
    FI; 
    zeile ("u","Uebersicht ueber alle Dateien " + zielname 1); 
    zeile ("s","Senden von Dateien            " + zielname 2); 
    zeile ("h","Holen von Dateien             " + zielname 3); 
    IF disk 
       THEN zeile ("c","'Checken' von Dateien         " + zielname 1) 
    FI; 
    zeile ("v","Vernichten von Dateien        " + zielname 1); 
    IF disk THEN 
       zeile ("d","Drucken einer Liste der Dateien des Archivs"); 
       zeile ("f","Formatieren einer Diskette"); 
       zeile ("i","Initialisieren/vollstaendiges Loeschen des Archivs"); 
       zeile ("n","Neue Diskette anmelden"); 
    FI;  
    line(1); 
    zeile ("q","Zurueck zum Vormonitor").

END PROC hauptmonitor;  
 
PROC menue auswerten (INT CONST stelle):
    enable stop;
    SELECT stelle OF  
       CASE  1 : auflisten der taskdateien 
       CASE  2 : loeschen von dateien in der task 
       CASE  3 : neue diskette anmelden 
       CASE  4 : formatieren einer diskette 
       CASE  5 : initialisieren des archives 
       CASE  6 : (* nichts *) 
       CASE  7 : auflisten der archivedateinamen 
       CASE  8 : schreiben von dateien aufs archive 
       CASE  9 : holen von dateien vom archive 
       CASE 10 : checken von dateien auf dem archive 
       CASE 11 : loeschen von dateien auf dem archive 
       CASE 12 : ausdruck archivelisting 
    END SELECT 
END PROC menue auswerten;

BOOL PROC eingabe von erlaubtem zeichen (TEXT CONST erlaubte zeichen):
   TEXT VAR char in; 
   char in := getcharety;
   IF pos (erlaubte zeichen,char in) > 0 AND char in <> " "
     THEN push (char in);TRUE 
     ELSE FALSE
   FI. 
END PROC eingabe von erlaubtem zeichen; 
 
PROC zeile (TEXT CONST t,tt): 
  putline (8*" " + ""15"" + t + " "14"" + " ... " + tt) 
END PROC zeile; 
 
PROC formatieren einer diskette: 
   page; 
   putline ("Formatieren einer Diskette."); 
   putline ("==========================="); 
   putline (""15"Achtung: Alle Disketten-Informationen werden gelöscht!"14""); 
   line; 
   putline ("Dies sind die moeglichen Formate:"); 
   zeile ("o","... Ohne Format-Angabe"); 
   zeile ("0","... Standard-Format"); 
   zeile ("1","... 40 Spur -  360 KB"); 
   zeile ("2","... 80 Spur -  720 KB"); 
   zeile ("3","... IBM Std - 1200 KB"); 
   zeile ("q","... Es wird nicht formatiert."); 
   TEXT VAR art; 
   put ("Ihre Wahl:"); 
   inchar (art, "o01234q"); 
   IF art = "q" 
      THEN LEAVE formatieren einer diskette 
   FI; 
   out (art); line; 
   put ("zukünftiger Name des Archives :"); 
   editget (aktueller archivename);line; 
   archive (aktueller archivename); 
   diskette im schacht := TRUE;
   disable stop; 
   IF art = "o" THEN format (archive) 
                ELSE format (int (art), archive) 
   FI; 
   IF is error 
      THEN diskette im schacht := FALSE
      ELSE aktueller archivename := archiv name
   FI
END PROC formatieren einer diskette; 
 
PROC auflisten der taskdateien: 
   DATASPACE VAR dummy ds :: nilspace; 
   FILE VAR f :: sequential file (output,dummy ds); 
   list (f); 
   headline (f,"Liste der eigenen Task"); 
   modify (f); 
   to line (f,1); 
   show (f); 
   forget (dummy ds) 
END PROC auflisten der taskdateien; 
 
PROC loeschen von dateien in der task: 
  t1 := invers ("Loeschen von Dateien ") + "  Info mit <?>" + trennzeichen + 
        "Bitte alle zu loeschenden Dateien ankreuzen" + trennzeichen + 
        invers ("(Ankreuzen mit <RETURN> )"); 
  forget (some (all,t1)) 
END PROC loeschen von dateien in der task; 
 
PROC reservieren des archives: 
   TEXT VAR meldung; 
   page; 
   cursor(1,1); write("Bitte warten..."); 
   line (2); 
   versuche archive zu reservieren (meldung); 
   IF meldung <> "" 
      THEN page; 
           line(10); 
           write (""15"" + meldung + " "14""); 
           weitermachen; 
           diskette im schacht := FALSE;
           archive ist meins := FALSE;  
           LEAVE reservieren des archives 
   FI; 
   archive anmelden (aktueller archive name, meldung); 
   IF meldung <> "" 
    THEN melde archiveerror (meldung)
   FI. 
  
END PROC reservieren des archives;  
   
PROC versuche archive zu reservieren (TEXT VAR fehlermeldung): 
    fehlermeldung := ""; 
    IF archive ist meins 
       THEN LEAVE versuche archive zu reservieren 
    FI; 
    disable stop;  
    archive (""); 
    IF is error  
       THEN fehlermeldung := errormessage; 
            archive ist meins := FALSE;
            clear error; 
            enable stop; 
       ELSE archive ist meins := TRUE;  
            fehlermeldung := "";  
            enable stop 
    FI 
END PROC versuche archive zu reservieren; 
 
PROC archive anmelden (TEXT VAR archivename, fehlermeldung): 
  page; 
  line(3); 
  fehlermeldung := ""; 
  IF NOT archive ist meins 
     THEN archivename   := "";  
          diskette im schacht := FALSE;
          fehlermeldung := "nicht reserviert"; 
          LEAVE archive anmelden  
  FI; 
  IF yes ("Haben Sie die Diskette eingelegt und das Laufwerk geschlossen") 
     THEN line; 
          write ("Bitte warten..."); 
          archive name := archiv name;
          IF archiv error <> ""
           THEN fehlermeldung := archiv error;
                diskette im schacht := FALSE
           ELSE diskette im schacht := TRUE
          FI
     ELSE diskette im schacht := FALSE; 
          archivename := ""
  FI 
END PROC archive anmelden;
 
PROC verlange reservierung des archives: 
   page;
   line(7); 
   write (""15"Sie muessen unbedingt erst das Archiv reservieren, "14""); 
   line(2);  
   write (""15"sonst kann ich nicht darauf zugreifen! "14""); 
   line(2);  
   weitermachen 
END PROC verlange reservierung des archives;  
  
PROC auflisten der archivedateinamen: 
  forget ("Dateiliste", quiet); 
  ueberpruefe reservierung; 
  liste dateien des archivs auf; 
  liste ausgeben; 
  forget ("Dateiliste", quiet). 
  
  ueberpruefe reservierung: 
    IF disk AND diskette im schacht 
            AND NOT archive ist meins 
       THEN verlange reservierung des archives;  
            LEAVE auflisten der archivedateinamen 
    FI. 
 
  liste dateien des archivs auf: 
    FILE VAR f :: sequential file (output,"Dateiliste"); 
    disable stop; 
    list(f,manager); 
    IF is error 
       THEN LEAVE auflisten der archivedateinamen; 
       ELSE enable stop 
    FI. 
  
  liste ausgeben: 
    show (f) 
END PROC auflisten der archivedateinamen;  
 
PROC checken von dateien auf dem archive:  
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und checke.  
  
   ueberpruefe reservierung: 
     IF disk AND diskette im schacht 
             AND NOT archive ist meins 
        THEN verlange reservierung des archives; 
             LEAVE checken von dateien auf dem archive 
     FI. 
  
   lasse dateien auswaehlen und checke: 
     t1 := invers ("'Checken' von Dateien  (auf dem Archiv) ") 
           + trennzeichen + "Bitte alle zu 'checkenden' Dateien ankreuzen"; 
     disable stop; 
     check (some (ALL manager, t1), manager); 
     weitermachen; 
     IF is error 
        THEN LEAVE checken von dateien auf dem archive 
        ELSE enable stop; 
     FI 
END PROC checken von dateien auf dem archive;  
  
PROC schreiben von dateien aufs archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und schreibe aufs archive. 
    
ueberpruefe reservierung: 
  IF disk AND diskette im schacht 
          AND NOT archive ist meins 
     THEN verlange reservierung des archives; 
          LEAVE schreiben von dateien aufs archive 
  FI. 
 
lasse dateien auswaehlen und schreibe aufs archive: 
  t1 := invers ("Schreiben von Dateien ") + " Info mit <?>" + trennzeichen + 
        "Bitte alle zu schreibenden Dateien ankreuzen." + trennzeichen + 
        invers ("(Ankreuzen mit <RETURN> )"); 
  THESAURUS VAR angekreuzte :: some (ALL myself, t1); 
  disable stop;
  zuerst loeschen; 
  INT VAR zaehler; 
  TEXT VAR dname; 
  page; 
  FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP 
      IF is error 
         THEN LEAVE schreiben von dateien aufs archive 
      FI;  
      dname := name (angekreuzte, zaehler); 
      IF dname <> "" 
         THEN putline (managername + " <--- """ + dname + """"); 
              save (dname, manager) 
      FI; 
  PER.
 
  zuerst loeschen:  
    IF disk CAND (not empty (angekreuzte)) 
       THEN out (center(invers("Bitte Warten"),"-",80)); 
            THESAURUS CONST zu loe :: angekreuzte / ALL manager;  
            IF not empty (zu loe) AND NOT is error
               THEN page; 
                    putline ("Zuerst Dateien auf der Diskette loeschen?"); 
                    erase (zu loe, manager) 
            FI 
    FI  
END PROC schreiben von dateien aufs archive; 
  
BOOL PROC not empty (THESAURUS CONST t): 
  INT VAR i; 
  FOR i FROM 1 UPTO highest entry (t) REP 
    IF name (t,i) <> "" 
       THEN LEAVE not empty WITH TRUE 
    FI 
  PER; 
  FALSE 
END PROC not empty; 
 
PROC holen von dateien vom archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und hole vom archive. 
    
ueberpruefe reservierung: 
  IF disk AND diskette im schacht 
          AND NOT archive ist meins 
     THEN verlange reservierung des archives; 
          LEAVE holen von dateien vom archive 
  FI. 
 
lasse dateien auswaehlen und hole vom archive: 
  t1 := invers ("Holen von Dateien ") + "  Info mit <?>" + 
        trennzeichen + 
        "Bitte alle zu holenden Dateien ankreuzen."; 
  THESAURUS VAR angekreuzte :: some (ALL manager,t1); 
  INT VAR zaehler; 
  TEXT VAR dname; 
  page; 
  FOR zaehler FROM 1 UPTO highest entry (angekreuzte) REP 
      dname := name (angekreuzte, zaehler); 
      disable stop; 
      IF dname <> "" 
         THEN putline (managername + " --> """ + dname + """"); 
              fetch (dname, manager) 
      FI; 
      IF is error 
         THEN LEAVE holen von dateien vom archive 
         ELSE enable stop  
      FI   
  PER 
END PROC holen von dateien vom archive; 
 
PROC loeschen von dateien auf dem archive: 
   ueberpruefe reservierung; 
   lasse dateien auswaehlen und loesche. 
    
 ueberpruefe reservierung: 
   IF disk AND diskette im schacht 
           AND NOT archive ist meins 
      THEN verlange reservierung des archives; 
           LEAVE loeschen von dateien auf dem archive 
   FI. 
 
lasse dateien auswaehlen und loesche: 
  t1 := invers ("Vernichten (Loeschen) von Dateien") + " Info mit <?>" + 
        trennzeichen + "Bitte alle zu loeschenden Dateien ankreuzen."; 
  disable stop; 
  erase (some (ALL manager, t1), manager); 
  IF is error 
     THEN LEAVE loeschen von dateien auf dem archive 
     ELSE enable stop; 
  FI 
END PROC loeschen von dateien auf dem archive; 
 
PROC initialisieren des archives: 
     TEXT VAR neuer archivename; 
     page; 
     line(2); 
     write(center (""15"Vollstaendiges Loeschen des Archivs "14"")); 
     line(2); 
     IF archive ist meins AND diskette im schacht
        THEN write("Eingestellter Archivname: " + 
             invers ("""" + aktueller archivename + """")); 
             line(2); 
             IF yes ("Moechten Sie einen anderen Namen fuer das Archiv") 
                THEN line(2); 
                     stelle frage nach neuem namen 
                ELSE neuer archivename := aktueller archivename 
             FI 
        ELSE stelle frage nach neuem namen  
     FI;  
     fuehre initialisierung durch. 
  
     stelle frage nach neuem namen: 
       write("Bitte den Namen fuer das Archiv (maximal 30 Buchstaben):"); 
       line; 
       getline(neuer archivename); 
       neuer archivename := compress(neuer archivename); 
       IF   length (neuer archivename) > 40 
            THEN line(2); 
                 write ("Der neue Archivname ist zu lang!"); 
                 weitermachen; 
                 LEAVE initialisieren des archives 
       FI. 
  
     fuehre initialisierung durch: 
       disable stop; 
       aktueller archivename := neuer archivename; 
       archive (neuer archivename); 
       IF is error 
          THEN diskette im schacht := FALSE;
               archive ist meins := FALSE;
               LEAVE initialisieren des archives 
          ELSE clear(archive); 
               IF is error 
                  THEN diskette im schacht := FALSE;
                       LEAVE initialisieren des archives 
                  ELSE aktueller archivename := archiv name;
                       diskette im schacht := archiv error = ""
               FI
       FI 
END PROC initialisieren des archives; 
   
PROC ausdruck archivelisting: 
   ueberpruefe reservierung; 
   print archive listing; 
   weitermachen. 
  
ueberpruefe reservierung: 
    IF disk AND diskette im schacht 
            AND NOT archive ist meins 
       THEN verlange reservierung des archives;  
            LEAVE ausdruck archivelisting 
    FI. 
   
print archive listing: 
  FILE VAR listfile := sequential file (output , "PLA");
  INT  VAR i;
  TEXT CONST head :: 70 * "=",
             end  :: 70 * "_";
  TEXT VAR   record;
  disable stop;
  list (listfile, archive);
  IF is error 
    THEN diskette im schacht := FALSE;
         LEAVE ausdruck archivelisting
  FI;
  print head;
  erase dummy names;
  print bottom;
  print and erase listing.

print head :
  modify (listfile);
  to line (listfile, 1);
  FOR i FROM 1 UPTO 6 REP
    insert record (listfile)
  PER;
  to line (listfile, 1);
  write record (listfile, type); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, "ARCHIVNAME: "+headline (listfile) + "  " +
                time of day  +"  " + date ); down (listfile);
  write record (listfile, head); down (listfile);
  write record (listfile, " "); down (listfile);
  write record (listfile, "Date      Store  Contents").

erase dummy names :
  to line (listfile, 6);
  WHILE NOT eof (listfile) REP
    read record (listfile, record);
    IF (record SUB dummy name pos) = "-"
      THEN delete record (listfile)
      ELSE down (listfile) 
    FI 
  PER.

print bottom :
   output (listfile);
   putline (listfile, end).

print and erase listing :
  modify (listfile);
  edit (listfile);
  line (3);
  IF yes ("Archivlisting drucken")
    THEN print ("PLA")
  FI;
  forget ("PLA", quiet).
 
END PROC ausdruck archivelisting;  
 
PROC neue diskette anmelden: 
   ueberpruefe reservierung; 
   melde neue diskette an. 
  
   ueberpruefe reservierung: 
     IF NOT archive ist meins 
       THEN reservieren des archives;  
             LEAVE neue diskette anmelden 
     FI.  
 
   melde neue diskette an: 
     TEXT VAR meldung;  
     page; 
     cursor(1,1); write("Bitte warten..."); 
     line (2); 
     archive anmelden (aktueller archive name,meldung); 
     IF meldung <> "" 
       THEN melde archiveerror (meldung) 
     FI. 
  
END PROC neue diskette anmelden;  
 
PROC automatische freigabe des archives: 
   archive ist meins := FALSE;  
   diskette im schacht := FALSE; 
   command dialogue (FALSE); 
   release(archive); 
   command dialogue (TRUE) 
END PROC automatische freigabe des archives;  
  
PROC melde archiveerror (TEXT CONST meldung): 
   line(2); 
   IF   meldung = "nicht reserviert" 
        THEN verlange reservierung des archives; 
   ELIF meldung = "keine diskette" 
        THEN write (""15"Ich mache die Reservierung rueckgaengig! "14""); 
             neu reservieren 
   ELIF pos (meldung,"inkonsistent") > 0 
        THEN write(""15"Diskette ist nicht formatiert / initialisiert "14""); 
             neu reservieren; 
   ELIF pos(meldung,"Lesen unmoeglich") > 0 
           COR pos(meldung, "Schreiben unmoeglich") > 0 
        THEN write(""15"Die Diskette ist falsch eingelegt "14"");line (2); 
             write(""15"oder das Laufwerk ist nicht geschlossen "14"");line (2); 
             write(""15"oder die Diskette ist nicht formatiert !"14""); 
             neu reservieren; 
   ELIF pos (meldung, "Archiv heisst") > 0 AND pos(meldung, "?????") > 0 
        THEN write(""15"Diskette nicht lesbar ! (Name: '?????') "14"");line(2); 
             write(""15"Moeglicherweise ist die Diskette defekt ! "14"");  
             neu reservieren; 
   ELIF pos(meldung, "Archiv heisst") > 0 
        THEN write (invers(meldung)); 
             line(2); 
             write (""15"Diskette wurde mit anderem Namen angemeldet!"14"");line(2); 
             write("Bitte neu reservieren!"); 
             weitermachen 
   ELSE write(invers(meldung)); 
        neu reservieren 
   FI 
END PROC melde archiveerror; 
 
PROC neu reservieren: 
  line (2); 
  write ("Bitte den Fehler beseitigen und das Archiv neu reservieren !"); 
  weitermachen; 
  diskette im schacht := FALSE
END PROC neu reservieren; 
 
PROC weitermachen: 
  line (2);
  write("Zum Weitermachen bitte irgendeine Taste tippen!"); 
  pause  
END PROC weitermachen; 

PROC melde error (TEXT CONST meldung): 
  page; 
  line(10); 
  write (invers(meldung)); 
  weitermachen 
END PROC melde error 
  
END PACKET mpg dm; 
 
(**************************** TOOLS  *******************************)

PACKET mpg tools DEFINES put,
                         th,
                         gen :
 

lernsequenz auf taste legen ("E", ""27""2""27"p"27"qedit ("27"g)"13""); 

PROC put (BOOL CONST b) :
  IF b THEN put ("TRUE") ELSE put ("FALSE")  FI
END PROC put;

PROC th (THESAURUS CONST thes) :
  THESAURUS VAR help :: SOME thes;help := empty thesaurus
END PROC th;

(************************ Task - Generierung *******************************)

(* Zum Generieren einer TASK ist folgendes zu beachten:

a) Es muss ein Archiv zur Verfuegung stehen, das einen beliebigen Namen hat.
b) Auf diesem Archiv muss es eine Datei namens <"gen." + taskname> geben.
c) Diese Datei muss folgendermassen aufgebaut sein:
   In jeder Zeile steht genau ein Name einer fuer diese TASK wichtigen Datei.
   Die ersten Namen sind Namen von zu insertierenden Dateien.
   Es folgt "gen." + taskname.
   Alle folgenden Dateinamen werden vom Archiv geholt und bleiben in der
   TASK erhalten. *)

BOOL VAR archive access :: FALSE;

PROC hole (TEXT CONST dateiname):
  IF exists (dateiname) 
     THEN display ("***")
     ELSE IF NOT archive access
            THEN archiv;    (* geaendert BV 10.07.86 *)
                 archive access := TRUE
          FI;
          display ("-->");
          from (dateiname)
  FI;
  display (dateiname + ""13""10"")
END PROC hole;

PROC ins (TEXT CONST dateiname):
  line; 
  out (77 * "=" + ""13""10"");
  out (dateiname + " wird insertiert"13""10"");
  insert (dateiname);
  forget (dateiname, quiet)
END PROC ins;

LET anzahl dateien = 50;

ROW anzahl dateien TEXT VAR datei;

INT VAR anzahl zu insertierender,
        gesamtzahl;

PROC gen:
  TEXT CONST taskname :: name (myself),
             gendateiname :: "gen." + taskname;
  TEXT VAR   record;
  BOOL VAR   zu insertieren :: TRUE;

  archive access := FALSE;
  anzahl zu insertierender := 0;
  gesamtzahl               := 0;
  page;
  putline ("GENERIERUNG VON " + taskname);
  putline ((16 + length (taskname)) * "=");
  hole (gendateiname);

  FILE VAR gendatei := sequential file (input, gendateiname);
  WHILE NOT eof (gendatei) AND gesamtzahl < anzahl dateien REP
     getline (gendatei, record);
     record := compress (record);
     IF record = gendateiname
        THEN zu insertieren := FALSE
     FI;
     IF zu insertieren
        THEN anzahl zu insertierender INCR 1
     FI;
     gesamtzahl INCR 1;
     hole (record);
     datei [gesamtzahl] := record
  PER;
  forget (gendateiname, quiet);
  IF archive access
    THEN release;
         line (2);
         put ("Bitte entfernen Sie Ihre Diskette aus dem Laufwerk!"); 
         line
  FI;
  INT VAR i;
  FOR i FROM 1 UPTO anzahl zu insertierender REP
      ins (datei [i])
  PER;
  IF yes ("global manager")
     THEN do ("global manager")
  FI.
END PROC gen
 
END PACKET mpg tools;
 
(********************* MPG TARGET HANDLING *******************) 
 
PACKET target handling DEFINES TARGET, 
                       initialize target, 
                       complete target, 
                       delete in target, 
                       select target, 
                       actual target name, 
                       actual target set, 
                       target names: 
 
 
TYPE TARGET = STRUCT (INT ind, THESAURUS target name, target set); 
 
LET no target = 0; 
 
PROC initialize target (TARGET VAR tar): 
  tar.target set  := empty thesaurus; 
  tar.target name := empty thesaurus; 
  tar.ind         := no target 
END PROC initialize target; 
 
PROC complete target (TARGET VAR tar, TEXT CONST nam, set): 
  IF NOT (tar.target name CONTAINS nam) 
     THEN insert (tar.target name, nam); 
          insert (tar.target set , set) 
     ELSE errorstop ("Bezeichner bereits vorhanden") 
  FI 
END PROC complete target; 
 
PROC delete in target (TARGET VAR tar, TEXT CONST nam): 
  INT CONST ind :: link (tar.target name, nam); 
  delete (tar.target name, ind); 
  delete (tar.target set , ind); 
  tar.ind := no target 
END PROC delete in target; 
 
PROC select target (TARGET VAR tar, TEXT CONST nam, TEXT VAR set): 
  INT VAR ind :: link (tar.target name, nam); 
  IF ind <> 0 
     THEN set     := name (tar.target set , ind); 
          tar.ind := ind 
     ELSE set     := "" 
  FI 
END PROC select target; 
 
TEXT PROC actual target name (TARGET CONST tar): 
  IF tar.ind = no target 
     THEN "" 
     ELSE name (tar.target name, tar.ind) 
  FI 
END PROC actual target name; 
 
TEXT PROC actual target set (TARGET CONST tar): 
  IF tar.ind = no target 
     THEN "" 
     ELSE name (tar.target set, tar.ind) 
  FI 
END PROC actual target set; 
 
THESAURUS PROC target names (TARGET CONST tar): 
  tar.target name 
END PROC target names 
 
END PACKET target handling;

(*********************** MPG PRINT CMD ***********************)

PACKET mpg print cmd DEFINES print, select printer, 
                             install printers, 
                             list printers,
                             printer, printers: 
 
 
TARGET VAR printer list; 
 
LET std printer name = "PRINTER", 
    titel            = "PRINTER AUSWAHL"; 
 
LET trenner = "\#"; 
 
TARGET PROC printers: 
   printer list
END PROC printers;

PROC install printers (FILE VAR f): 
  initialize target (printer list); 
  TEXT VAR nam, set; 
  TEXT VAR std nam :: "", std set :: ""; 
  WHILE NOT eof (f) REP 
    TEXT VAR zeile; 
    getline (f, zeile); 
    IF zeile <> "" 
       THEN INT CONST po :: pos (zeile, trenner); 
            nam := subtext (zeile, 1, po - 1); 
            set := subtext (zeile, po + 1); 
            complete target (printer list, nam, set); 
            IF int (nam) = station (myself) 
               THEN std nam := nam; 
                    std set := set 
            FI 
    FI
  PER; 
  select target (printer list, std nam, std set); 
  IF std set <> "" 
     THEN fonttable (std set) 
  FI 
END PROC install printers; 
 
PROC select printer: 
  TEXT VAR font; 
  select target (printer list, 
     one (target names (printer list), titel,1,24), font); 
  IF font <> "" 
     THEN fonttable (font) 
  FI 
END PROC select printer; 
 
PROC list printers: 
  th (target names (printer list)) 
END PROC list printers; 
 
PROC print : 
  print (last param) 
END PROC print; 
 
PROC print (TEXT CONST file) : 
  save (file, printer) 
END PROC print; 
 
PROC print (THESAURUS CONST thes) : 
  save (thes, printer) 
END PROC print; 
 
TASK PROC printer: 
  INT VAR stat :: int (actual target name (printer list)); 
  IF stat = 0 
     THEN niltask 
     ELSE stat/std printer name 
  FI 
END PROC printer 
 
END PACKET mpg print cmd;
 
(************************ EDIT MONITOR *************************)

PACKET edit monitor DEFINES  edit monitor,    (* Lutz Prechelt      *)
                             F,               (* Carsten Weinholz   *) 
                             table:           (* Thomas Clermont    *) 
                                              (* EUMEL 1.8          *)
                                              (* Version 4.4.1      *)
                                              (* Multimonitor       *)
                                              (* Alphaeditor        *)
                                              (* 06.07.1987         *)
 
LET   command handling line  = 18,  (* muss > max file + 1 und < 23 sein *)
      max file               = 15,  (* max. 20 *)
      file type              = 1003,
      min lines per segment  = 24,  (* darunter wird reorganisiert *)
      integer is allowed     =  3,
      no command             = 4711,
      gib kommando 1         = "Gib Edit-Monitor ",
      gib kommando 2         = " Kommando :";
 
TEXT CONST command list ::"quitmonitor:1.0edit:2.1run:3.1insert:4.1" + 
                          "forget:5.1rename:6.2copy:7.2fetch:8.1"      + 
                          "save:9.1close:10.1fileinfo:11.0reorganize:12.1";
 
LET EDITTABLE = ROW max file STRUCT (THESAURUS line table, 
                                     TEXT      name, 
                                     FILE      file      );
 
LET nil code = 0, 
    edit code= 1, 
    do code  = 2;

INT  VAR command index, number of params, command indices,
         aufruftiefe :: 0,zeile;
 
TEXT VAR param 1, param 2, old command :: "", command line :: "";
BOOL VAR short command, info :: FALSE,verlasse monitor :: FALSE;
INITFLAG VAR this monitor;
 
EDITTABLE VAR etb;
 
PROC edit monitor :
  TEXT VAR ch, old lernsequenz :: lernsequenz auf taste ("Q");
  INT  VAR i, previous heap size :: heap size;
  disable stop;
  initialize;
  get new table;
  REP
    prepare screen;
    perhaps reorganize and get command;
    execute command;
    collect heap garbage if necessary
  UNTIL verlasse monitor PER;
  lernsequenz auf taste legen ("Q",old lernsequenz);
  close all files if not nested.

initialize :
  lernsequenz auf taste legen ("Q",""1""8""1""12"quitmonitor"13"");
  verlasse monitor := FALSE;
  aufruftiefe INCR 1;
  IF aufruftiefe > max file
     THEN aufruftiefe DECR 1; 
          errorstop ("Editmonitor overflow: Bereits " + text (max file ) + "Monitore geoeffnet") 
     ELSE IF NOT initialized (this monitor) 
             THEN FOR i FROM 1 UPTO max file REP 
                      etb [i].line table := empty thesaurus; 
                      etb [i].name := ""
                  PER
          FI; 
          FOR i FROM 1 UPTO max file REP 
            etb [i].name := name (etb [aufruftiefe].line table,i) 
          PER
  FI.

prepare screen :
  calc command handling line; 
  put file info.
 
calc command handling line: 
  out (""10""); (* down *)
  INT VAR dummy, y; 
  get cursor (dummy, y); 
  FOR dummy FROM 1 UPTO y-22 REP
     out (""10"") 
  PER; 
  zeile := max (command handling line, min (y + 1, 22)). 
 
perhaps reorganize and get command :
  BOOL VAR anything reorganized :: FALSE, 
           was error :: FALSE ;
  IF is error
   THEN command line := old command;
        out (""3""); (* up *)
        put error; clear error; was error := TRUE
   ELSE command line := "" 
  FI;
  out (        "      ");
  out (gib kommando);
  out (""13""10"      ");
  IF NOT was error THEN perhaps reorganize  FI;
  IF anything reorganized
  THEN command index := no command;
       LEAVE perhaps reorganize and get command
  FI;
  editget (command line, "", "fk", ch);
  IF ch = ""27"k"
  THEN out (""13""5"");
       command line := old command;
       out ("      ");
       editget (command line, "", "f", ch) 
  FI;
  line;
  old command := command line;
  command index := cmd index (command line);
  param position (LENGTH command line + 7);
  IF (command index > 0 AND command index <= max file) 
                        AND command indices > 0
  THEN short command := TRUE
  ELSE short command := FALSE;
       analyze command (command list, command line, integer is allowed,
                        command index, number of params,param 1, param 2)
  FI.

perhaps reorganize :
  BOOL VAR interrupt;
  ch := getcharety;
  IF ch <> "" 
   THEN push (ch); LEAVE perhaps reorganize 
  FI;
  ch := incharety (50);
  IF ch <> "" 
   THEN type (ch); LEAVE perhaps reorganize 
  FI;
  FOR i FROM 1 UPTO max file REP
    reorganize (etb [i].name, anything reorganized, interrupt, i);
  UNTIL interrupt OR anything reorganized  PER.

close all files if not nested :
  aufruftiefe DECR 1;
  command index := 0; (* Um die verschachtelten Aufrufe zu schuetzen *)
  verlasse monitor := aufruftiefe = 0;
  IF aufruftiefe > 0 
     THEN FOR i FROM 1 UPTO max file REP 
            etb [i].name := name (etb [aufruftiefe].line table,i)
          PER; 
     ELSE param 1      := "";
          param 2      := "";
          command line := "";
          old command  := ""
   FI.

collect heap garbage if necessary :
  IF heap size > previous heap size + 4
  THEN collect heap garbage;
       previous heap size := heap size
  FI
ENDPROC edit monitor;

PROC put file info: 
  INT VAR i;
    out (""1""); (* home *) 
  FOR i FROM 1 UPTO max file WHILE NOT is incharety REP
    out (text (i, 2));
    out (" : ");
    IF info 
     THEN show file info
    FI;
    IF etb [i].name <> "" 
     THEN out ("""" + etb [i].name + """")
    FI;
    out (""5""10""13"")
  PER;
  out(""5"");
  cursor (1, zeile).
 
show file info :
  (* Falls fileinfo an, werden vor den Dateinamen bei FILEs die Anzahl von
     Zeilen , Segmenten und Speicher angezeigt.                         *)
  IF exists (etb [i].name) 
     THEN IF type (old (etb [i].name)) = file type 
           THEN out (text (lines (etb [i].file), 5));
                out (" ");
                out (text (segments (etb [i].file), 4));
                out (" ")
           ELSE out ( 11 * "=")
          FI; 
          out (text (storage (old (etb [i].name)),5))
     ELIF etb [i].name <> ""
     THEN out ( 16 * "=") 
  FI;
  out ("  ").

END PROC put file info; 
 
PROC execute command :
  enable stop;
  IF command index = no command THEN LEAVE execute command  FI;
  IF short command  THEN do edit monitor command (command index) 
                    ELSE case selection  FI.

case selection :
  SELECT command index OF
    CASE 1 : (* quit *)  verlasse monitor := TRUE
    CASE 2 : edit (name from list (param 1))
    CASE 3 : run (name from list (param 1))
    CASE 4 : insert (name from list (param 1))
    CASE 5 : forget (name from list (param 1)); close (int (param1))
    CASE 6 : rename (name from list (param 1) , name from list (param 2))
    CASE 7 : copy (name from list (param 1), name from list (param 2))
    CASE 8 : fetch (name from list (param 1))
    CASE 9 : save (name from list (param 1))
    CASE 10: close (int (param 1))
    CASE 11: info := NOT info
    CASE 12: reorganize (name from list (param 1))
    OTHERWISE do (command line) 
  END SELECT 
END PROC execute command;

PROC close (INT CONST n) :
  IF (n > 0  AND n <= max file)  CAND  etb [n].name <> ""
  THEN IF exists (etb [n].name) CAND type (old (etb [n].name)) = file type
          THEN close (etb [n].file) 
       FI;
       INT VAR id;
       delete (etb [aufruftiefe].line table,etb [n].name,id); 
       etb [n].name := ""
  FI
END PROC close;

TEXT OP F (INT  CONST nr) :
     IF nr > 0 AND nr <= max file
      THEN etb [nr].name
      ELSE out (""7""); "" 
     FI
END OP F;

OP F (INT CONST nr, TEXT CONST datei) :
    IF nr > 0 AND nr <= max file
     THEN etb [nr].name := datei;
          insert (etb [aufruftiefe].line table,datei);
          IF exists (datei) CAND type (old (datei)) = file type
           THEN etb [nr].file := sequential file(modify, datei) 
          FI
     ELSE out (""7"") 
    FI
END OP F;

PROC get new table: 
 table (some (all + etb [aufruftiefe].line table + vorgaenger)). 
 
 vorgaenger: 
  IF aufruftiefe = 1 
   THEN empty thesaurus 
   ELSE etb [aufruftiefe - 1].line table
  FI
END PROC get new table; 
 
THESAURUS PROC table :
  THESAURUS VAR result :: emptythesaurus;
  INT VAR i;
  FOR i FROM 1 UPTO max file REP
    IF exists (etb [i].name) AND NOT (result CONTAINS etb [i].name)
     THEN insert (result, etb [i].name) 
    FI
  PER;
  result
END PROC table;

PROC table (THESAURUS CONST new) :
  INT VAR i, nr :: 1, dummy;
  TEXT VAR t;
  etb [aufruftiefe].line table := empty thesaurus; 
  FOR i FROM 1 UPTO max file REP
    etb [i].name := ""
  PER;
  FOR i FROM 1 UPTO highest entry (new) REP
    get (new, t, dummy);
    IF t <> ""
     THEN nr F t;nr INCR 1
    FI
  UNTIL nr > max file  PER
END PROC table;

PROC do edit monitor command (INT CONST file nr) :
  enable stop;
  IF command indices = 1 
     THEN try to edit or to execute
     ELSE try alpha editor 
  FI.

try to edit or to execute:
  SELECT prepare edit (file nr) OF
    CASE edit code: last param (etb [file nr].name);
                    edit   (etb [file nr].file);
                    page
    CASE do code  : do (etb[file nr].name)
  END SELECT. 
 
try alpha editor: 
  IF command indices <= 10 
     THEN open sub editors; 
          IF groesster editor > 0 
             THEN edit (1); 
                  WHILE groesster editor > 0 REP
                        quit
                  PER;
                  page
          FI
     ELSE errorstop ("Maximal 10 Parallel-Editoren") 
  FI. 
 
open sub editors: 
  TEXT VAR num, edit cmd :: ""; 
  INT VAR ye :: 1, sub :: file nr, pass;
  WHILE groesster editor > 0 REP
        quit
  PER;
  FOR pass FROM 1 UPTO 2 REP 
     IF pass = 2
        THEN command line := edit cmd
     FI;
     scan (command line);
     next symbol (num);                 (* skip ersten index *)
     REP
        INT VAR op code := prepare edit (sub);
        IF pass = 1
           THEN SELECT op code OF
                  CASE nil code : command indices DECR 1
                  CASE editcode : edit cmd CAT (num + " ")
                  CASE do code  : edit cmd CAT (num + " ");
                                  command indices DECR 1 
                END SELECT
           ELSE SELECT op code OF
                  CASE edit code: neuer editor
                  CASE do   code: do (etb [sub].name); 
                                  IF groesster editor > 0 
                                     THEN bild zeigen;     
                                          ueberschrift zeigen 
                                  FI 
                END SELECT
        FI; 
        next symbol (num);
        sub := int (num)
     UNTIL num = "" PER;
     sub := file nr;
  PER.

  neuer editor: 
    open editor (groesster editor+1,etb [sub].file, TRUE, 1,ye,79,25-ye); 
    ye INCR (24 DIV command indices)

END PROC do edit monitor command;

INT PROC prepare edit (INT CONST file nr): 
  IF file nr > 0 AND file nr <= max file
     THEN IF etb [file nr].name = "" 
             THEN get file name and open;
                  IF etb [file nr].name <> "" 
                     THEN IF exists (etb [file nr].name) 
                             THEN IF type (old (etb [file nr].name)) = file type
                                   THEN edit code
                                   ELSE nil code
                                  FI 
                             ELSE do code
                          FI
                     ELSE nil code
                  FI
          ELIF NOT exists (etb [file nr].name)  
             THEN do code
          ELIF type (old (etb [file nr].name)) <> file type
             THEN nil code
             ELSE modify (etb [file nr].file);
                  edit code
          FI 
     ELSE errorstop ("Undefinierter Index [1;15]");nil code
  FI.
  
get file name and open :
  cursor (4, file nr);
  out (""5"? ");
  editget (etb [file nr].name);
  IF etb [file nr].name <> "" 
     THEN file nr F etb [file nr].name; 
          IF NOT exists (etb [file nr].name)
             THEN out (""13""10"");
                  IF no (5 * ""2"" +"Datei neu einrichten")
                     THEN LEAVE prepare edit WITH nil code
                     ELSE kopple file an
                  FI
           ELIF type (old (etb [file nr].name)) = file type
             THEN kopple file an
          FI
   FI. 
 
 kopple file an: 
   etb [file nr].file := sequential file (output, etb [file nr].name). 
 
END PROC prepare edit; 
 
(***************** Hilfsprozeduren *********************************)

BOOL PROC is incharety :
  TEXT VAR ch :: getcharety; 
  IF ch = "" 
   THEN FALSE
   ELSE push (ch); 
        TRUE 
  FI
END PROC is incharety;

TEXT PROC name from list (TEXT CONST name):
  INT  VAR i :: int (name);
  IF (i > 0  AND  i <= max file)
   THEN etb [i].name
   ELSE name
  FI.
END PROC name from list;
 
PROC reorganize (TEXT CONST datei, BOOL VAR reorganization processed,
                                            interrupted, 
                                   INT CONST file nummer): 
  (* Reorganisiert nur , falls :
     1. Datei ein FILE ist
     2. FILE mindestens "min lines to reorganize" Zeilen hat
     3. FILE nicht im Schnitt "min lines per segment" Zeilen pro Segment hat
     4. kein Tastendruck erfolgt
   *)
  DATASPACE VAR ds;
  FILE VAR in, out;
  TEXT VAR t;
  INT VAR actual line,i,x,y;
  get cursor (x,y);
  interrupted := FALSE;
  IF NOT exists (datei) COR type (old (datei)) <> file type
   THEN LEAVE reorganize 
  FI;
  in := sequential file (modify, datei);
  actual line := line no (in); 
  input (in);
  IF (lines (in) < 120 CAND segments (in) < 6) COR 
     lines (in) DIV segments (in) >= min lines per segment
   THEN modify (in);
        to line (in,actual line); 
        LEAVE reorganize
  FI;
  disable stop;
  ds := nilspace;
  out := sequential file (output, ds);
  IF info 
     THEN FOR i FROM 1 UPTO lines (in) REP
              cursor (4, file nummer); 
              put (i);
              getline (in, t);
              putline (out, t);
              IF is error COR is incharety THEN interrupt  FI
          PER 
     ELSE FOR i FROM 1 UPTO lines (in) REP
              getline (in, t);
              putline (out, t);
              IF is error COR is incharety THEN interrupt  FI
          PER
  FI; 
  copy attributes (in,out);
  modify (out);
  to line (out,actual line);
  forget (datei, quiet);
  copy (ds, datei);
  forget (ds);
  reorganization processed := TRUE.

interrupt :
  cursor (4, lines (in)); 
  forget (ds);
  interrupted := TRUE;
  cursor (x,y);
  enable stop;
  LEAVE reorganize.

END PROC reorganize;

INT PROC cmd index (TEXT CONST command line): 
    INT VAR type, result :: 0; 
    TEXT VAR num;
    command indices := 0; 
    scan (command line); 
    REP 
       next symbol (num, type); 
       IF type = 3                     (* Ziffernfolge *) 
          THEN IF command indices = 0 
                  THEN result := int (num) 
               FI; 
               command indices INCR 1 
       ELIF type <> 7 
          THEN command indices := 0 
       FI 
    UNTIL type = 7 OR command indices = 0 PER; 
    result 
END PROC cmd index;

TEXT PROC gib kommando: 
  gib kommando 1 + text (aufruftiefe) + gib kommando 2 
END PROC gib kommando; 
 
END PACKET edit monitor; 
 
(******************************** MANAGER ******************************)
 
PACKET mpg global manager DEFINES monitor, 
                                  break, 
                                  end global manager, 
                                  begin, 
                                  begin password,
                                  manager message,
                                  manager question,
                                  free manager,
                                  std manager,
                                  mpg manager,
                                  free global manager,
                                  global manager :


LET ack              = 0,
    nak              = 1,
    error nak        = 2,
    message ack      = 3,
    question ack     = 4,
    second phase ack = 5,
    false code       = 6,

    begin code       = 4,
    password code    = 9,
    fetch code       = 11,
    save code        = 12,
    exists code      = 13,
    erase code       = 14,
    list code        = 15,
    all code         = 17,

    killer code      = 24, 

    continue code    = 100,
 
    error pre        = ""7""13""10""5"Fehler : ",
    cr lf            = ""13""10"";

 
DATASPACE VAR ds := nilspace;
 
BOUND STRUCT (TEXT fnam, write pass, read pass) VAR msg;
BOUND TEXT VAR reply msg;
 
TASK VAR order task, last order task;
 
FILE VAR list file;
INT VAR reply, order, last order, phase no;
TEXT VAR error message buffer :: "",
         record,
         fnam,
         create son password :: "",
         save write password,
         save read password,
         save file fnam;
 
TEXT VAR std begin proc :: "checkoff;endglobalmanager(TRUE);" +
                           "warnings off;sysout("""");sysin("""");" +
                           "monitor";
BOOL VAR is global manager, is break manager;

PROC mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
                  manager) :
  IF online
    THEN TEXT VAR dummy;
         put ("Task-Passwort  :");
         getsecretline (dummy);
         IF dummy <> "" THEN taskpassword (dummy) FI;
         put ("Beginn-Passwort:");
         getsecretline (dummy);
         IF dummy <> "" THEN begin password (dummy) FI
  FI;
  is break manager  := FALSE;
  global manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
                  manager)
END PROC mpg manager;

PROC global manager :
  mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
               std manager)
END PROC global manager;

PROC global manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
                     TASK CONST) manager) :
   is global manager := TRUE; 
   internal manager (PROC (DATASPACE VAR,INT CONST,INT CONST, 
                     TASK CONST) manager) 
END PROC global manager; 
 
PROC internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST,
                       TASK CONST) manager) :
  old break;
  set autonom;
  disable stop;
  command dialogue (FALSE);
  last order task := niltask;
  remember heap size;
  REP
    wait (ds, order, order task);
    IF   order <> second phase ack
      THEN prepare first phase;
           manager (ds, order, phase no, order task)
    ELIF order task = last order task
      THEN prepare second phase;
           manager (ds, order, phase no, order task)
      ELSE send nak  FI;
    send error if necessary;
    collect heap garbage if necessary
  UNTIL (NOT is global manager) AND (NOT is break manager)
  PER;
  command dialogue (TRUE);
  reset autonom.

send error if necessary :
  IF is error
    THEN forget (ds);
         ds := nilspace;
         reply msg := ds;
         CONCR (reply msg) := error message;
         clear error;
         send (order task, error nak, ds)
  FI .
 
remember heap size :
  INT VAR old heap size := heap size .

collect heap garbage if necessary :
  IF heap size > old heap size + 2
    THEN collect heap garbage;
         old heap size := heap size
  FI .

prepare first phase :
  phase no := 1;
  last order := order;
  last order task := order task.

prepare second phase :
  phase no INCR 1;
  order := last order.

send nak :
  forget (ds);
  ds := nilspace;
  send (order task, nak, ds)
END PROC internal manager;

PROC free global manager :
  mpg manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST)
               free manager)
END PROC free global manager;

PROC std manager (DATASPACE VAR ds, INT CONST order, phase, 
                  TASK CONST order task) :
  IF (order = begin code AND task darf beginnen) COR
                             task darf senden
     THEN free manager (ds, order, phase, order task)
     ELSE errorstop ("Kein Zugriffsrecht auf Task """ + name (myself) + """")
  FI.

  task darf beginnen:
    (task ist systemtask OR task ist sohn) AND is global manager.

  task darf senden:
    task ist systemtask OR task ist sohn.

  task ist systemtask:
    ordertask < supervisor OR ordertask = supervisor.

  task ist sohn:
    order task < myself
END PROC std manager;

PROC free manager (DATASPACE VAR ds, INT CONST order, phase,
                   TASK CONST order task) :
  enable stop;
  IF   order > continue code   AND
       order task = supervisor THEN y maintenance
  ELIF order = begin code AND is global manager
    THEN y begin
    ELSE file manager order
  FI .

file manager order :
  get message text if there is one;
  SELECT order OF
    CASE fetch code       : y fetch
    CASE save code        : y save
    CASE exists code      : y exists 
    CASE erase code       : y erase
    CASE list code        : y list
    CASE all code         : y all
    CASE killer code      : y killer
    OTHERWISE errorstop ("Falscher Auftrag fuer Task """ + name (myself) + """")
  ENDSELECT .
 
get message text if there is one :
  IF order >= fetch code AND order <= erase code AND phase = 1 (* 28.6.'86 *)
    THEN msg := ds;
         fnam := msg.fnam
  FI .
 
y begin :
  BOUND STRUCT (TEXT tname, tpass, TASK task, PROCA start proc) VAR sv msg := ds;
  IF create son password = sv msg.tpass AND create son password <> "-"
    THEN create son task
  ELIF sv msg.tpass = ""
    THEN ask for password
  ELSE   errorstop ("Passwort falsch")
  FI .

create son task :
  begin (ds, PROC std begin, reply);
  send (order task, reply, ds) .

ask for password :
  send (order task, password code, ds) .

y fetch :
  IF read permission (fnam, msg.read pass) COR order task < supervisor
    THEN forget (ds);
         ds := old (fnam);
         send (order task, ack, ds)
    ELSE errorstop ("Passwort falsch")
  FI .
 
y erase :
  msg := ds;
  fnam := msg.fnam;
  IF NOT exists (fnam)
    THEN manager message ("""" + fnam + """ existiert nicht", order task)
  ELIF phase no = 1
    THEN manager question ("""" + fnam + """ loeschen", order task)
  ELIF write permission (fnam, msg.write pass) COR order task < supervisor
    THEN forget (fnam, quiet);
         send (order task, ack, ds)
    ELSE errorstop ("Passwort falsch")  FI .
 
y save :
  IF phase no = 1
    THEN ysave pre
    ELSE y save post  FI.

y save pre :
  IF write permission (fnam, msg.write pass) COR order task < supervisor
    THEN save file fnam := fnam;
         save write password  := msg.write pass;
         save read password   := msg.read pass;
         IF exists (fnam)
           THEN manager question (""""+fnam+""" ueberschreiben", order task)
           ELSE send (order task, second phase ack, ds)
         FI;
    ELSE errorstop ("Passwort falsch")
  FI .
 
y save post :
  forget (save file fnam, quiet);
  copy (ds, save file fnam);
  enter password (save file fnam,
                  save write password, save read password);
  forget (ds);
  ds := nilspace;
  send (order task, ack, ds);
  cover tracks of save passwords.

cover tracks of save passwords :
  replace (save write password, 1, LENGTH save write password * " ");
  replace (save read  password, 1, LENGTH save read  password * " ") .

y exists :
  IF exists (fnam)
    THEN send (order task, ack, ds)
    ELSE send (order task, false code, ds)
  FI.

y list :
  forget (ds);
  ds := nilspace;
  list file := sequential file (output, ds);
  list (list file);
  send (order task, ack, ds) .
 
y all :
  BOUND THESAURUS VAR all fnams := ds;
  all fnams := all;
  send (order task, ack, ds) .
 
y maintenance :
  TEXT VAR  param 1, param 2;
  INT  VAR  c index, nr of params;
  TEXT CONST c list :: "break:1.0end:2.0monitor:3.0stdbeginproc:4.1";
  disable stop;
  call (supervisor, order, ds, reply);
  forget (ds);
  IF reply = ack
    THEN IF is break manager
           THEN end global manager (TRUE);
                LEAVE y maintenance
         FI;
         put error message if there is one;
         REP 
           command dialogue (TRUE);
           get command ("Gib " + name (myself) + "-Kommando :");
           analyze command (c list,0,c index,nr of params,param 1,param 2);
           SELECT c index OF
             CASE 1    : old break
             CASE 2, 3 : is global manager := FALSE;
                         is break manager  := FALSE;
                         LEAVE y maintenance
             CASE 4    : std begin proc := param 1
             OTHERWISE do command
           END SELECT
         UNTIL NOT on line PER;
         command dialogue (FALSE);
         old break;
         set autonom;
         save error message if there is one
  FI;
  enable stop .

put error message if there is one :
  IF error message buffer <> ""
    THEN out (error pre);
         out (error message buffer);
         out (cr lf);
         error message buffer := ""
  FI.

save error message if there is one :
  IF is error
    THEN error message buffer := error message;
         clear error
  FI.

y killer :
  FILE VAR f :: sequential file (input, ds);
  WHILE NOT eof (f) REP
    getline (f, record);
    IF exists (record) THEN forget (record, quiet)  FI
  PER;
  send (order task, ack, ds).
ENDPROC free manager;
 
PROC manager question (TEXT CONST question) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := question;
  send (order task, question ack, ds)
END PROC manager question;

PROC manager question (TEXT CONST question, TASK CONST receiver) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := question;
  send (receiver, question ack, ds)
END PROC manager question;

PROC manager message (TEXT CONST message) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := message;
  send (order task, message ack, ds)
END PROC manager message;

PROC manager message (TEXT CONST message, TASK CONST receiver) :
  forget (ds);
  ds := nilspace;
  reply msg := ds;
  reply msg := message;
  send (receiver, message ack, ds)
END PROC manager message;

PROC std begin :
  do (std begin proc)
ENDPROC std begin;

PROC begin (TEXT CONST task name) :
  TASK VAR sohn;
  begin (task name, PROC monitor, sohn)
END PROC begin;

PROC begin password (TEXT CONST password) :
  cover tracks of old create son password;
  create son password := password;
  display (""3""13""5"");
  cover tracks.

cover tracks of old create son password:
  replace (create son password,1,LENGTH create son password * " ")
END PROC begin password;

PROC end global manager (BOOL CONST ende) :
  is global manager := NOT ende;
  is break manager  := NOT ende
ENDPROC end global manager;

PROC old break :
  eumel must advertise;
  supervisor call (6)
END PROC old break;

PROC break :
  IF is global manager 
    THEN old break; LEAVE break
  FI;
  is break manager  := TRUE;
  is global manager := FALSE; 
  internal manager (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) 
                    std manager)
END PROC break;

PROC supervisor call (INT CONST nr) :
  DATASPACE VAR sv space :: nilspace;
  INT VAR answer;
  call (supervisor, nr, sv space, answer);
  IF answer = error nak
    THEN BOUND TEXT VAR err msg :: sv space;
         forget (sv space); errorstop (err msg)
  FI;
  forget (sv space)
END PROC supervisor call;

 
 
LET cmd list =
 
"edit:1.01end:3.0run:4.01runagain:6.0insert:7.01forget:9.01rename:11.2copy:12.2
list:13.0storageinfo:14.0taskinfo:15.0fetch:16.1save:17.01saveall:19.0";
 
 
INT VAR cmd index , params , previous heap size ;
TEXT VAR param1, param2 ;
 
 
PROC monitor :
  disable stop ;
  previous heap size := heap size ;
  REP 
    command dialogue (TRUE); 
    sysin (""); 
    sysout (""); 
    cry if not enough storage; 
    get command ("gib kommando :"); 
    analyze command (cmd list, 4, cmd index, params, param1, param2);
    execute command ;
    collect heap garbage if necessary
  PER .
 
collect heap garbage if necessary :
  IF heap size > previous heap size + 4
    THEN collect heap garbage ;
         previous heap size := heap size
  FI.

cry if not enough storage : 
  INT VAR size, used; 
  storage (size, used); 
  IF used > size 
    THEN out (""7"Speicher Engpass! Dateien loeschen!"13""10"") 
  FI. 
ENDPROC monitor ;

PROC execute command :
  enable stop ;
  SELECT cmd index OF
    CASE 1 : edit
    CASE 2 : edit (param1)
    CASE 3 : end
    CASE 4 : run
    CASE 5 : run (param1)
    CASE 6 : run again
    CASE 7 : insert
    CASE 8 : insert (param1)
    CASE 9 : forget
    CASE 10: forget (param1)
    CASE 11: rename (param1, param2)
    CASE 12: copy (param1, param2)
    CASE 13: list
    CASE 14: storage info
    CASE 15: task info
    CASE 16: fetch (param1)
    CASE 17: save
    CASE 18: save (param1)
    CASE 19: save all 
    OTHERWISE do command
  ENDSELECT .
 
ENDPROC  execute command ;

END PACKET mpg global manager