PROGRAM DoitCompiler;
(* --------------------------------------------------------- *)
(*      Doit-Yourself Compiler                               *)
(*                                                           *)
(*      Autor : Helmut Richter                               *)
(*      Version : 2.1  Datum: 4. Februar 1986                *)
(*                                                           *)
(* Die Parser-Prozeduren werden hier nur so weit noch        *)
(* einmal gezeigt, wie gegenueber der Fassung in Teil 3      *)
(* fuer die Codegenerierung Ergaenzungen notwendig sind.     *)
(* --------------------------------------------------------- *)
(*$U-,C+,A-*)

CONST (*$I SCCONST.INC *)
(*    Adressen der Sprungvektoren aller Funktionen des Run-  *)
(*    Time- Systems (Library)                                *)
      ReadInt  =  4; (* Systemfunktionen (READ/WRITE)        *)
      ReadChar =  7; WriteInt = 10; WriteChar = 13;
      Addop    = 16; (* Arithmetische Operationen            *)
      SUBop    = 19; NEGop    = 22; Multop    = 25;
      DIVop    = 28; MODop    = 31;
      ODDop    = 34; (* Logische Operationen                 *)
      EQLop    = 37; NEQop    = 40; GTRop     = 43;
      LSSop    = 46; GEQop    = 49; LEQop     = 52;

(* Anzahl der "Maschinen"operationen, der virtuellen CPU     *)
      MaxOp = 14;  (* Index beginnt bei 0 !                  *)
      Memo : ARRAY[0.. MaxOp] OF STRING [13] =

(* Stackmaschinenbefehl OpCode                               *)
      ('LoadInTConst ', (*  0 *) 'LoadCharConst', (*  1 *)
       'Operation    ', (*  2 *) 'LoadIntVar   ', (*  3 *)
       'LoadCharVar  ', (*  4 *) 'SaveIntVar   ', (*  5 *)
       'SaveCharVar  ', (*  6 *) 'Call Proc    ', (*  7 *)
       'Decr_SP      ', (*  8 *) 'Jump         ', (*  9 *)
       'Jump Cond    ', (* 10 *) 'Call RTsystem', (* 11 *)
       'Return       ', (* 12 *) 'Save_ BP     ', (* 13 *)
       'Init SP_BP   ');(* 14 *)

TPA_Anfang = $100;  (* Anfang von CP/M-Programmen:           *)

(* Startadresse des Maschinenprogramms: TPA + Laenge RTS     *)
      MCode_Offset   = $200;
      ZCode_Offset   = 0;     (* Startadresse des Zwischencode *)
      ASMCode_Offset = $200;  (* Startadresse des Assemblercodes *)

(* Laenge des Patchfeldes fuer die Rueckwaertsspruenge:      *)
      MaxPatch = 40;
      Test     = FALSE;

TYPE (*$I SCTYPE.INC *)
     ObjektTyp = (INTEGER_Objekt, Character_Objekt,
                  FehlerObjekt);  (* verfuegtbare Typen      *)
     ... STR10, Objektklasse u. ObjPtr wie gehabt ...
     Objekt = RECORD ...
                CASE kind : ObjektKlasse OF
                     ...
                     Prozedur : (ZWC_StartAdresse,
                                 ASM_StartAdresse,
                                 COM_StartAdresse: INTEGER);
                     CharVar, IntVar : (DatenAdresse, Vlevel
                                     : INTEGER);
                     Header : (Last, Down : ObjPtr);
              END;

(* Typen fuer die EXIT-Sprung-Liste                          *)
        ExitListenTyp = (Hdr, Blatt);
        ExitPtr       = ^ExitListe;
        ExitListe     = RECORD
                          L : INTEGER; next : ExitPtr;
                          CASE ElementTyp : ExitListenTyp OF
                               Blatt : ();
                               Hdr   : (Last, Down : ExitPtr);
                        END;
        Str40      = STRING[ 40];  Str7 = STRING[  7];
        Str4       = STRING[  4];  Str2 = STRING[  2];
        Dateitypen = (SRC, COM, PRN, ZWC, ASM);

(* Typen fuer Assembler- und Zwischencode                    *)
        ZCode_Instruction = RECORD  (* Zwischencode-Befehl   *)
              nr : INTEGER;         (* Nummer des Befehls    *)
              bc : 0..MaxOp;        (* Befehlscode           *)
              Iv : 0..15;           (* Level des Programms   *)
              ad : INTEGER:         (* Adresse des Datums    *)
              km : str40;           (* Kommentar             *)
              END;
        ASM_Instruction = RECORD  (* Assembler-Befehl        *)
              nr : INTEGER;       (* Nummer des Befehls      *)
              bc : Str4;          (* Operationscode          *)
              op1,                (* Operand 1               *)
              op2: Str7;          (* Operand 2               *)
              km : Str40;         (* Kommentar               *)
              END;
        PatchInfo = RECORD  (* Typ fuer das Patchfeld        *)
              (* Zwischencode-Advesse und -Patchwert         *)
              Z_Adresse, Z_Patch,
              (* Assemblercode-Adresse und -Patchwert        *)
              A_Adresse, A_Patch : INTEGER;
              (* Indikator fuer Art des Sprunges             *)
              JPC                : BOOLEAN;
              (* Maschinencode-Adresse und -Patchwert        *)
              M_Adresse, M_Patch : INTEGER;
              END;

