PROGRAM DoitCompiler;
(* --------------------------------------------------------- *)
(*      Doit-Yourself Compiler                               *)
(*                                                           *)
(*      Author : Helmut Richter                              *)
(*      Version : 2.1  Date: 4. February 1986                *)
(*                                                           *)
(* The parser procedures are only here for as far as there   *)
(* any additions to the versions in part 3 are necessary for *)
(* code generation.                                          *)
(* --------------------------------------------------------- *)
(*$U-,C+,A-*)

CONST (*$I SCCONST.INC *)
(*    Addresses of the jump vectors for all functions of the *)
(*    Run Time System (Library)                              *)
      ReadInt  =  4; (* Systemfunction (READ/WRITE)          *)
      ReadChar =  7; WriteInt = 10; WriteChar = 13;
      Addop    = 16; (* Arithmetic Operations                *)
      SUBop    = 19; NEGop    = 22; Multop    = 25;
      DIVop    = 28; MODop    = 31;
      ODDop    = 34; (* Logical  Operationsn                 *)
      EQLop    = 37; NEQop    = 40; GTRop     = 43;
      LSSop    = 46; GEQop    = 49; LEQop     = 52;

(* Number of "Machine" oprations of the "virtual" CPU        *)
      MaxOp = 14;  (* Index starts at 0 !                    *)
      Memo : ARRAY[0.. MaxOp] OF STRING [13] =