VAR (*$I SCVAR.INC *)
    TopScope, Bottom : ObjPtr;
    ProgrammName     : T_Name;
    (* Variable zur Feststellung der Rekursionstiefe         *)
    level            : INTEGER;
    (* Variable zur Pruefung der Typengleichheit             *)
    Expression_Typ   : Objekt_Typ;
    (* Variable fuer Zwischen- und Assemblercodebefehle      *)
    ZCode            : ZCode_Instruction;
    ASMCode          : ASM_Instruction;
    ZCode_Adresse,  (* Nachster freier Zwischencodebefehl    *)
    MCode_Adresse,  (* Nachster freier Maschinenbefehl       *)
    ASMCode Adresse  : INTEGER; (* " " Assemblerbefehl       *)
    ExitSprung       : ExitPtr;
    (* Deklarationen der Compilerdateien                     *)
    Source, COM_File, List : TEXT;
    ZWC_File         : FILE OF ZCode_Instruction;
    ASM_File         : FILE OF ASM_Instruction;
    (* Feld zur Markierung geoeffneter Dateien:              *)
    Ist_offen        : ARRAY[DateiTypen] OF BOOLEAN;
    (* Schalter fuer die Ausgabedatei-Generierung:           *)
    COM_Gen, ListOn, ASM_Gen, ZWC_Gen,
    (* Variable zur Markierung des Bedingten Sprunges        *)
    Jump_on_Condition: BOOLEAN;
    (* Deklarationen fuer die Sprungadressenverwaltung       *)
    (* Patchfeld und sein Zaehler                            *)
    PatchFeld        : ARRAY[1..MaxPatch] OF Patchinfo;
    ipatch,
    (* Fortlaufende Nummer einer Variablen in ihrer Symbol-  *)
    (* tabelle (dient zur Berechnung ihres Stackoffsets)     *)
    DatenNr          : INTEGER;

PROCEDURE Wait;
BEGIN REPEAT UNTIL KeyPressed; END (* Wait *);

FUNCTION AdressZahl(i:integer):REAL;
BEGIN
  IF i < 0 THEN AdressZahl:=65536.0+i ELSE AdressZahl:=0.0+i;
END (* AdressZahl *);

FUNCTION Exist(DateiName:Str40):BOOLEAN;
VAR Datei : File;
BEGIN (* Testet, ob die Datei mit Namen (DateiName) existiert *)
  Exist := FALSE; ASSIGN(Datei,DateiName);
  (*$I-*) RESET(Datei); (*$I+*)
  IF (IOResult = 0) THEN BEGIN CLOSE(Datei); Exist := TRUE; END
     ELSE BEGIN HighVideo;
     WRITELN('Datei',DateiName,' existiert nicht.'); NormVideo;
  END;
END (* Exist *);

(*$I PARS-001.INC *)  (* Alle Scannerprozeduren.             *)
(*$I DC-002.INC   *)  (* Codegenerator GEN                   *)
(*$I DC-003.INC   *)  (* Hilfsprozeduren zur Codegenerierung *)
(*$I PARS-002.INC *)  (* Hilfsprozeduren des Parsers/EXITver.*)
(*$I PARS-003.INC *)  (* Prozeduren Expression, Statement.   *)
(*$I PARS-004.INC *)  (* Prozeduren Block, Parse.            *)
(*$I DC-007.INC   *)  (* Hilfsprozeduren  des Compilers.     *)
(*$I DC-008.INC   *)  (* Dialogprozeduren des Compilers      *)

BEGIN InitDC;  (* -- DOIT - Hauptprogramm ------------------ *)
  REPEAT DisplayMenue;  (* -- Hauptschleife des Compilers -- *)
    IF ch = ' C' THEN Compile;
  UNTIL (ch = 'Q') OR (ch = 'X');
  Schliessedateien;
END.

(* --------------------------------------------------------- *)
(* Modul DC-001.INC  (PARS-001.INC)                  Scanner *)
(* --------------------------------------------------------- *)

Der Scanner bleibt im wesentlichen unveraendert.
In InitScanner muessen die Dateimanipulationen entfernt werden.
(Geschehen nun in InitParser). Sie sieht jetzt so aus:

PROCEDURE InitScanner;
BEGIN (* InitScanner *)
  ClrScr; Ctrl := ' '; sym := Null; intval := 0; Charval := ' ';
  errcount := 0; lesen := TRUE; Noerr := TRUE; ch := ' ' ;
  SwT(. 1.).s := 'BEGIN';  SwT(. 1.).NR := 32;
  ... Initialisierung der  Schluesselworttabelle ..
  SwT(.18.).s := 'WRITE';  SwT(.18.).NR := 41;
  ClrScr; HighVideo; WRITELN('Compiling...');
  WRITELN; NormVideo; Satz := '' ; Fuellepuffer;
END (* InitScanner *);

PARAMCOUNT und PARAMSTR muessen vor InitScanner gezogen
werden, um global erreichbar zu sein. (Nur TURBO 2.0)
SYMNAME, PROMPT und alle ihre Referenzen koennen entfernt werden.

(* --------------------------------------------------------- *)
(* Modul DC-002.INC                            Codegenerator *)
(* --------------------------------------------------------- *)

PROCEDURE Gen(x, y, z:INTEGER; Kommentar:str40);
(* Generiering von Stackmaschinen-Code (Rest naechstes Heft) *)
BEGIN
  IF Noerr THEN BEGIN
     WITH ZCode DO BEGIN
       nr:=ZCode_Adresse; bc:=x; lv:=y; ad:=z; km:=Kommentar;
     END;
     IF ZWC_Gen THEN WRITE(ZWC_File,ZCode);
     ZCode_Adresse := ZCode_Adresse + 1;
  END;
END (* Gen *);

(* --------------------------------------------------------- *)
(* Modul DC-003.INC       Hilfsprozeduren des Codegenerators *)
(* --------------------------------------------------------- *)

PROCEDURE FixUp(adresse : INTEGER);
BEGIN  (* Backpatching der Spruenge und Unterprogrammaufrufe *)
  WITH PatchFeld[adresse] DO BEGIN Z_Patch := ZCode_Adresse;
    A_Patch := ASMCode_Adresse; M_Patch := MCode_Adresse;
  END;
END (* FixUp *);

PROCEDURE BackPatch: (* -- Vorwaertsspruence patchen ------- *)

  PROCEDURE PatchZWCFile;
  (* Patches per RANDOM-ACCESS in die richtigen Saetze       *)
  (* schreiben. Zugriff enfolgt ueber die Satznummer.        *)
  VAR ZCode2 : ZCode Instruction;
        i, j : INTEGER;
  BEGIN
    WRITELN; WRITELN('Zwischencode-File...');
    RESET(ZWC_File); i := 1;
    WHILE i < ipatch DO BEGIN
      WITH ZCode2 DO WITH PatchFeld[i] DO BEGIN
        1 := Z_Adresse - ZCode_Offset :
        (* Random Access: gewuenschten Satz suchen und in    *)
        (* ZCode2 lesen. Achtung: der Satzzeiger rueckt      *)
        (* einen Satz vor!                                   *)
        SEEK(ZWC_File,j); READ(ZWC_File,ZCode2);
        (* Patch eintragen, ...                              *)
        ad := Z_Patch;
        (* ... Satzzeiger nochmal auf alten Sektor           *)
        (* positionieren und zurueckschreiben.               *)
        SEEK(ZWC_File, j); WRITE(ZWC_File, ZCode2);
        (* Patchinfo auf Bildschirm schreiben.               *)
        WRITELN('Patch Nr: ',i:2,'  Adresse:',Z_Adresse:5,
                '  Patch: ',Z_Patch:5,'     SatzNr: ',j:3);
        i := i + 1;
      END;
    END;
  END (* PatchZWCFile *);

  PROCEDURE PatchASMFile;
  BEGIN END;

  PROCEDURE PatchCOMFile;
  BEGIN END;

BEGIN (* BackPatch *)
  WRITELN; WRITELN; WRITE('Backpatching: ');
  IF ZWC_Gen THEN PatchZWCFile; IF ASM_Gen THEN PatchASMFile;
  IF COM_Gen THEN PatchCOMFile;
  WRITELN('-- Fertip mit Backpatching --');
END (* BackPatch *);

PROCEDURE MakeData (VAR adr:INTEGER; Laenge:INTEGER);
(* Erzeugt Adresse fuer Daten auf Stack                      *)
BEGIN  (* hier: 2 Byte pro Variable!!!                       *)
  adr := DatenNr; DatenNr := DatenNr + Laenge;
  (* StackPointer <Laenge>-mal decrementieren !              *)
  Gen(8,0,2,'Platz fuer Daten schaffen');
END (* MakeData *);

FUNCTION MakeLabel : INTEGER;
BEGIN
  WITH PatchFeld[ipatch] DO BEGIN
    Z_Adresse := ZCode_Adresse;
    IF Jump_on_Condition THEN BEGIN
       A_Adresse := ASMCode_Adresse + 3;
       M_Adresse := MCode_Adresse + 4; JPC := TRUE;
    END ELSE BEGIN
       A_Adresse := ASMCode_Adresse;
       M_Adresse := MCode_Adresse + 1; JPC := FALSE:
    END;
    Z_Patch := 0; A_Patch := 0; M_Patch := 0;
  END;
  MakeLabel := ipatch; ipatch := ipatch + 1;
  IF ipatch > MaxPatch THEN BEGIN HighVideo;
     WRITELN('Patchfeld overflow - mehr als ', MaxPatch:2,
     ' Spruenge - Nothalt - press key');NormVideo; Wait;
  END;
END (* MakeLabel *);

(* ---------------------------------------------------------- *)
(* Modul DC-004.INC (PARS-002.INC) Hilfsprozeduren des Parser *)
(* ---------------------------------------------------------- *)

FUNCTION TypenGleich (Typ1, Typ2:0bjekt_Typ):BOOLEAN;
(* Testet auf Typengleichheit. Ist einer der beiden der      *)
BEGIN  (* Fehler Typ, so muss FALSE geliefert werden.        *)
  IF (Typ1 = Febler_Objekt) OR (Typ2 = Fehler_Objekt) THEN
  TypenGleich := FALSE ELSE TypenGleich := (Typ1 = Typ2);
END (* TypenGleich *);

PROCEDURE ProcCall(Obj:ObjPtr);
(* Bearbeiting eines Unterprogrammaufrufs                    *)
BEGIN  (* Ausnahme: keine Adresse sondern Zeiger auf Symbol- *)
  (* tabelle (als INTEGER getarnt) an GEN uebergeben.        *)
  Gen(7,1,ORD(Obj),'Unterprogramm rufen'); GetSym;
END (* ProcCall *);

FUNCTION NewObj(k : Objektklasse) : ObjPtr;
  ...
  (* Neues Element anlegen *)
  ...
  CASE Kind OF
       Nix          :   Typ := Fehler_Objekt;
       CharacterCon : BEGIN CWert := CharVal;
                        Typ := Character_Objekt; END;
       INTEGERCon   : BEGIN IWert := IntVal;
                        Typ := Integer_Objekt; END;
       Prozedur     : BEGIN ZWC_StartAdresse := 0;
                        ASM_StartAdresse := 0;
                        COM_StartAdresse := 0; END;
       CharVar      : BEGIN MakeData(DatenAdresse, 1);
                        Typ := Character_Objekt; END;
       IntVar       : BEGIN MakeData(DatenAdresse, 2);
                        Typ := Integer_Objekt; END;
  END (* CASE Kind OF *);

FIND, TESTSYM und TESTSEMICOLON bleiben unveraendert. Neu sind:

PROCEDURE NewExitListe;
(* Initialisierung der Liste der EXIT-Spruenge mit Header    *)
VAR ExitListenKopf : ExitPtr;
BEGIN NEW(ExitListenKopf);
  WITH ExitListenKopf^ DO BEGIN
    ElementTyp := Hdr; L := -Maxint; next := NIL;
    Last := ExitListenKopf; Down := ExitSprung;
  END;
  ExitSprung := ExitListenKopf;