(* Stackmachine command 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_Start = $100;  (* Start of CP/M program                  *)

(* Startaddress of the machinecode program : TPA+length(RTS) *)
      MCode_Offset   = $200;
      IMCode_Offset  = 0;     (* Startaddress Intermediate code *)
      ASMCode_Offset = $200;  (* Startaddress Assemblycode      *)

(* Length of patchfield for the backward jumps:              *)
      MaxPatch = 40;
      Test     = FALSE;

TYPE (*$I SCTYPE.INC *)
     ObjectType = (INTEGER_Object, Character_Object,
                  ErrorObject);  (* admissable types        *)
     ... STR10, ObjectClass u. ObjPtr as had (????) ...
     Object = RECORD ...
                CASE kind : ObjectClass OF
                     ...
                     Procedure : (IMC_StartAddress,
                                 ASM_StartAddress,
                                 COM_StartAddress: INTEGER);
                     CharVar, IntVar : (DataAddress, Vlevel
                                     : INTEGER);
                     Header : (Last, Down : ObjPtr);
              END;

(* Types for the EXIT-jump list                              *)
        ExitListType = (Hdr, page);
        ExitPtr       = ^ExitList;
        ExitList     = RECORD
                          L : INTEGER; next : ExitPtr;
                          CASE ElementType : ExitListType OF
                               page : ();
                               Hdr   : (Last, Down : ExitPtr);
                        END;
        Str40      = STRING[ 40];  Str7 = STRING[  7];
        Str4       = STRING[  4];  Str2 = STRING[  2];
        FileTypes = (SRC, COM, PRN, IMC, ASM);

(* Types for Assembler- and Intermediatecode                 *)
        IMCode_Instruction = RECORD  (* Intermediatecode command *)
              nr : INTEGER;         (* Command number        *)
              bc : 0..MaxOp;        (* Command code          *)
              Iv : 0..15;           (* Program level         *)
              ad : INTEGER:         (* Data address          *)
              km : str40;           (* Comment               *)
              END;
        ASM_Instruction = RECORD  (* Assembler-Command       *)
              nr : INTEGER;       (* Command number          *)
              bc : Str4;          (* Operationcode           *)
              op1,                (* Operand 1               *)
              op2: Str7;          (* Operand 2               *)
              km : Str40;         (* Comment                 *)
              END;
        PatchInfo = RECORD  (* Type for the patchfield       *)
              (* Intermediatecode address and patchvalue     *)
              IM_Address, IM_Patch,
              (* Assemblercode-Address and -Patchvalue       *)
              A_Address, A_Patch : INTEGER;
              (* Indicates the kind of jump                  *)
              JPC                : BOOLEAN;
              (* Machinecode-Address and -Patchvalue         *)
              M_Address, M_Patch : INTEGER;
              END;

VAR (*$I SCVAR.INC *)
    TopScope, Bottom : ObjPtr;
    ProgramName      : T_Name;
    (* Variable to indicate the recursion depth              *)
    level            : INTEGER;
    (* Variable for testing of type equality                 *)
    Expression_Type  : Object_Type;
    (* Variable for Intermediate- and Abssembly commands     *)
    IMCode           : IMCode_Instruction;
    ASMCode          : ASM_Instruction;
    IMCode_Address,  (* Next free Intermediate command       *)
    MCode_Address,  (* Next free Machinecode command         *)
    ASMCode Address  : INTEGER; (* " " Assemblycommand       *)
    ExitJump       : ExitPtr;
    (* Declarationsof the Compiler files                     *)
    Source, COM_File, List : TEXT;
    IMC_File         : FILE OF IMCode_Instruction;
    ASM_File         : FILE OF ASM_Instruction;
    (* Field to mark opened files                            *)
    Ist_open         : ARRAY[FileTypes] OF BOOLEAN;
    (* Switch for the output file generation                 *)
    COM_Gen, ListOn, ASM_Gen, IMC_Gen,
    (* Variable for markint of conditional jumps             *)
    Jump_on_Condition: BOOLEAN;
    (* Declarations for keeping track of jump addresses      *)
    (* PatchField and its counter                            *)
    PatchField        : ARRAY[1..MaxPatch] OF Patchinfo;
    ipatch,
    (* Contiguous number of a variable in its symbol table   *)
    (* (used for calculating it's stack offset               *)
    DataNr          : INTEGER;

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

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

FUNCTION Exist(FileName:Str40):BOOLEAN;
VAR Filee : File;
BEGIN (* Tests, whether the file with name(FileName) exists   *)
  Exist := FALSE; ASSIGN(Filee,FileName);
  (*$I-*) RESET(Filee); (*$I+*)
  IF (IOResult = 0) THEN BEGIN CLOSE(Filee); Exist := TRUE; END
     ELSE BEGIN HighVideo;
     WRITELN('File',FileName,' doesn't exist.'); NormVideo;
  END;
END (* Exist *);

(*$I PARS-001.INC *)  (* All Scannerprocedures.               *)
(*$I DC-002.INC   *)  (* Codegenerator GEN                    *)
(*$I DC-003.INC   *)  (* Helpprocedures for Codegeneration    *)
(*$I PARS-002.INC *)  (* Helpprocedures o/t Parser/EXITver.   *)
(*$I PARS-003.INC *)  (* Procedures  Expression, Statement.   *)
(*$I PARS-004.INC *)  (* Procedures  Block, Parse.            *)
(*$I DC-007.INC   *)  (* Helpprocedures  o/t Compiler.        *)
(*$I DC-008.INC   *)  (* Dialogprocedures o/t Compiler        *)

BEGIN InitDC;  (* -- DOIT - Main program  ------------------  *)
  REPEAT DisplayMenu;  (* -- Main loop of the Compiler     -- *)
    IF ch = ' C' THEN Compile;
  UNTIL (ch = 'Q') OR (ch = 'X');
  CloseFiles;
END.

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

(* The scanner is in essence unchanged. In InitScanner, the  *)
(* file manipulation routines must be removed, since the are *)
(* now performed in InitParser. It now looks like :          *)

PROCEDURE InitScanner;
BEGIN (* InitScanner *)
  ClrScr; Ctrl := ' '; sym := Null; intval := 0; Charval := ' ';
  errcount := 0; read := TRUE; Noerr := TRUE; ch := ' ' ;
  SwT(. 1.).s := 'BEGIN';  SwT(. 1.).NR := 32;
  ... Initialization of the Keyword tables       ..
  SwT(.18.).s := 'WRITE';  SwT(.18.).NR := 41;
  ClrScr; HighVideo; WRITELN('Compiling...');
  WRITELN; NormVideo; Line := '' ; BufferFull;
END (* InitScanner *);

(* PARAMCOUNT and PARAMSTR must be put BEFORE InitScanner    *)
(* to be globally available. (Only TURBO 2.0).               *)
(* SYMNAME, PROMPT and all their references can be removed   *)

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

PROCEDURE Gen(x, y, z:INTEGER; Comment:str40);
(* Generation of Stackmachine-Code (Rest next installment   *)
BEGIN
  IF Noerr THEN BEGIN
     WITH IMCode DO BEGIN
       nr:=IMCode_Address; bc:=x; lv:=y; ad:=z; km:=Comment;
     END;
     IF IMC_Gen THEN WRITE(IMC_File,IMCode);
     IMCode_Address := IMCode_Address + 1;
  END;
END (* Gen *);

(* --------------------------------------------------------- *)
(* Modul DC-003.INC       Helpprocedures o/t Codegenerator   *)
(* --------------------------------------------------------- *)

PROCEDURE FixUp(address : INTEGER);
BEGIN  (* Backpatching the jumps and procedure calls         *)
  WITH PatchField[address] DO BEGIN IM_Patch := IMCode_Address;
    A_Patch := ASMCode_Address; M_Patch := MCode_Address;
  END;
END (* FixUp *);

PROCEDURE BackPatch: (* -- Patch the forward jumps   ------- *)

  PROCEDURE PatchIMCFile;
  (* Write the patches per RANDOM-ACCESS in the correct lines*)
  (* Access is done by line number                           *)
  VAR IMCode2 : IMCode Instruction;
        i, j : INTEGER;
  BEGIN
    WRITELN; WRITELN('Intermediatecode-File...');
    RESET(IMC_File); i := 1;
    WHILE i < ipatch DO BEGIN
      WITH IMCode2 DO WITH PatchField[i] DO BEGIN
        1 := IM_Address - IMCode_Offset :
        (* Random Access: find correct line and              *)
        (* IMCode2 read. Attention : line counter is one     *)
        (* line ahead                                        *)
        SEEK(IMC_File,j); READ(IMC_File,IMCode2);
        (* Write Patch  ...                                  *)
        ad := IM_Patch;
        (* ... Line counter back to sam4 sector and          *)
        (* write back to file                                *)
        SEEK(IMC_File, j); WRITE(IMC_File, IMCode2);
        (* Write patch info to screen                        *)
        WRITELN('Patch Nr: ',i:2,'  Address:',IM_Address:5,
                '  Patch: ',IM_Patch:5,'     LineNr: ',j:3);
        i := i + 1;
      END;
    END;
  END (* PatchIMCFile *);

  PROCEDURE PatchASMFile;
  BEGIN END;

  PROCEDURE PatchCOMFile;
  BEGIN END;

BEGIN (* BackPatch *)
  WRITELN; WRITELN; WRITE('Backpatching: ');
  IF IMC_Gen THEN PatchIMCFile; IF ASM_Gen THEN PatchASMFile;
  IF COM_Gen THEN PatchCOMFile;
  WRITELN('-- Backpatching ready --');
END (* BackPatch *);

PROCEDURE MakeData (VAR adr:INTEGER; Length:INTEGER);
(* Generates Address for data on stack                       *)
BEGIN  (* 2 Byte per Variable!!!                             *)
  adr := DataNr; DataNr := DataNr + Length;
  (* Decrement StackPointer <Length>-times                   *)
  Gen(8,0,2,'Make room for the data');
END (* MakeData *);

FUNCTION MakeLabel : INTEGER;
BEGIN
  WITH PatchField[ipatch] DO BEGIN
    IM_Address := IMCode_Address;
    IF Jump_on_Condition THEN BEGIN
       A_Address := ASMCode_Address + 3;
       M_Address := MCode_Address + 4; JPC := TRUE;
    END ELSE BEGIN
       A_Address := ASMCode_Address;
       M_Address := MCode_Address + 1; JPC := FALSE:
    END;
    IM_Patch := 0; A_Patch := 0; M_Patch := 0;
  END;
  MakeLabel := ipatch; ipatch := ipatch + 1;
  IF ipatch > MaxPatch THEN BEGIN HighVideo;
     WRITELN('Patchfield overflow - more then ', MaxPatch:2,
     ' jumps - Error stop - press key');NormVideo; Wait;
  END;
END (* MakeLabel *);

(* ---------------------------------------------------------- *)
(* Modul DC-004.INC (PARS-002.INC) Help procedures of Parser  *)
(* ---------------------------------------------------------- *)

FUNCTION EqualTypes (Typ1, Typ2:Object_Type):BOOLEAN;
(* Tests if the types are the same. If is the                *)
BEGIN  (* Error Typ, FALSE must be returned                 *)
  IF (Typ1 = Error_Object) OR (Typ2 = Error_Object) THEN
  EqualTypes := FALSE ELSE EqualTypes := (Typ1 = Typ2);
END (* EqualTypes *);

PROCEDURE ProcCall(Obj:ObjPtr);
(* Processing of a procedure call                            *)
BEGIN  (* Exception : no  Address but a pointer to   Symbol- *)
  (* table ( .... as INTEGER)  forward to GEN                *)
  Gen(7,1,ORD(Obj),'Call procedure'); GetSym;
END (* ProcCall *);

FUNCTION NewObj(k : ObjectClass) : ObjPtr;
  ...
  (* Add New Element           *)
  ...
  CASE Kind OF
       Nix          :   Type := Error_Object;
       CharacterCon : BEGIN CValue := CharVal;
                        Type := Character_Object; END;
       INTEGERCon   : BEGIN IValue := IntVal;
                        Type := Integer_Object; END;
       Procedure     : BEGIN IMC_StartAddress := 0;
                        ASM_StartAddress := 0;
                        COM_StartAddress := 0; END;
       CharVar      : BEGIN MakeData(DataAddress, 1);
                        Type := Character_Object; END;
       IntVar       : BEGIN MakeData(DataAddress, 2);
                        Type := Integer_Object; END;
  END (* CASE Kind OF *);

FIND, TESTSYM and TESTSEMICOLON stay the same. New are :

PROCEDURE NewExitList;
(* Initialization of the list with EXIT jumps with header   *)
VAR ExitListHead : ExitPtr;
BEGIN NEW(ExitListHead);
  WITH ExitListHead^ DO BEGIN
    ElementType := Hdr; L := -Maxint; next := NIL;
    Last := ExitListHead; Down := ExitJump;
  END;
  ExitJump := ExitListHead;
END (* NewExitList *);

PROCEDURE EnterExitList(Labl : INTEGER);
(* Enter an EXIT statement                                   *)
VAR Entry : ExitPtr;
BEGIN NEW(Entry);
  WITH Entry^ DO BEGIN
    ElementType := page; L := Labl; next := NIL;
  END;
  WITH ExitJump^ DO BEGIN
    Last^.next := Entry; Last := Entry;
  END;
END (* EnterExitList *);

PROCEDURE FixUpExitList;
(* "Backpatching" the Exit-jumps of a     DO..OD-Levels      *)
VAR Pointer : ExitPtr;
BEGIN Pointer := ExitJump^.next;
  WHILE Pointer <> NIL DO BEGIN
    FixUp(Pointer^.L); Pointer := Pointer^.next;
  END;
  ExitJump := ExitJump^.Down;
END (* FixUpExitList *);

(* --------------------------------------------------------- *)
(* Modul DC-005.INC (PARS-003.INC)      Analysis procedures  *)
(* --------------------------------------------------------- *)

PROCEDURE Expression;
(* The test if types of expressions are equal is done with   *)
(* EqualTypes of the local variable                          *)
(* Factor_Typ, Term_Typ, Expression_Typ (global).            *)
VAR Operation : Symbol; Factor_Typ, Term_Type : Object_Type;

  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,IValue,
                       'Load Integer constant ' + idname);
         CharacterCon : Gen(1,0,ORD(CValue),
                       'Load Character constant ' + idname);
         IntVar       : Gen(3,Level-Vlevel,DataAddress,
                       'Load Integer variable ' + idname);
         CharVar      : Gen(4,Level-Vlevel,DataAddress,
                       'Load Character variable ' + idname);
         Procedure     : Error(21,
                       'Procedures not allowed here');
         ELSE ;
       END;
       Factor_Type := Obj^.Typ; GetSym;
    END ELSE IF sym = Intcon THEN BEGIN
        Factor_Type := Integer_Object;
        Gen(0,0,IntVal,'immediate Integer constant'); GetSym;
    END ELSE IF sym = Charcon THEN BEGIN
        Factor_Type := Character_0bjekt;
        Gen(1,0,ORD(CharVal),'immediate Character constant'); GetSym;
    END ELSE IF sym = Hexcon THEN BEGIN
        Factor_Type := Character_Object;
        Gen(1,0,0RD(CharVal),'immediate Hex constant'); GetSym;
    END ELSE IF sym = lparent THEN BEGIN GetSym;
        Expression; Factor_Type := Expression_Typ;
        IF sym = Rparent THEN GetSym ELSE Error(7,'")" expected');
    END ELSE BEGIN
        Factor_Type := Error_Object; Error(18,'Expression expected');
    END;
END (* Factor *);

PROCEDURE Term;
VAR mulop : Symbol; Factor1_Type : Object_Type;
BEGIN Factor; Term_Type := Factor_Typ;
  WHILE (times <= sym) AND (sym (= modsy) DO BEGIN
    mulop := sym; GetSym; Factor;
    IF EqualTypes(Term_Typ,Factor_Typ) THEN BEGIN
       Term_Type := Factor_Typ;
       CASE mulop OF
            times : Gen(2,0,MULTop,'Multiplication');
            divsy : Gen(2,0,DIVop,'Division');
            modsy : Gen(2,0,MODop,'Modulo');
       END (* CASE mulop OF ... *);
    END ELSE BEGIN Term_Type := Error_Object;
        Error(50,'in Term');
    END (* IF EqualTypes 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,'Process Minus sign');
  END ELSE Term;
  Expression_Type := Term_Typ;
  WHILE (plus <= sym) AND (sym <= minus) DO BEGIN
    Operation := sym; GetSym; Term;
    IF EqualTypes(Expression_Typ,Term_Typ) THEN BEGIN
       Expression_Type := Term_Typ;
       IF Operation = plus THEN
          Gen(2,0,ADDop,'Addition')
       ELSE Gen(2,0,SUBop,'Subtraction');
    END ELSE BEGIN
        Expression_Type := Error_Object; Error(50,'in Expression')
    END (* IF EqualTypes THEN ... *);
  END (* WHILE (plus .= ... *);
END (* Expression *);

PROCEDURE Condition;
VAR relop : Symbol; Condition_Type : Object_Type;
BEGIN
  IF sym = odd THEN BEGIN Getsym; Expression;
     IF Expression_Type <> Integer_Object THEN
        Error(51,'Integer expected after ODD');
     Gen(2,0,ODDop,'ODD-Test');
  END ELSE BEGIN
     Expression; Condition_Type := Expression_Typ;
     IF (eql <= sym) AND (sym <= geq) THEN BEGIN
        relop := sym; Getsym; Expression;
        IF NOT EqualTypes(Condition_Typ,Expression_Typ) THEN
           Error(50,'Un-equal types in Condition');
        CASE relop OF
             eql : Gen(2,0,EQLop,'Equality');
             neq : Gen(2,0,NEQop,'Un-Equality');
             lss : Gen(2,0,LSSop,'Smaller');
             geq : Gen(2,0,GEQop,'Larger or equal');
             gtr : Gen(2,0,GTRop,'Larger');
             leq : Gen(2,0,LEQop,'Smaller or equal');
        END (* Case *);
     END ELSE Error(20,'Relation expected');
  END (* IF sym = odd THEN ... *);
END (* Condition *);

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

  PROCEDURE IFstatement;
  LABEL 99;
  VAR L0, L1 : INTEGER; OnlyThisPart : BOOLEAN;
  BEGIN OnlyThisPart := FALSE;
    GetSym; Condition;
    IF sym = THENsy THEN BEGIN OnlyThisPart := TRUE; GetSym;
       (* Conditional Jump to after the THEN-Block, if       *)
       (* CONDITION = FALSE.                                 *)
       Jump_on_Condition := TRUE;
       L0 := MakeLabel; Gen(10,0,0,'Jump on ELSE-part');
       Jump_on_Condition := FALSE;
       SymbolSet := (.ELSEsy, FIsy, ENDsy, period, eofsy.);
       REPEAT Statement; UNTIL sym in SymbolSet;
       IF sym = ELSEsy THEN BEGIN
          (* Jump to adter the ELSE block after going        *)
          (* the THEN part                                   *)
          L1 := MakeLabel;
          Gen(9,0,0,'Jump hinter ELSE-part');
          (* Save jump address for the jump over the THEN part*)
          (* (means  CONDITION = FALSE)                       *)
          FixUp(L0); OnlyThisPart := FALSE; Getsym;
          SymbolSet := (.FIsy, ENDsy, period, eofsy.);
          REPEAT Statement;
            IF sym = ELSEsy THEN BEGIN
               Error(16,'FI expected'); GOTO 99; END;
          UNTIL sym IN SymbolSet;
          (* Save jump address for the jump over the ELSE part*)
          FixUp(L1);
       END;
       IF OnlyThisPart THEN FixUp(L0);
       IF sym = FIsy THEN GetSym ELSE Error(16,'FI expected');
    END ELSE Error(15,'THEN expected');
  99:
  END (* IFstatement *);

BEGIN (* Statement *) TestSym(semicolon,98);
  IF sym = Identifier THEN BEGIN Obj := Find(idname);
     IF Obj^.kind = Procedure THEN ProcCall(Obj)
     ELSE IF Obj^.kind = IntVar THEN BEGIN GetSym;
       IF sym = becomes THEN GetSym
          ELSE Error(11,':= expected');
       Expression;
       IF NOT EqualTypes (INTEGER Object, Expression_Typ) THEN
          Error(50,'in Integer expression' )
       ELSE WITH Obj^ DO Gen(5,Level-vlevel,DataAddress,
       'Save Integer ' + Name);
     END ELSE IF Obj^.kind = ChanVar THEN BEGIN GetSym;
     IF sym = becomes THEN GetSym
        ELSE Error(11,':= expected' );
     Expression;
     IF NOT EqualTypes (Character_Object, Expression_Typ)
        THEN Error(50,'in Character expression')
        ELSE WITH Obj^ DO Gen(6,Level-vlevel,DataAddress,
        'Save Character ' + Name);
     END ELSE IF Obj^.Kind = NIX THEN BEGIN GetSym;
        IF sym = Semicolon THEN ProcCall (Obj)
           ELSE BEGIN (* Variablename / Set (:=) *)
             IF sym = becomes THEN Get Sym
                ELSE Error(11,':= expected' );
        Expression;
     END;
  END;
END ELSE IF sym = IFsy THEN IFstatement
ELSE IF sym = DOsy THEN BEGIN
  SymbolSet := (.ODsy, ENDsy, period, eofsy.);
  (* Jump address for the end of the   DO...OD-loop         *)
  L0 := MakeLabel;
  (* Create list for any Exit jump present in the loop      *)
  NewExitList; GetSym;
  REPEAT Statement; UNTIL sym in SymbolSet;
  IF sym = ODsy THEN GetSym ELSE Error(17,'OD expected');
  (* Jump bach from the beginning of the DO...OD block      *)
  (* (Convert address off DO in Patch-Field                 *)
  WITH PatchField[L0] DO BEGIN
    IM_Patch := IM_Address;   IM_Address := IMCode_Address;
    A_Patch := A_Address;   A_Address := ASMCode_Address;
    M_Patch := M_Address-1; M_Address := MCode_Address+1;
  END;
  Gen(9,0,0,'DO..OD: Jump back to DO');
  (* If any Exits are present between the DO and OD,        *)
  (* the Exit list has to be updated                        *)
  FixUpExitList;
END ELSE IF sym = EXITsy THEN BEGIN
  (* EXIT can also be used OUTSIDE the DO...OD loop,        *)
  (* In that case it simulates a Return                     *)
  (* ExitJump = NIL means that the Exit OUTSIDE a DO...OD ! *)
  IF ExitJump = NIL THEN NewExitList;
  EnterExitList(MakeLabel); Gen(9,0,0,'EXIT-Jump'); 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  (* Integer variable        *)
       (* Call READ_Integer                                 *)
       Gen(11,0,ReadInt,'Read Integer');
       (* SAve Integer-Variable                             *)
       Gen(5,Level-vlevel,DataAddress,'and save it')
    END ELSE IF kind <> Procedure THEN
       BEGIN  (* Charactervariable i                        *)
         (* Call READ_Character*)
         Gen(11,0,ReadChar,'Read Character');
         (* Save Character-Variable                         *)
         Gen(6,Level-vlevel,DataAddress,'and save it');
       END ELSE Error(21,'Procedures are not allowed here');
  END (* With *);
  Getsym;
END ELSE Error(14,'After READ there must be an Identifier');
END ELSE IF sym = WRITEsy THEN BEGIN GetSym;
  IF sym = semicolon THEN BEGIN
     Gen(1,0,13,'Load 0Dh'); Gen(11,0,WriteChar,'Write CR')
     Gen(1,0,10,'Load 0Ah'); Gen(11,0,WriteChar,'Write LF')
  END ELSE BEGIN Expression;
     IF Expression Type = INTEGER Object THEN
        Gen(11,0,Writelnt,'Write Integer')
     ELSE Gen(11,0,WriteChar,'Write Character');
  END
END ELSE . . .
END (* Statement *);

(* ----------------------------------------------------------- *)
(* Modul DC-006.INC (PARS-004.INC) Help/Anal. proc' s Parser   *)
(* ----------------------------------------------------------- *)

PROCEDURE Block;
...
VAR ...
    L0 : INTEGER;
... ConstDeclaration stays the same ...

PROCEDURE VarDeclaration;
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,'After ":" INT or CHAR expected')
END (* VarDeclaration *);

BEGIN (* -- Block ------------------------------------------ *)
...
  IF level = 0 THEN Bottom := hd;
  DataNr := 1; L0 := 0;
  (* --- Creation of the Activation-Record ----------------- *)
  Gen(13,0,0,'Save Basepointer , load new one');
  (* --- Processing of the constant declarations ----------- *)
  ...
  (* --- Processing of the Procedure declarations ---------- *)
  IF sym = PROCsy THEN BEGIN
     (* Jump over  the Code o/t procedure(s) to  the start   *)
     (* of the statements that belong to this block -------- *)
     L0 := MakeLabel;
     Gen(9,0,0,'Mgl. Jump over procedures');
   END;
   WHILE sym = PROCsy DO BEGIN GetSym;
     ...
     obj := NewObj(Procedure); (* Insert: *)
     WITH Obj^ DO BEGIN IMC_Startaddress := IMCode_Address;
       ASM_Startaddress := ASMCode_Address;
       COM_Startaddress := MCode_Address;
     END;
     (* continue with ... TestSemicolon; level:=level+1;...  *)
     (* -- Start processing the actual Block              -- *)
     IF sym = BEGINsy THEN Getsym ELSE Error(8,'BEGIN expected');
     (* -- If procedures have been declared, save jump over  *)
     (* -- their code to start of the blocks code            *)
     IF L0 > 0 THEN FixUp(L0);
     (* --- Analysis of the block  ------------------------- *)
     ...
     IF sym = ENDsy THEN Getsym ELSE Error(9,'END expected');
     (* -- save all other EXIT's left as returns             *)
     IF ExitJump <> NIL THEN FixUpExitList;
     (* --- create RETURN to start point + 1        -------- *)
     IF Level <> 0 THEN Gen(12,1,0,'Return from procedure call')
        ELSE Gen(12,0,0,'Return from Mainprogram call');
     (* --- Select next higher symboltable           ------- *)
END (* Block *);

PROCEDURE Parse;
VAR BDOS_Adr : INTEGER ABSOLUTE $0006;
BEGIN (* --- Analysis of the program header ---------------- *)
  IF sym = MODULEsy THEN BEGIN GetSym;
     IF sym = Identifier THEN BEGIN GetSym; TestSemicolon; END
        ELSE error(4,'Parse : Identifier expected');
  END ELSE error(1,'Parse : "MODULE" expected');
  (* -- Intialize Base-Pointer for the Activation records    *)
  (* -- to  BDOS-1                -------------------------- *)
  Gen(14,0,BDOS_Adr-1,'Initialize Stack/Basepointer');
  (* The Main program is also called as a procedure, but     *)
  (* followed by a warmstart (warmboot)                      *)
  Gen(7,0,IMCode_Address + 2,'Main program call');
  Gen(9,0,0,'Warmstart'); (* End of Program *)
  (* --- Analysis of the program body----------------------- *)
  ...
  IF noerr THEN BEGIN
     (* -- Patch the forward jumps on  Machine-,          -- *)
     (*    Intermediate- and Assemblycode file            -- *)
     BackPatch; WRITELN; WRITE ('Program errorfree');
  END ELSE BEGIN
      WRITE('Errors in Program - Number of errors : ',errcount:3);
  END;
  WRITE(' - Press ENTER'); REPEAT READ(KBD,ch) UNTIL ORD(ch)=13;
END (* Parse *);

(* --------------------------------------------------------- *)
(* DC-007.INC                  Helpprocedures o/t Compilers  *)
(* --------------------------------------------------------- *)

PROCEDURE ListMsg(print:BOOLEAN;s:Str255);
VAR i : INTEGER;
BEGIN
  IF print THEN BEGIN
     WRITELN('Ready printer and press any key'); 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('Continue with (Key)'); WRITELN;
END (* ListMsg *);

PROCEDURE ShowIMcode(print:BOOLEAN);
VAR i : INTEGER; (* Show Intermediate code file on screen   *)
BEGIN ClrScr;
  IF NOT Exist(ProgramName+'.IMC') THEN
     WRITELN(' -- File not found --')
  ELSE BEGIN ListMsg(print,
           'Address OpCode               Level Address/Value');
     RESET(IMC_File); i := 0;
     REPEAT i := i + 1; READ(IMC File,IMCode);
       WITH IMCode DO BEGIN
         WRITELN(nr:5,' : ',Memo[bc],lv:10,AddressValue(ad):10:0,
             ' ; ' , km) ;
         IF print THEN WRITELN(LST,nr:5,' : ',Memo[bc],lv:10,
            AddressValue(ad):10:0,' ; ',km);
       END;
       IF (i MOD 21 = 0) AND NOT (print) THEN Wait;
     UNTIL EOF(IMC_File);
  END;
  WRITELN(' ----- Ready - Press Key -----'); Wait;
END (* ShowIMcode *);

PROCEDURE InitParser;
VAR i, end : INTEGER; Lib : TEXT;
(* Filebuffer at least (MCode0ffset-TPA Anfang) Byte         *)
(* here : $200 - $100 = 256 Byte                             *)
pf : ARRAY [1..256] OF CHAR;
BEGIN
  Jump_on_Condition := FALSE;
  IMCode_Address   := IMCode_Offset;    (* Intermediatecode-Startaddress  *)
  MCode Address   := MCode_Offset;    (* Machinecode-Startaddress *)
  ASMCode Address := ASMCode_Offset;  (* Assemblycode-Startaddress *)
  ipatch          := 1;               (* Patchfieldpointer           *)
  (* -- Intialize PatchField --------------------------- *)
  FOR i := 1 TO MaxPatch DO WITH PatchField[i] DO BEGIN
      IM_Address := 0; IM_Patch := 0; A_Address := 0; A_Patch := 0;
      JPC := FALSE; M_Address := 0; M_Patch := 0;
  END;
  TopScope   := NIL;  (* Intialize Symboltable *)
  ExitJump := NIL;  (* Intialize Exittable *)
  MEM[$80]   := 0;    (* Clear CP/M-Parameter buffer *)
  Noerr      := FALSE;
  (* -- Get program name from CRT or input buffer    ------ *)
  IF ProgramName <> '' THEN
     Noerr := Exist(ProgramName+'.SRC');
  WHILE NOT Noerr DO BEGIN WRITELN; HighVideo;
    WRITELN('Enter Sourcename: (<CR> = ',
    ProgramName+'.SRC');
    NormVideo; READLN(Line);
    FOR i := 1 TO Length(Line) DO Line[i] := UpCase(Line[i]);
    IF Line <> '' THEN ProgramName := Line;
    Noerr := Exist(ProgramName+'.SRC');
  END;
  (* - now the compiler files will be initialized   -------- *)
  ASSIGN(Source,ProgramName+'.SRC'); RESET(Source);
  Is_Open[SRC] := TRUE;
  IF IMC_Gen THEN BEGIN ASSIGN(IMC_File,ProgramName+'.IMC');
     REWRITE(IMC_File); Is_Open[IMC] := TRUE;
  END;
  IF COM_Gen THEN BEGIN
     IF NOT Exist('DCRTS.LIB') THEN BEGIN HighVideo;
        WRITELN('The File DCRTS.LIB with the RunTimeSystem is');
        WRITELN ('not on this disc.');
        WRITELN('Check and start again..'); HALT; NormVideo;
     END;
     ASSIGN(COM_File,ProgramName+'.COM'); REWRITE(COM_File);
     Is_Open[COM] := TRUE;
     ASSIGN(Lib,'DCRTS.LIB'); RESET(Lib); ClrScr; HighVideo;
     WRITELN('Copying the RunTimeSystem...'); NormVideo;
     end := MCode_Offset - TPA_Start;
     FOR i := 1 TO end DO READ (Lib,pf[i]);
     FOR i := 1 TO end DO WRITE(COM_File,pf[i]);
     CLOSE(Lib);
  END;
  IF ListOn THEN BEGIN ASSIGN(List,ProgramName+'.LST');
     REWRITE(List); Is_Open[PRN] := TRUE;
  END;
  IF ASM_Gen THEN BEGIN ASSIGN(ASM_File,ProgramName+'.ASM');
  REWRITE(ASM_File); Is_Open[ASM] := TRUE;
  END;
  InitScanner; Getsym; (* -- Initialize Scanner -------- *)
END (* InitParser *);

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

PROCEDURE Compile;
BEGIN (* Parse Main program *)
  InitParser; Parse; EndParser;
END (* Compile *);

(* --------------------------------------------------------- *)
(* Modul DC-008.INC                                          *)
(* Help- and Dialogprocedures o/t Compilers                  *)
(* --------------------------------------------------------- *)

PROCEDURE InitDC;
(* Initialisation of the File control variable o/t Compiler  *)
BEGIN ProgramName := 'TEST';
  IF ParamCount > 0 THEN ProgramName := ParamStr(1);
  COM_Gen        := FALSE; ListOn         := FALSE;
  IMC_Gen        := FALSE; ASM_Gen        := FALSE;
  Is_Open[SRC] := FALSE; Is_Open[COM] := FALSE;
  Is_Open[PRN] := FALSE; Is_Open[IMC] := FALSE;
  Is_Open[ASM] := FALSE;
END (* InitDC *);

PROCEDURE CloseFiles;
BEGIN (* Closes the output files o/t Compiler          *)
  IF Is_Open[SRC] THEN BEGIN
     CLOSE(Source); Ist_0ffen[SRC] := FALSE; END;
  IF Is_Open[COM] THEN BEGIN
     CLOSE(COM_File); Is_Open[COM] := FALSE; END;
  IF Is_Open[PRN] THEN BEGIN
     CLOSE(List); Is_Open[PRN] := FALSE; END;
  IF Is_Open[IMC] THEN BEGIN
     CLOSE(IMC_File); Is_Open[IMC] := FALSE; END;
  IF Is_Open[ASM] THEN BEGIN
     CLOSE(ASM_File); Is_Open[ASM] := FALSE; END;
END (* Closefiles *);

PROCEDURE DisplayMenu;
(* Main menu o/t compiler with the various options       *)
VAR i : INTEGER;

  PROCEDURE ShowFiles(st:Str40;s2:Str4;Switch:BOOLEAN);
  (* Show work files *)
  BEGIN WRITE(s1,' : ');
    IF Switch THEN WRITE (ProgramName + s2); WRITELN;
  END (* ShowFiles *);

BEGIN (* DisplayMenu *)
  ClrScr; HighVideo; IMC_Gen := TRUE:
  WRITELN('D O I T - C o m p i l e r  -  Main menu ');
  WRITELN('----------------------------------------');
  NormVideo; WRITELN;
  ShowFiles('Work file             ', '.SRC',TRUE);
  ShowFiles('Intermediatecode file ', '.IMC',IMC_Gen); WRITELN;
  WRITELN('Compile_______________________________(C)'); WRITELN;
  WRITELN('Compile Options_______________________(O)');
  WRITELN('Change work file______________________(W)');
  WRITELN('Show Intermediatecode_________________(1)');
  WRITELN('Print Intermediatecode________________(5)'); WRITELN;
  WRITELN('Quit_________________________(X) oder (Q)');
  READ (KBD,ch); ch := UpCase(ch)
  CASE ch OF
       'W' :     BEGIN CloseFiles; WRITELN; HighVideo;
                 WRITE('Chane work file: '); NormVideo;
                 READLN(ProgramName) ;
                 FOR i := 1 TO Length(ProgramName) DO
                     ProgramName[i] := UpCase(ProgramName[i]); END
       '1','5' : ShowIMCode (ch='5');
       ELSE ;
  END (* CASE ch OF ... *);
END (* DisplayMenu *);