END (* NewExitListe *);

PROCEDURE EnterExitListe(Labl : INTEGER);
(* Eintrag eines EXIT-Statements                             *)
VAR Eintrag : ExitPtr;
BEGIN NEW(Eintrag);
  WITH Eintrag^ DO BEGIN
    ElementTyp := Blatt; L := Labl; next := NIL;
  END;
  WITH ExitSprung^ DO BEGIN
    Last^.next := Eintrag; Last := Eintrag;
  END;
END (* EnterExitListe *);

PROCEDURE FixUpExitListe;
(* "Backpatching" der Exit-Spruenge eines DO..OD-Levels      *)
VAR Zeiger : ExitPtr;
BEGIN Zeiger := ExitSprung^.next;
  WHILE Zeiger <> NIL DO BEGIN
    FixUp(Zeiger^.L); Zeiger := Zeiger^.next;
  END;
  ExitSprung := ExitSprung^.Down;
END (* FixUpExitListe *);

(* --------------------------------------------------------- *)
(* Modul DC-005.INC (PARS-003.INC)         Analyseprozeduren *)
(* --------------------------------------------------------- *)

PROCEDURE Expression;
(* Die Pruefung der Typengleichheit in Ausdruecken geschieht *)
(* mit Hilfe von TYPENGELEICH, der lokalen Variablen         *)
(* FAKTOR_TYP, TERM_TYP, EXPRESSION TYP (global).            *)
VAR Operation : Symbol; Faktor_Typ, Term_Typ : Objekt_Typ;

  PROCEDURE factor;
  VAR Obj: ObjPtr;
  BEGIN TestSym(Lparent,95) ;
    IF sym = identifier THEN BEGIN Obj := Find(idname);
       WITH Obj^ DO CASE kind OF
         IntegerCon   : Gen(0,0,IWert,
                       'Lade Integerkonstante ' + idname);
         CharacterCon : Gen(1,0,ORD(CWert),
                       'Lade Characterkonstante ' + idname);
         IntVar       : Gen(3,Level-Vlevel,Datenadresse,
                       'Lade Integervariable ' + idname);
         CharVar      : Gen(4,Level-Vlevel,Datenadresse,
                       'Lade Charactervariable ' + idname);
         Prozedur     : Error(21,
                       'Prozeduren hier nicht erlaubt');
         ELSE ;
       END;
       Faktor_Typ := Obj^.Typ; GetSym;
    END ELSE IF sym = Intcon THEN BEGIN
        Faktor_Typ := Integer_Objekt;
        Gen(0,0,IntVal,'direkte INTEGERkonstante'); GetSym;
    END ELSE IF sym = Charcon THEN BEGIN
        Faktor_Typ := Character_0bjekt;
        Gen(1,0,ORD(CharVal),'direkte Characterkonstante'); GetSym;
    END ELSE IF sym = Hexcon THEN BEGIN
        Faktor_Typ := Character_Objekt;
        Gen(1,0,0RD(CharVal),'direkte Hexkonstante'); GetSym;
    END ELSE IF sym = lparent THEN BEGIN GetSym;
        Expression; Faktor_Typ := Expression_Typ;
        IF sym = Rparent THEN GetSym ELSE Error(7,'")" erwartet');
    END ELSE BEGIN
        Faktor_Typ := Fehler_Objekt; Error(18,'Ausdruck erwartet');
    END;
END (* Factor *);

PROCEDURE Term;
VAR mulop : Symbol; Faktor1_Typ : Objekt_Typ;
BEGIN Factor; Term_Typ := Faktor_Typ;
  WHILE (times <= sym) AND (sym (= modsy) DO BEGIN
    mulop := sym; GetSym; Factor;
    IF TypenGleich(Term_Typ,Faktor_Typ) THEN BEGIN
       Term_Typ := Faktor_Typ;
       CASE mulop OF
            times : Gen(2,0,MULTop,'Multiplikation durchfuehren');
            divsy : Gen(2,0,DIVop,'Division durchfuehren');
            modsy : Gen(2,0,MODop,'Modulo durchfuehren');
       END (* CASE mulop OF ... *);
    END ELSE BEGIN Term_Typ := Fehler_Objekt;
        Error(50,'in Term');
    END (* IF TypenGleich THEN ... *);
  END (* WHILE (times <= ... *);
END (* Term *);

BEGIN (* Expression *)
  IF (plus <= sym) AND (sym <= minus) THEN BEGIN
     Operation := sym; Get Sym; Term;
     IF Operation = minus THEN
        Gen(2,0,NEGop,'Vorzeichen Minus behandeln');
  END ELSE Term;
  Expression_Typ := Term_Typ;
  WHILE (plus <= sym) AND (sym <= minus) DO BEGIN
    Operation := sym; GetSym; Term;
    IF TypenGleich(Expression_Typ,Term_Typ) THEN BEGIN
       Expression_Typ := Term_Typ;
       IF Operation = plus THEN
          Gen(2,0,ADDop,'Addition durchfuehren')
       ELSE Gen(2,0,SUBop,'Subtraktion durchfuehren');
    END ELSE BEGIN
        Expression_Typ := Fehler_Objekt; Error(50,'in Expression')
    END (* IF TypenGleich THEN ... *);
  END (* WHILE (plus .= ... *);
END (* Expression *);

PROCEDURE Condition;
VAR relop : Symbol; Condition_Typ : Objekt_Typ;
BEGIN
  IF sym = odd THEN BEGIN Getsym; Expression;
     IF Expression_Typ <> Integer_Objekt THEN
        Error(51,'Nach ODD Integer erwartet');
     Gen(2,0,ODDop,'ODD-Test durchfuehren');
  END ELSE BEGIN
     Expression; Condition_Typ := Expression_Typ;
     IF (eql <= sym) AND (sym <= geq) THEN BEGIN
        relop := sym; Getsym; Expression;
        IF NOT TypenGleich(Condition_Typ,Expression_Typ) THEN
           Error(50,'Typenungleichheit in Condition');
        CASE relop OF
             eql : Gen(2,0,EQLop,'Gleichheit testen');
             neq : Gen(2,0,NEQop,'Ungleichheit testen');
             lss : Gen(2,0,LSSop,'Kleiner testen');
             geq : Gen(2,0,GEQop,'Groesser-gleich testen');
             gtr : Gen(2,0,GTRop,'Groesser testen');
             leq : Gen(2,0,LEQop,'Kleiner-gleich testen');
        END (* Case *);
     END ELSE Error(20,'Relation erwartet');
  END (* IF sym = odd THEN ... *);
END (* Condition *);

PROCEDURE Statement;
VAR Obj : ObjPtr; L0, L1 : INTEGER; Folgesymbole : SET OF symbol;

  PROCEDURE IFstatement;
  LABEL 99;
  VAR L0, L1 : INTEGER; NurThenTeil : BOOLEAN;
  BEGIN NurThenTeil := FALSE;
    GetSym; Condition;
    IF sym = THENsy THEN BEGIN NurThenTeil := TRUE; GetSym;
       (* Konditionaler Sprung hinter den THEN-Block, falls  *)
       (* CONDITION = FALSE.                                 *)
       Jump_on_Condition := TRUE;
       L0 := MakeLabel; Gen(10,0,0,'Sprung auf ELSE-Teil');
       Jump_on_Condition := FALSE;
       Folgesymbole := (.ELSEsy, FIsy, ENDsy, period, eofsy.);
       REPEAT Statement; UNTIL sym in Folgesymbole;
       IF sym = ELSEsy THEN BEGIN
          (* Sprung hinter den ELSE-Block nach durchlaufen   *)
          (* des THEN-Zweiges.                               *)
          L1 := MakeLabel;
          Gen(9,0,0,'Sprung hinter ELSE-Teil');
          (* Ansprungadresse des Sprungs ueber den THEN-Block *)
          (* eintragen (entspricht CONDITION = FALSE)         *)
          FixUp(L0); NurThenTeil := FALSE; Getsym;
          Folgesymbole := (.FIsy, ENDsy, period, eofsy.);
          REPEAT Statement;
            IF sym = ELSEsy THEN BEGIN
               Error(16,'FI erwartet'); GOTO 99; END;
          UNTIL sym IN Folgesymbole;
          (* Ansprungadresse des Sprungs ueber den ELSE-Block *)
          (* eintragen.                                       *)
          FixUp(L1);
       END;
       IF NurThenTeil THEN FixUp(L0);
       IF sym = FIsy THEN GetSym ELSE Error(16,'FI erwartet');
    END ELSE Error(15,'THEN erwartet');
  99:
  END (* IFstatement *);

BEGIN (* Statement *) TestSym(semicolon,98);
  IF sym = Identifier THEN BEGIN Obj := Find(idname);
     IF Obj^.kind = Prozedur THEN ProcCall(Obj)
     ELSE IF Obj^.kind = IntVar THEN BEGIN GetSym;
       IF sym = becomes THEN GetSym
          ELSE Error(11,':= erwartet');
       Expression;
       IF NOT TypenGleich (INTEGER Objekt, Expression_Typ) THEN
          Error(50,'in INTEGERausdruck' )
       ELSE WITH Obj^ DO Gen(5,Level-vlevel,Datenadresse,
       'Save Integer ' + Name);
     END ELSE IF Obj^.kind = ChanVar THEN BEGIN GetSym;
     IF sym = becomes THEN GetSym
        ELSE Error(11,':= erwartet' );
     Expression;
     IF NOT TypenBleich (Character_Objekt, Expression_Typ)
        THEN Error(50,'in Characterausdruck')
        ELSE WITH Obj^ DO Gen(6,Level-vlevel,Datenadresse,
        'Save Character ' + Name);
     END ELSE IF Obj^.Kind = NIX THEN BEGIN GetSym;
        IF sym = Semicolon THEN ProcCall (Obj)
           ELSE BEGIN (* Variablenname / Zuweisung *)
             IF sym = becomes THEN Get Sym
                ELSE Error(11,':= erwartet' );
        Expression;
     END;
  END;
END ELSE IF sym = IFsy THEN IFstatement
ELSE IF sym = DOsy THEN BEGIN
  Folgesymbole := (.ODsy, ENDsy, period, eofsy.);
  (* Ansprungadresse fuer das Ende der DO...OD-Schleife   *)
  L0 := MakeLabel;
  (* Liste fuer moegliche Exit-Spruenge anlegen              *)
  NewExitListe; GetSym;
  REPEAT Statement; UNTIL sym in Folgesymbole;
  IF sym = ODsy THEN GetSym ELSE Error(17,'OD erwartet');
  (* Sprung rueckwaerts zum Anfang des DO...OD-Blocks        *)
  (* (Adresse vom DO im Patch-Feld umsetzen)                 *)
  WITH PatchFeld[L0] DO BEGIN
    Z_Patch := Z_Adresse;   Z_Adresse := ZCode_Adresse;
    A_Patch := A_Adresse;   A_Adresse := ASMCode_Adresse;
    M_Patch := M_Adresse-1; M_Adresse := MCode_Adresse+1;
  END;
  Gen(9,0,0,'DO..OD: Ruecksprung zum DO');
  (* Falls zwischen DO und OD EXIT(s) vorlag(en), muss       *)
  (* die ExitListe abgearbeitet werden.                      *)
  FixUpExitListe;
END ELSE IF sym = EXITsy THEN BEGIN
  (* EXIT kann auch ausserhalb von DO..OD-Schleifen ver-     *)
  (* wendet werden. Es simuliert dann ein RETURN.            *)
  (* ExitSprung = NIL bedeutet, dass kein DO..OD vorliegt.   *)
  IF ExitSprung = NIL THEN NewExitListe;
  EnterExitListe(MakeLabel); Gen(9,0,0,'EXIT-Sprung'); GetSym;
END ELSE IF sym = READsy THEN BEGIN GetSym;
  IF sym = Identifier THEN BEGIN Obj := Find(idname);
  WITH Obj^ DO BEGIN
    IF Kind = IntVar THEN BEGIN  (* Integervariable          *)
       (* UP READ_Integer aufrufen *)
       Gen(11,0,ReadInt,'INTEGER einlesen');
       (* Integer-Variable sichern *)
       Gen(5,Level-vlevel,DatenAdresse,'und sichern')
    END ELSE IF kind <> Prozedur THEN
       BEGIN  (* Charactervariable *)
         (* UP READ_Character aufrufen *)
         Gen(11,0,ReadChar,'Character einlesen');
         (* Character-Variable sichern *)
         Gen(6,Level-vlevel,DatenAdresse,'und sichern');
       END ELSE Error(21,'Prozeduren sind hier nicht erlaubt');
  END (* With *);
  Getsym;
END ELSE Error(14,'Nach READ mu~ Identifier folgen');
END ELSE IF sym = WRITEsy THEN BEGIN GetSym;
  IF sym = semicolon THEN BEGIN
     Gen(1,0,13,'Lade 0Dh'); Gen(11,0,WriteChar,'CR schreiben')
     Gen(1,0,10,'Lade 0Ah'); Gen(11,0,WriteChar,'LF schreiben')
  END ELSE BEGIN Expression;
     IF Expression Typ = INTEGER Objekt THEN
        Gen(11,0,Writelnt,'INTEGER schreiben')
     ELSE Gen(11,0,WriteChar,'Character schreiben');
  END
END ELSE . . .
END (* Statement *);

(* ----------------------------------------------------------- *)
(* Modul DC-006.INC (PARS-004.INC) Hilfs/Analyseproc' s Parser *)
(* ----------------------------------------------------------- *)

PROCEDURE Block;
...
VAR ...
    L0 : INTEGER;
... ConstDeklaration bleibt gleich ...

PROCEDURE VarDeclarat ion;
VAR Obj : ObjPtr; Name : T_Name;
BEGIN Name := '';
  ...
  IF sym = Charsy THEN BEGIN Idname := Name;
     Obj := NewObj(CharVar); Obj^.VLevel := Level; GetSym;
  END ELSE IF sym = Intsy THEN BEGIN Idname := Name;
      obj := NewObj(Int Var) ; Obj^.VLevel := Level; GetSym;
  END ELSE Error(33,'Nach ":" INT oder CHAR erwartet')
END (* VarDeclaration *);

BEGIN (* -- Block ------------------------------------------ *)
...
  IF level = 0 THEN Bottom := hd;
  DatenNr := 1; L0 := 0;
  (* --- Aufbau des Activation-Records --------------------- *)
  Gen(13,0,0,'Basepointer sichern, neuen laden');
  (* --- Bearbeitung der Konstantendeklarationen ----------- *)
  ...
  (* --- Bearbeitung der Prozedurdeklarationen ------------- *)
  IF sym = PROCsy THEN BEGIN
     (* Sprung ueber den Code des(r) Unterprogramm(e) zum Anfang *)
     (* der zu diesm Block gehoerigen Statements --------------- *)
     L0 := MakeLabel;
     Gen(9,0,0,'Mgl. Unterprogramme ueberspringen');
   END;
   WHILE sym = PROCsy DO BEGIN GetSym;
     ...
     obj := NewObj(Prozedur); (* Einfuegen: *)
     WITH Obj^ DO BEGIN ZWC_Startadresse := ZCode_Adresse;
       ASM_Startadresse := ASMCode_Adresse;
       COM_Startadresse := MCode_Adresse;
     END;
     (* weiter mit ... TestSemicolon; level:=level+1;...     *)
     (* -- Beginn der Bearbeitung des eigentlichen Blocks -- *)
     IF sym = BEGINsy THEN Getsym ELSE Error(8,'BEGIN erwartet');
     (* -- Falls Prozeduren deklariert worden sind, Sprung    -- *)
     (* -- vom Anfang des Blocks (ueber deren Code) eintragen -- *)
     IF L0 > 0 THEN FixUp(L0);
     (* --- Analyse des Rumpfes ---------------------------- *)
     ...
     IF sym = ENDsy THEN Getsym ELSE Error(9,'END erwartet');
     (* -- Uebriggebliebene EXIT-Spruenge als RETURN eintragen -- *)
     IF ExitSprung <> NIL THEN FixUpExitListe;
     (* --- RETURN erzeugen nach Absprungpunkt + 1. -------- *)
     IF Level <> 0 THEN Gen(12,1,0,'Return vom Unterprogrammaufruf')
        ELSE Gen(12,0,0,'Return vom Haupt programmaufruf');
     (* --- Naechst hoehere Symboltabelle anwaehlen, ------- *)
END (* Block *);

PROCEDURE Parse;
VAR BDOS_Adr : INTEGER ABSOLUTE $0006;
BEGIN (* --- Analyse des Programmkopfes -------------------- *)
  IF sym = MODULEsy THEN BEGIN GetSym;
     IF sym = Identifier THEN BEGIN GetSym; TestSemicolon; END
        ELSE error(4,'Parse : Identifier erwartet');
  END ELSE error(1,'Parse : "MODULE" erwartet');
  (* -- Basis-Zeiger fuer die Aktivierungsrecords ---------- *)
  (* -- auf BDOS-1 initialisieren -------------------------- *)
  Gen(14,0,BDOS_Adr-1,'Stack/Basepointer initialisieren');
  (* Das Hauptprogramm wird ebenfalls wie ein Unterprogramm  *)
  (* aufgerufen. Anschliessend Warmstart.                    *)
  Gen(7,0,ZCode_Adresse + 2,'Aufruf des Hauptprogramms');
  Gen(9,0,0,'Warmstart'); (* Programmende *)
  (* --- Analyse des Programmrumpfes ----------------------- *)
  ...
  IF noerr THEN BEGIN
     (* -- Patchen der Vcerwaertsspruenge auf Maschinen-, -- *)
     (*    Zwischen- und Assemblercodedatei               -- *)
     BackPatch; WRITELN; WRITE ('Programm fehlerfrei');
  END ELSE BEGIN
      WRITE('Programm fehlerhaft - Fehlerzahl: ',errcount:3);
  END;
  WRITE(' - ENTER druecken'); REPEAT READ(KBD,ch) UNTIL ORD(ch)=13;
END (* Parse *);

(* --------------------------------------------------------- *)
(* DC-007.INC                  Hilfsprozeduren des Compilers *)
(* --------------------------------------------------------- *)

PROCEDURE ListMsg(drucken:BOOLEAN;s:Str255);
VAR i : INTEGER;
BEGIN
  IF drucken THEN BEGIN
     WRITELN('Drucker fertig machen and Taste druecken'); Wait;
     ClrScr; WRITELN(LST,s);
     FOR i := 1 TO Length(s) DO WRITE(LST,'-' ); WRITELN(LST);
         WRITELN(LST);
     END;
     ClrScr; HighVideo; WRITELN(s);
     FOR i := 1 TO Length(s) DO WRITE('-'); WRITELN;
     NormVideo; WRITELN; WRITELN('Weiter mit (Taste)'); WRITELN;
END (* ListMsg *);

PROCEDURE ZeigeZwischencode(drucken:BOOLEAN);
VAR i : INTEGER; (* Zwischencode-Datei auf CRT zeigen        *)
BEGIN ClrScr;
  IF NOT Exist(ProgrammName+'.ZWC') THEN
     WRITELN(' -- Datei existiert nicht --')
  ELSE BEGIN ListMsg(drucken,
           'Adresse OpCode               Level Adresse/Wert');
     RESET(ZWC_File); i := 0;
     REPEAT i := i + 1; READ(ZWC File,ZCode);
       WITH ZCode DO BEGIN
         WRITELN(nr:5,' : ',Memo[bc],lv:10,Adresszahl(ad):10:0,
             ' ; ' , km) ;
         IF drucken THEN WRITELN(LST,nr:5,' : ',Memo[bc],lv:10,
            Adresszah1(ad):10:0,' ; ',km);
       END;
       IF (i MOD 21 = 0) AND NOT (drucken) THEN Wait;
     UNTIL EOF(ZWC_File);
  END;
  WRITELN(' ----- Fertig - Taste druecken -----'); Wait;
END (* ZeigeZwischencode *);

PROCEDURE InitParser;
VAR i, ende : INTEGER; Lib : TEXT;
(* Dateipuffer: Laenge mind. (MCode0ffset-TPA Anfang) Byte   *)
(* hier : $200 - $100 = 256 Byte                             *)
pf : ARRAY [1..256] OF CHAR;
BEGIN
  Jump_on_Condition := FALSE;
  ZCode_Adresse   := ZCode_Offset;    (* Zwischencode-Startadresse  *)
  MCode Adresse   := MCode_Offset;    (* Maschinencode-Startadresse *)
  ASMCode Adresse := ASMCode_Offset;  (* Assemblercode-Startadresse *)
  ipatch          := 1;               (* Patchfeldzeiger            *)
  (* -- PatchFeld initialisieren --------------------------- *)
  FOR i := 1 TO MaxPatch DO WITH PatchFeld[i] DO BEGIN
      Z_Adresse := 0; Z_Patch := 0; A_Adresse := 0; A_Patch := 0;
      JPC := FALSE; M_Adresse := 0; M_Patch := 0;
  END;
  TopScope   := NIL;  (* Symboltabelle initialisieren        *)
  ExitSprung := NIL;  (* Exittabelle initialisieren          *)
  MEM[$80]   := 0;    (* CP/M-Parameterzeile loeschen        *)
  Noerr      := FALSE;
  (* -- Programmname von CRT oder Eingabepuffer holen ------ *)
  IF ProgrammName <> '' THEN
     Noerr := Exist(ProgrammName+'.SRC');
  WHILE NOT Noerr DO BEGIN WRITELN; HighVideo;
    WRITELN('Bitte Sourcenamen eingeben: (<CR> = ',
    ProgrammName+'.SRC');
    NormVideo; READLN(Satz);
    FOR i := 1 TO Length(Satz) DO Satz[i] := UpCase(Satz[i]);
    IF Satz <> '' THEN ProgrammName := Satz;
    Noerr := Exist(ProgrammName+'.SRC');
  END;
  (* - nun werden die Compilerdateien initialisiert -------- *)
  ASSIGN(Source,ProgrammName+'.SRC'); RESET(Source);
  Ist_Offen[SRC] := TRUE;
  IF ZWC_Gen THEN BEGIN ASSIGN(ZWC_File,ProgrammName+'.ZWC');
     REWRITE(ZWC_File); Ist_0ffen[ZWC] := TRUE;
  END;
  IF COM_Gen THEN BEGIN
     IF NOT Exist('DCRTS.LIB') THEN BEGIN HighVideo;
        WRITELN('Die Datei DCRTS.LIB mit dem Laufzeitsystem ist');
        WRITELN ('auf dieser Diskette.');
        WRITELN('Bitte pruefen und neu starten.'); HALT; NormVideo;
     END;
     ASSIGN(COM_File,ProgrammName+'.COM'); REWRITE(COM_File);
     Ist_Offen[COM] := TRUE;
     ASSIGN(Lib,'DCRTS.LIB'); RESET(Lib); ClrScr; HighVideo;
     WRITELN('Kopieren des Laufzeitsystems...'); NormVideo;
     ende := MCode_Offset - TPA_Anfang;
     FOR i := 1 TO ende DO READ (Lib,pf[i]);
     FOR i := 1 TO ende DO WRITE(COM_File,pf[i]);
     CLOSE(Lib);
  END;
  IF ListOn THEN BEGIN ASSIGN(List,ProgrammName+'.LST');
     REWRITE(List); Ist_Offen[PRN] := TRUE;
  END;
  IF ASM_Gen THEN BEGIN ASSIGN(ASM_File,ProgrammName+'.ASM');
  REWRITE(ASM_File); Ist_Offen[ASM] := TRUE;
  END;
  InitScanner; Getsym; (* -- Scanner initialisieren -------- *)
END (* InitParser *);

PROCEDURE EndParser;
BEGIN ClrScr;
  IF Ist_Offen [SRC] THEN BEGIN CLOSE(Source);
     Ist_Offen [SRC] := FALSE; END;
  IF Ist_Offen [PRN] THEN BEGIN CLOSE(List);
     Ist Offen [PRN] := FALSE; END;
  IF (Ist_Offen[COM3] AND NOT (Noerr) THEN BEGIN CLOSE(COM_File)
     ERASE(COM_File); Ist_0ffen[COM] := FALSE; END;
  IF (Ist_Offen[ZWC]) AND NOT (Noerr) THEN BEGIN CLOSE(ZWC_File)
     ERASE(ZWC_File); Ist_Offen[ZWC] := FALSE; END;
  IF (Ist_Offen[ASM]) AND NOT (Noerr) THEN BEGIN CLOSE(ASM File)
     ERASE(ASM_File); Ist_Offen[ASM] := FALSE; END;
END (* EndParser *);

PROCEDURE Compile;
BEGIN (* Parsenhaupt programm F)
  InitParser; Parse; EndParser;
END (* Compile *);

(* --------------------------------------------------------- *)
(* Modul DC-008.INC                                          *)
(* Hilfs- und Dialogprozeduren des Compilers                 *)
(* --------------------------------------------------------- *)

PROCEDURE InitDC;
(* Initialisierung der Dateikontrollvariablen des Compilers  *)
BEGIN ProgrammName := 'TEST';
  IF ParamCount > 0 THEN ProgrammName := ParamStr(1);
  COM_Gen        := FALSE; ListOn         := FALSE;
  ZWC_Gen        := FALSE; ASM_Gen        := FALSE;
  Ist_Offen[SRC] := FALSE; Ist_0ffen[COM] := FALSE;
  Ist_Offen[PRN] := FALSE; Ist_Offen[ZWC] := FALSE;
  Ist_Offen[ASM] := FALSE;
END (* InitDC *);

PROCEDURE SchliesseDateien;
BEGIN (* Schliesst die Ausgabedateien des Compilers          *)
  IF Ist_Offen[SRC] THEN BEGIN
     CLOSE(Source); Ist_0ffen[SRC] := FALSE; END;
  IF Ist_Offen[COM] THEN BEGIN
     CLOSE(COM_File); Ist_Offen[COM] := FALSE; END;
  IF Ist_Offen[PRN] THEN BEGIN
     CLOSE(List); Ist_Offen[PRN] := FALSE; END;
  IF Ist_Offen[ZWC] THEN BEGIN
     CLOSE(ZWC_File); Ist_Offen[ZWC] := FALSE; END;
  IF Ist_Offen[ASM] THEN BEGIN
     CLOSE(ASM_File); Ist_Offen[ASM] := FALSE; END;
END (* Schliessedateien *);

PROCEDURE DisplayMenue;
(* Hauptmenue des Compilers mit den verschiedenen Optionen   *)
VAR i : INTEGER;

  PROCEDURE ZeigeFiles(st:Str40;s2:Str4;Schalter:BOOLEAN);
  (* Zeige Arbeitsdateien *)
  BEGIN WRITE(s1,' : ');
    IF Schalter THEN WRITE (ProgrammName + s2); WRITELN;
  END (* ZeigeFiles *);

BEGIN (* DisplayMenue *)
  ClrScr; HighVideo; ZWC_Gen := TRUE:
  WRITELN('D O I T - C o m p i l e r  -  Hauptmenue');
  WRITELN('----------------------------------------');
  NormVideo; WRITELN;
  ZeigeFiles('Arbeitsdatei      ', '.SRC',TRUE);
  ZeigeFiles('Zwischencodedatei ', '.ZWC',ZWC_Gen); WRITELN;
  WRITELN('Compilieren___________________________(C)'); WRITELN;
  WRITELN('Compileroptionen______________________(O)');
  WRITELN('neue Arbeitsdatei waehlen_____________(W)');
  WRITELN('Zwischencode reigen___________________(1)');
  WRITELN('Zwischencode drucken__________________(5)'); WRITELN;
  WRITELN('Ende_________________________(X) oder (Q)');
  READ (KBD,ch); ch := UpCase(ch)
  CASE ch OF
       'W' :     BEGIN SchliesseDateien; WRITELN; HighVideo;
                 WRITE('Neue Arbeitsdatei: '); NormVideo;
                 READLN(ProgrammName) ;
                 FOR i := 1 TO Length(ProgrammName) DO
                     ProgrammName[i] := UpCase(ProgrammName[i]); END
       '1','5' : ZeigeZwischenCode (ch='5');
       ELSE ;
  END (* CASE ch OF ... *);
END (* DisplayMenue *);