PROGRAM R65; { V3A Edit #63 20-Mar-85 Autor: -tf-  File: R65.PAS  }

{ RT11SJ-V5, Oregon PASCAL V1.2 }  { 28 KW, RK05 }

{ Oregon PASCAL V1.3 bietet eine 'File-Delete-Moeglichkeit'
  die man hier einbauen koennte }

{ Doku siehe File: R65DOC.TXT }

{ Weitergabe und Gebrauch dieses Programms ohne Service und Haftung }
{ Fehler-Meldungen werden gerne entgegen genommen }

CONST
  VersionNumber = '3A-063/RT'; VersionDate = '20-Mar-85';

{
         Adresse des Autors:              Telefon:

         Eidg. Techn. Hochschule          01 / 256 5336
         Hybridrechenzentrum AIE          01 / 256 2211 (Zentrale)
         F. Kuster, dipl. El'Ing.
         Gloriastr. 35,  ETZ J96
         CH-8092 Z u e r i c h



}
LABEL
  1; {fatal EXIT}

CONST
  NOINSTR  = 111; { muss bei Aenderung von INSR65.ASM angepasst werden }
  NOPRD    =   8;
  NSYM     =  56; { Anzahl Symbole pro Record in SYMTAB.ASM }

TYPE
  ADDRMODE = (IMM,ABS,ZPAG,ACCU,IMPL,INDZPAGX,INDZPAGY,ZPAGX,
              ABSX,ABSY,REL,INDABS,ZPAGY,INDZPAG,INDABSX,ZPAGREL);
  SYMBOL   = (ADDR,BSS,BYTES,EQU,ORG,WORDS,MNEMS,TEXTS,MARK,LIST,NOLIST,
              NEWPAG,NEWFILE,SUBFILE,RETURN,ENDS,CHARS,IDENT,NUMBER,STRNG);
  ALFA     = PACKED ARRAY[1..10] OF CHAR;
  BYTE     = PACKED ARRAY[1..2] OF CHAR;
  CODELIST = ARRAY[ADDRMODE] OF BYTE;
  UNSIGNED = 0..65535;
  ERRMSG   = ARRAY[1..70] OF CHAR;
  SRCLINE  = ARRAY[1..100] OF CHAR;
  DATSTRNG = ARRAY[1..9] OF CHAR;
  LABTYP   = RECORD
               NAME    : ALFA;
               WERT    : UNSIGNED;
               LINNUM  : INTEGER;
               DEF,IO,
               MRK,DOUBLEDEF : BOOLEAN; {DOUBLEDEF nicht implementiert}
             END;
  TABTYP   = RECORD
               ANZ   : INTEGER;
               LETTER: CHAR;
               LAB   : ARRAY[1..NSYM] OF LABTYP
             END;
  SYMBTAB   = FILE OF TABTYP;

  TEXTSTRNG           = RECORD
                          ASCII   : ARRAY[1..NOPRD] OF BYTE;
                          LEN,VAL : UNSIGNED
                        END;
  INSTRINF            = RECORD
                          NAME     : ALFA;
                          SYM      : SYMBOL;
                          OPCODE   : CODELIST
                        END;

  LISTFLE   = ARRAY[1..256] OF INTEGER;
  MRKFIL    = FILE OF LISTFLE;

VAR
  SYMTAB                                 : SYMBTAB;
  ADDRM                                  : ADDRMODE;
  OPLEN,CC,PASS,
  LSTSIZ,LDASIZ,MRKSIZ,STASIZ,SYMSIZ, { File-Sizes for REWRITE }
  NOPG,NOPGST,LNO,LEV,LNCNT,CNTL1,CNTL2,KZ,LNOR,NOL,LEN,K,NOERR,C0,MM,SS,
  J,POS,ERRPOS1,ERRPOS2,ERRPOS3,ERRPOS4  : INTEGER;
  SYM,INSTR                              : SYMBOL;
  CH,CHLC,CHS,CHIN,TAB,FF,LASTOPERATION  : CHAR;
  NUM,ALCNT,ALC,VAL                      : UNSIGNED;
  ID,LABL,FILNAM,LOADFIL,SRCFIL,LISTFIL  : ALFA;
  PTEXT,NTEXT                            : TEXTSTRNG;
  LINE                                   : SRCLINE;
  NEWST,COMM,TXT,LAB,FULLOAD,ERRMES,{FALSE wenn R65ERR.ASM fehlt}
  PASSEND,OK,TXT0,COLB,ASS,FATAL,SHORT,MRK,MRKR,MRKBLK,LABMRK,SHPOSS,MRKMIN,
  TXT1,LST,LOAD,LISTNG,CMND,CREF,STBOUT  : BOOLEAN;
  ALCL,ALCH,HBT,LBT,OPC                  : BYTE;
  ZEIT                                   : REAL;
  DAT                                    : DATSTRNG;
  INSTRFIL                               : FILE OF INSTRINF;
  INSTRTAB                               : ARRAY[1..NOINSTR] OF INSTRINF;
  LISTE1,LISTE2                          : LISTFLE;
  MRKLST                                 : MRKFIL;
  OLDCMND                                : FILE OF SRCLINE;
  ERRTAB                                 : FILE OF ERRMSG;

  STATSTORE           : FILE OF RECORD
                                  DONE         :BOOLEAN;
                                  ALC          :UNSIGNED;
                                  DATA         :RECORD
                                                  DAT   :ARRAY[1..NOPRD]
                                                  OF BYTE;
                                                  LEN   :INTEGER
                                                END;
                                  ERROR        :RECORD
                                                  OK,PASS1  :BOOLEAN;
                                                  NUM,POS   :UNSIGNED
                                                END;
                                END;

  FILESTACK           : ARRAY[1..20] OF RECORD
                                          NAME: ALFA;
                                          NUM : INTEGER
                                        END;

  DELETFILE, LDAFIL, LSTFIL: TEXT; { Output-Files }

  PROCEDURE DATE(VAR DAT:DATSTRNG);FORTRAN;
  PROCEDURE NEWPAGE;

   BEGIN
     NOPG:=NOPG+1;
     IF STBOUT THEN NOPGST:=NOPGST+1;
     PAGE(LSTFIL);

     IF SRCFIL # FILNAM
     THEN
       WRITE(LSTFIL,'AIM-Files: ',SRCFIL:6,', ',FILNAM:6)
     ELSE
       WRITE(LSTFIL,'AIM-File:  ',SRCFIL:6,' ':8);
     WRITE(LSTFIL,' R65 Crossassembler ',VersionNumber);
     IF SHORT OR MRKBLK THEN WRITE(LSTFIL,' Short') ELSE WRITE(LSTFIL,' Full ');
     WRITELN(LSTFIL,' ',DAT,'  ','Page',NOPG:4);

     IF STBOUT
      THEN
       BEGIN
         WRITELN(LSTFIL,'Symboltable  -  Page':46,NOPGST:4);
         IF (NOT CREF) AND (NOERR <> 0)
           THEN WRITELN(LSTFIL,'(errors only)':39);
       END
       ELSE
         IF (NOT LISTNG) AND (NOERR <> 0)
           THEN WRITELN(LSTFIL,'(errors only)':39);


     WRITELN(LSTFIL); WRITELN(LSTFIL);

     IF STBOUT
      THEN
       BEGIN
         WRITE(LSTFIL,'  Label    Defined      Value');
         WRITELN(LSTFIL,' ':14,'Label    Defined      Value');
         WRITE(LSTFIL,'  -----    at line      --------------');
         WRITELN(LSTFIL,' ':5,'-----    at line      --------------');
         WRITELN(LSTFIL);
       END;
     LNCNT:=0
   END;


  PROCEDURE CMNDERR(N:INTEGER);
  VAR
    J:INTEGER;
   BEGIN
     WRITE(CHR(7),'R65 ');
     CASE N OF
       0 : WRITELN('bad command!');

       1 : BEGIN
            WRITE('can','''','t find ');
            J:=1;
            WHILE SRCFIL[J]#' ' DO
            BEGIN
               WRITE(SRCFIL[J]); J:=J+1;
            END;
            WRITELN('.AIM')
          END;

       2 : WRITELN('no short assembly possible : error(s) outside of MARK-block !');
       3 : WRITELN('DK:SYMTAB.ASM (Symboltable) not found !');
       4 : WRITELN('DK:STATST.ASM (Statement Store) not found !');
       5 : WRITELN('DK:MRKLST.ASM (Mark- and Updatelist) not found !');
       6 : WRITELN('DK:R65INS.ASM (Instruction Table) not found !');

      END;

     GOTO 1 {fatal EXIT}

   END;

  PROCEDURE SYMTABRST;
  VAR
    N,K : INTEGER;

   BEGIN
     RESET(SYMTAB,'SYMTAB','.ASM/SEEK',K);
     IF K <=0 THEN CMNDERR(3);
     FOR N:=1 TO 52 DO
      BEGIN
        SEEK(SYMTAB,N);
        FOR K:=1 TO SYMTAB^.ANZ DO
        IF SYMTAB^.LAB[K].MRK
         THEN
         WITH SYMTAB^.LAB[K] DO
          BEGIN
            DEF:=FALSE;
            IO :=FALSE
          END;
        PUT(SYMTAB);
      END
   END;


  PROCEDURE GETBYTE(VAR Z:UNSIGNED;VAR BT:BYTE);

  VAR
    J  :INTEGER;
    CH :CHAR;

    PROCEDURE GETDIG;

    VAR
      I,K  :INTEGER;

     BEGIN
       K:=Z MOD 16;
       IF K<10 THEN I:=48 ELSE I:=55;
       CH:=CHR(I+K);
       Z:=Z DIV 16
     END;

   BEGIN { GETBYTE }
     FOR J:=2 DOWNTO 1 DO
      BEGIN
        GETDIG; BT[J]:=CH
      END
   END;

  PROCEDURE GETWORD(VAR X:UNSIGNED;VAR HI,LO: BYTE);

   BEGIN
     GETBYTE(X,LO); GETBYTE(X,HI)
   END;
  PROCEDURE SYMTABOUT;
  VAR
    NL,        { Anzahl gedruckte Labels }
    NZ,        { Anzahl Zeilen pro Seite 1..100 }
    ANZL,      { Laufvariable 1.. SYMTAB^.ANZ }
    N0         { Zaehler 1..52 durch SYMTAB }
               : INTEGER;
    SYMBOLS    : ARRAY [1..101] OF LABTYP;  { Liste der zu druckenden Labels }
    BAD        : BOOLEAN;

    PROCEDURE DRUCKSYMLINE(INDEX:INTEGER);

    VAR
      LNO,DEZWERT  : INTEGER;
      HIBYT,LOBYT  : BYTE;
      X1           : LABTYP;

     BEGIN
     IF SYMBOLS[INDEX].LINNUM # 0 THEN
      BEGIN {1. ZEILE }
       X1:=SYMBOLS[INDEX];

       IF X1.LINNUM < 0 THEN LNO:=-X1.LINNUM ELSE LNO:=X1.LINNUM;
       IF (X1.DEF) AND (X1.IO) {AND (NOT X1.DOUBLEDEF)} AND (X1.LINNUM>0)
          THEN WRITE(LSTFIL,'  ') ELSE WRITE(LSTFIL,'**');

       WRITE(LSTFIL,X1.NAME,' ':2);

       IF X1.DEF
        THEN
         BEGIN
           WRITE(LSTFIL,LNO:4);
           IF X1.IO
            THEN
             BEGIN
               IF X1.LINNUM>0 THEN WRITE(LSTFIL,' ':6) ELSE WRITE(LSTFIL,' #### ');
               DEZWERT:=X1.WERT; {weil GETWORD den Input aendert !}
               GETWORD(X1.WERT,HIBYT,LOBYT);
               WRITE(LSTFIL,HIBYT,LOBYT,' (',DEZWERT:6,'.) ');
             END
            ELSE
               WRITE(LSTFIL,' too many forward',' ':4);
         END
        ELSE
         BEGIN {not .DEF}
           IF X1.LINNUM<0
            THEN
              WRITE(LSTFIL,LNO:4,' bad assignment!',' ':5)
            ELSE
               WRITE(LSTFIL,' ':10,'not defined!',' ':3);
         END;

       NL:=NL+1; {gedruckte Labels zaehlen}

      END
     ELSE
      BEGIN {2. ZEILE}

       X1:=SYMBOLS[INDEX-1];
       IF X1.LINNUM < 0 THEN LNO:=-X1.LINNUM ELSE LNO:=X1.LINNUM;

       IF X1.DEF {kompliziert, weil gewachsen !}
        THEN
         BEGIN
           IF X1.LINNUM<0
            THEN
              IF NOT X1.IO
              THEN WRITE(LSTFIL,'    references and multiple definition!')
              ELSE WRITE(LSTFIL,' ':19,'multiple definition!')
            ELSE
              IF NOT X1.IO THEN WRITE(LSTFIL,' ':19,'references!',' ':9);
         END
        ELSE
         BEGIN
           IF X1.LINNUM>0
            THEN WRITE(LSTFIL,' ':13,'first used in line',LNO:5,'   ');
         END;
     END;

     END; { DRUCKSYMLINE }


     PROCEDURE DRUCKSYMPAGE;

     VAR
     ZPK1, ZPK2, { Zeilen pro Kolonne }
     NKOL { zaehlt Zeile in Kol 1 resp. 2 }
     : INTEGER;

      BEGIN
        NEWPAGE;
        ZPK1:=(NZ+1) DIV 2;
        IF SYMBOLS[ZPK1+1].LINNUM=0 THEN ZPK1:=ZPK1+1;
        ZPK2:=NZ-ZPK1;
        FOR NKOL:=1 TO ZPK1 DO
        BEGIN
          DRUCKSYMLINE(NKOL);
          IF NKOL <= ZPK2 THEN
          BEGIN
            WRITE(LSTFIL,'  '); DRUCKSYMLINE(NKOL+ZPK1);
          END;
          WRITELN(LSTFIL);
        END;

        NZ:=0;

      END; { DRUCKSYMPAGE }

   BEGIN {SYMTABOUT}
     WRITELN('R65 Symbol-Table');
     FILNAM:=SRCFIL;
     STBOUT:=TRUE;
     RESET(SYMTAB,'SYMTAB.ASM','/SEEK');

       NOPGST:=0;
       NZ:=0; NL:=0;

       FOR N0:=1 TO 52 DO
        BEGIN
          SEEK(SYMTAB,N0);
          FOR ANZL:=1 TO SYMTAB^.ANZ DO
          BEGIN

            BAD:=(NOT SYMTAB^.LAB[ANZL].IO) OR (SYMTAB^.LAB[ANZL].LINNUM<0);

            IF BAD OR (CREF AND ((NOT SHORT) OR (SYMTAB^.LAB[ANZL].MRK)))
            THEN
              BEGIN
                NZ:=NZ+1; SYMBOLS[NZ]:=SYMTAB^.LAB[ANZL];
                IF SYMBOLS[NZ].DEF { alle Faelle mit 2 Zeilen markieren }
                THEN
                  BEGIN
                   IF (NOT SYMBOLS[NZ].IO) OR (SYMBOLS[NZ].LINNUM<0) THEN
                     BEGIN NZ:=NZ+1; SYMBOLS[NZ].LINNUM:=0 END;
                 END
                ELSE
                 BEGIN
                  IF SYMBOLS[NZ].LINNUM > 0 THEN
                     BEGIN NZ:=NZ+1; SYMBOLS[NZ].LINNUM:=0 END;
                 END

             END { Drucken erwuenscht };


             IF NZ > 99 THEN DRUCKSYMPAGE;

          END {FOR ANZ SYMBOLS PRO RECORD};

       END {FOR 1..52};

       IF NZ#0 THEN DRUCKSYMPAGE; { lezte Seite, nicht voll }

       WRITELN(LSTFIL);

       IF CREF THEN WRITELN(LSTFIL,'Number of labels used:',NL:5)
               ELSE WRITELN(LSTFIL,'Number of bad labels:',NL:5);

   END; {SYMTABOUT}
  PROCEDURE STATEMENT;

  LABEL
    2,3;

    PROCEDURE ERROR(N:INTEGER);

    VAR
      POSIT: UNSIGNED;
     BEGIN
       IF CMND
        THEN
        CMNDERR(0)
        ELSE
         BEGIN
           IF NOT (MRKR OR MRKBLK)
              THEN SHPOSS:=FALSE; {Fehler ausserhalb des Mark-Blocks}
            { andere Faelle: div. MARK-Fehler ??? ==> SHPOSS:=FALSE;}
           ASS:=FALSE; POSIT:=0 {solange nicht anders definiert};

           IF (PASS=1) OR ((PASS=2) AND (NOT STATSTORE^.ERROR.PASS1))
           THEN
            BEGIN
              NOERR:=NOERR+1; WRITELN('R65 error',N:4,' at line',LNO:5);
            END;

{          IF N IN [1,2,3,6,7,16,35,38,39,53..55] THEN POSIT:=0; }
           IF N IN [4,5,11..14,17,19..23,25,51]  THEN POSIT:=ERRPOS1;
           IF N IN [15]                          THEN POSIT:=ERRPOS3;
           IF N IN [18,24]                       THEN POSIT:=1;
           IF N IN [30..34]                      THEN POSIT:=ERRPOS2;
           IF N IN [10,50]                       THEN POSIT:=ERRPOS2-1;
           IF N IN [26,29,40..43,45,46]          THEN POSIT:=CC;
           IF N IN [36,37,44,47,48,49,52]        THEN POSIT:=ERRPOS2-1;
           IF N IN [46..48]                      THEN POSIT:=ERRPOS4{String};

           WITH STATSTORE^,ERROR DO
            BEGIN
              DONE    :=TRUE;
              OK      :=FALSE;
              PASS1   :=(PASS=1);
              NUM     :=N;
              POS     :=POSIT;
            END;

           IF (INSTR=ENDS) OR (INSTR=MARK) THEN STATSTORE^.DONE:=FALSE;
           IF (N IN [1..9]) OR FATAL THEN PASSEND:=TRUE {ev. auch andere?};

           ALCNT:=ALCNT+STATSTORE^.DATA.LEN;
           IF N=53 THEN GOTO 3;
           IF N#8  THEN GOTO 2 {8, 53 werden nach LABEL 2 entdeckt};
         END
     END;


    PROCEDURE GETSYM(NEWFLD,INSTRFLD:BOOLEAN);

      PROCEDURE GETCH;

      VAR
        J,TABPOS:INTEGER;

       BEGIN
         IF NEWST THEN
           BEGIN
             CC:=0;
             WHILE (NOT (EOF OR EOLN)) AND (CC<100) DO
              BEGIN
                CC:=CC+1; READ(LINE[CC]);

                IF LINE[CC]=TAB THEN
                BEGIN
                  TABPOS:= ((((CC-1) DIV 8) + 1) * 8); CC:=CC-1;
                  REPEAT CC:=CC+1; LINE[CC]:=' '; UNTIL CC=TABPOS;
                END;

                IF LINE[1]=FF THEN
                 BEGIN
                   LINE[1]:=' ';
                   LINE[2]:='N'; LINE[3]:='E'; LINE[4]:='W';
                   LINE[5]:='P'; LINE[6]:='A'; LINE[7]:='G';
                   LINE[8]:=' ';
                   LINE[9]:='<'; LINE[10]:='f'; LINE[11]:='f'; LINE[12]:='>';
                   CC:=12; 
                 END

              END;

             J:=CC; WHILE J<100 DO BEGIN J:=J+1; LINE[J]:=' ' END;

             IF EOF THEN
              IF PASS=1
              THEN
                BEGIN
                  STATSTORE^.DONE:=FALSE; PASSEND:=TRUE;
                  GOTO 2 { START PASS 2 ? }
                END
               ELSE
                ERROR(1);

             READLN;
             COMM := (CC=0) {Leer-Zeile};
             CC:=0; NEWST:=FALSE;
           END;

         CC:=CC+1; IF CC>100 THEN ERROR(38);
         CHLC:=LINE[CC];
         IF (CHLC >= 'a') AND (CHLC <= 'z') THEN
            CH:=CHR(ORD(CHLC)-40B) ELSE CH:=CHLC;


       END;
      PROCEDURE GETIDENT;

      VAR
        J,K : INTEGER;

       BEGIN
         K:=0;
          REPEAT
           K:=K+1;
           IF K>10 THEN ERROR(45);
           ID[K]:=CH;
           GETCH
          UNTIL NOT (CH IN ['A'..'Z','0'..'9',':']);
         IF K<10
          THEN
           BEGIN
             J:=10;
              REPEAT
               ID[J]:=' '; J:=J-1
              UNTIL J=K
           END
       END;


      PROCEDURE GETINSTR;

      VAR
        I,J,K : INTEGER;

       BEGIN
         I:=1; J:=NOINSTR;
          REPEAT
           K:=(I+J) DIV 2;
           IF ID<=INSTRTAB[K].NAME THEN J:=K-1;
           IF ID>=INSTRTAB[K].NAME THEN I:=K+1
          UNTIL I>J;

         IF I-1>J
          THEN
           BEGIN
             SYM:=INSTRTAB[K].SYM;
             POS:=K
           END
          ELSE SYM:=IDENT
       END;


      PROCEDURE GETNUM;

      VAR
        I,J,BASE : INTEGER;

       BEGIN
         SYM:=NUMBER;
         I:=CC-1;
         WHILE CH IN ['A'..'F','0'..'9'] DO GETCH;
         CASE CH OF
           'Z','.': BASE:=10;
           'O': BASE:= 8;
           'L': BASE:= 2;
           ELSE BASE:=16
          END;
         J:=CC; CC:=I;
         NUM:=0; GETCH;
          REPEAT
           IF (BASE=10) AND NOT (CH IN ['0'..'9']) THEN ERROR(40);
           IF (BASE= 8) AND NOT (CH IN ['0'..'7']) THEN ERROR(41);
           IF (BASE= 2) AND NOT (CH IN ['0','1']) THEN ERROR(42);
           IF ORD(CH)<=ORD('9')
            THEN I:=48
            ELSE I:=55;
           NUM:=BASE*NUM+(ORD(CH)-I);
           GETCH
          UNTIL CC=J;
         IF CH IN ['H','L','O','Z','.'] THEN GETCH
       END;



      PROCEDURE GETSTRNG;

      VAR
        VAL,J,K,ACBIN : UNSIGNED;
        ACHEX : BYTE;

       BEGIN
         SYM:=STRNG; VAL:=0;
         K:=0;
         GETCH;
          REPEAT
           ERRPOS4:=CC;
           K:=K+1;
           IF K>NOPRD THEN ERROR(46);
           ACBIN:=ORD(CHLC);
           CASE K OF
             1 : VAL:=ACBIN;
             2 : VAL:=ACBIN+VAL*256
            END;
           GETBYTE(ACBIN,ACHEX);
           PTEXT.ASCII[K]:=ACHEX;
           GETCH
          UNTIL CH='''';
         GETCH;
         PTEXT.VAL:=VAL;
         PTEXT.LEN:=K
       END;


     BEGIN { GETSYM }

       GETCH;
       IF NEWFLD THEN WHILE CH=' ' DO GETCH;

       IF CH IN ['A'..'Z']
        THEN
         BEGIN
           GETIDENT;
           IF INSTRFLD THEN GETINSTR ELSE SYM:=IDENT
         END
        ELSE
        IF CH IN ['0'..'9']
         THEN GETNUM
         ELSE
         IF CH=''''
          THEN GETSTRNG
          ELSE
          SYM:=CHARS;
       IF  (SYM#CHARS) THEN ERRPOS1:=CC-1 ELSE ERRPOS1:=CC
     END;

    PROCEDURE SUCHEN(USE:BOOLEAN);
    VAR
      C,L,N,KS : INTEGER;
      STORE    : LABTYP;

      PROCEDURE QUICKSUCH;
      VAR
        I,J  : INTEGER;

       BEGIN
         I:=1;
         J:=SYMTAB^.ANZ;

          REPEAT
           KS:=(I+J) DIV 2;
           IF LABL < SYMTAB^.LAB[KS].NAME THEN J:=KS ELSE I:=KS
          UNTIL (SYMTAB^.LAB[KS].NAME = LABL) OR(I=J) OR (J=I+1);

         IF LABL <> SYMTAB^.LAB[KS].NAME
          THEN
           BEGIN
             IF LABL <= SYMTAB^.LAB[I].NAME THEN KS:=I ELSE KS:=J;
           END

       END;

      PROCEDURE ZUWEIS(VAR X1:LABTYP);
       BEGIN
         X1.NAME:=LABL;
         IF USE
          THEN
          WITH X1 DO
           BEGIN
             IO:=FALSE;
             DEF:=FALSE;
             LINNUM:=LNO;
             MRK:=FALSE;
             OK:=FALSE;
           END
          ELSE
           BEGIN
             IF OK
              THEN
              WITH X1 DO
               BEGIN
                 IO:=TRUE;
                 WERT:=VAL;
                 LINNUM:=LNO;
                 DEF:=TRUE;
                 MRK:=FALSE;
               END
              ELSE
              WITH X1 DO
               BEGIN
                 IO:=FALSE;
                 DEF:=TRUE;
                 LINNUM:=LNO;
                 MRK:=FALSE;
               END
           END
       END;

      PROCEDURE SORT(VAR X : INTEGER);
      VAR
        L0  : INTEGER;
       BEGIN
         IF LABL > SYMTAB^.LAB[SYMTAB^.ANZ].NAME
          THEN
           BEGIN
             ZUWEIS(SYMTAB^.LAB[SYMTAB^.ANZ+1]);
             KS:=KS+1
           END
          ELSE
           BEGIN
             IF SYMTAB^.ANZ=NSYM
              THEN
               BEGIN
                 STORE:=SYMTAB^.LAB[NSYM];
                 L0:=SYMTAB^.ANZ-1
               END
              ELSE L0:=SYMTAB^.ANZ;
             FOR L:=L0 DOWNTO X DO
             SYMTAB^.LAB[L+1]:=SYMTAB^.LAB[L];
             ZUWEIS(SYMTAB^.LAB[X])
           END;
       END;

      PROCEDURE HOLEN(VAR X1 : LABTYP);
       BEGIN
         IF USE
          THEN
           BEGIN
             IF X1.IO
              THEN VAL:=X1.WERT
              ELSE
               BEGIN
                 IF PASS=1
                  THEN
                   BEGIN
                     OK:=FALSE;VAL:=1
                   END
                  ELSE
                   BEGIN
                     IF X1.DEF THEN ERROR(13) ELSE ERROR(14)
                   END
               END
           END
          ELSE
           BEGIN
             IF OK
              THEN
               BEGIN
                 IF X1.DEF
                  THEN
                   BEGIN
                     IF PASS = 1
                      THEN
                      BEGIN
                {X1.DOUBLEDEF:=TRUE; wird nicht geschrieben, wegen ERROR}
                        ERROR(15);
                      END
                      ELSE
                      WITH X1 DO
                       BEGIN
                         IO:=TRUE;
                         WERT:=VAL;
                         LINNUM:=LNO;
                       END
                   END
                  ELSE
                  WITH X1 DO
                   BEGIN
                     IO:=TRUE;
                     DEF:=TRUE;
                     WERT:=VAL;
                     LINNUM:=LNO;
                   END
               END
              ELSE
               BEGIN
                 IF X1.DEF
                   THEN
                    BEGIN
                {X1.DOUBLEDEF:=TRUE; wird nicht geschrieben, wegen ERROR}
                      ERROR(15);
                    END
                  ELSE
                   WITH X1 DO
                   BEGIN
                     IO:=FALSE;
                     DEF:=TRUE;
                     LINNUM:=LNO;
                   END
               END
           END
       END;



      PROCEDURE MARK;
       BEGIN
         IF SYMTAB^.LAB[KS].MRK AND USE AND NOT ASS THEN LABMRK:=TRUE;
         IF ASS THEN SYMTAB^.LAB[KS].LINNUM:=-LNO;
         IF ((NOT USE) OR ASS) AND (MRKR OR MRKBLK)
           THEN SYMTAB^.LAB[KS].MRK:=TRUE;
         ASS:=FALSE
       END;

     BEGIN  {SUCHEN} { "HASH"-Code: Anfangsbuchstabe gibt Record-Nummer }
       N:=2*ORD(LABL[1])-129;
       SEEK(SYMTAB,N);
       IF SYMTAB^.ANZ=0
        THEN
         BEGIN
           ZUWEIS(SYMTAB^.LAB[1]);
           SYMTAB^.ANZ:=1;
           KS:=1;
           MARK
         END
        ELSE
         BEGIN
           IF NOT((SYMTAB^.ANZ=NSYM) AND
                  (LABL > SYMTAB^.LAB[SYMTAB^.ANZ].NAME))
            THEN
             BEGIN
               QUICKSUCH;
               IF SYMTAB^.LAB[KS].NAME <> LABL
                THEN
                 BEGIN
                   SORT(KS);
                   MARK;
                   IF SYMTAB^.ANZ=NSYM
                    THEN
                     BEGIN
                       PUT(SYMTAB);
                       SEEK(SYMTAB,N+1);
                       IF SYMTAB^.ANZ <> 0
                        THEN
                         BEGIN
                           IF SYMTAB^.ANZ<NSYM
                            THEN
                             BEGIN
                               C:=1;SORT(C)
                             END
                            ELSE ERROR(17)
                         END;
                       SYMTAB^.LAB[1]:=STORE;
                       SYMTAB^.ANZ:=SYMTAB^.ANZ+1
                     END
                    ELSE  SYMTAB^.ANZ:=SYMTAB^.ANZ+1
                 END
                ELSE
                 BEGIN
                   HOLEN(SYMTAB^.LAB[KS]);
                   MARK;
                 END
             END
            ELSE
             BEGIN
               SEEK(SYMTAB,N+1);
               IF SYMTAB^.ANZ = 0
                THEN
                 BEGIN
                   ZUWEIS(SYMTAB^.LAB[1]);
                   SYMTAB^.ANZ:=SYMTAB^.ANZ+1;
                   KS:=1;
                   MARK
                 END
                ELSE
                 BEGIN
                   QUICKSUCH;
                   IF SYMTAB^.LAB[KS].NAME <> LABL
                    THEN
                     BEGIN
                       IF SYMTAB^.ANZ < NSYM
                        THEN
                         BEGIN
                           SORT(KS);
                           MARK;
                           SYMTAB^.ANZ:=SYMTAB^.ANZ+1
                         END
                        ELSE
                        ERROR(17)
                     END
                    ELSE
                     BEGIN
                       HOLEN(SYMTAB^.LAB[KS]);
                       MARK;
                     END
                 END
             END
         END;
       PUT(SYMTAB)
     END;


    PROCEDURE PRINTOUT; { Listing }

    VAR
      J,K,Z,POSIT:UNSIGNED;
      LC1,LC2 : INTEGER;

  PROCEDURE LINEINCR;
   BEGIN
     WRITELN(LSTFIL);
     LNCNT:=LNCNT+1;
     IF LNCNT >= 55 THEN NEWPAGE
   END;

      PROCEDURE WRITEDAT;

      VAR
        I:INTEGER; BT:BYTE;

       BEGIN
         Z:=K;
         GETWORD(Z,ALCH,ALCL);
         WRITE(LSTFIL,ALCH,ALCL,'  ');
         K:=K+4;
         FOR I:=1 TO 4 DO
          BEGIN
            J:=J+1;
            IF J>STATSTORE^.DATA.LEN
             THEN BT:='  '
             ELSE BT:=STATSTORE^.DATA.DAT[J];
            WRITE(LSTFIL,BT,' ')
          END
       END;


     BEGIN { PRINTOUT }
       IF ( NOT(STATSTORE^.ERROR.OK) AND (LNCNT >=51)) OR (NOPG=0)
        THEN NEWPAGE;

       WRITE(LSTFIL,LNO:4,' ');
       J:=0;
       K:=STATSTORE^.ALC;
       WRITEDAT; WRITE(LSTFIL,TAB);
       LC1:=100;
       WHILE (LINE[LC1] = ' ') AND (LC1>1) DO LC1:=LC1-1;
       FOR LC2:=1 TO LC1 DO WRITE(LSTFIL,LINE[LC2]);
       WRITELN(LSTFIL);
       LNCNT:=LNCNT+1;
       IF NOT STATSTORE^.ERROR.OK
        THEN
         BEGIN
           POSIT:=STATSTORE^.ERROR.POS;
           IF POSIT=0
            THEN WRITE(LSTFIL,'*********',' ':14)
            ELSE WRITE(LSTFIL,'*********',' ':15+POSIT-1,'^');
           WRITELN(LSTFIL,STATSTORE^.ERROR.NUM:2);
           LNCNT:=LNCNT+1;
           IF ERRMES THEN
           BEGIN
              SEEK(ERRTAB,STATSTORE^.ERROR.NUM);
              WRITELN(LSTFIL,'*********  error  ',ERRTAB^);
           END;
           WRITELN(LSTFIL);
           LNCNT:=LNCNT+2;
         END {if not ok};

       WHILE J<STATSTORE^.DATA.LEN DO {nur 2 Zeilen zu 4 bytes}
        BEGIN
          WRITE(LSTFIL,' ':5); WRITEDAT; WRITELN(LSTFIL);
          LNCNT:=LNCNT+1;
        END;

       IF LNCNT >= 55 THEN NEWPAGE;

       IF MRKMIN
        THEN
         BEGIN
           LNO:=LNO+1;
           SEEK(STATSTORE,LNO);
           WHILE LNO < LISTE2[CNTL2] DO {naechste 'vernuenftige' }
            BEGIN                       {Zeile muss in Liste 2 sein!}
              WRITE(LSTFIL,LNO:4,' ');
              J:=0;
              K:=STATSTORE^.ALC;
              WRITEDAT;
              LINEINCR;
              WHILE J < STATSTORE^.DATA.LEN DO
               BEGIN
                 WRITE(LSTFIL,' ':5); WRITEDAT; LINEINCR;
               END;
              LNO:=LNO+1;
              SEEK(STATSTORE,LNO);
            END;

           IF SHORT THEN LINEINCR;
           LNO:=LNO-1;
           MRKMIN:=FALSE;
           CNTL2:=CNTL2+1;
         END;
     END;
    PROCEDURE PUSHBYTE(VAR BT : BYTE);

    VAR
      K : INTEGER;

     BEGIN
       K:=STATSTORE^.DATA.LEN;
       K:=K+1;
       WITH STATSTORE^.DATA DO
        BEGIN
          DAT[K]:=BT;
          LEN:=K
        END
     END;


    PROCEDURE PUSHWORD(VAR HI,LO : BYTE);

     BEGIN
       IF OPLEN<>0
        THEN
         BEGIN
           PUSHBYTE(HI);
           IF OPLEN=2 THEN PUSHBYTE(LO)
         END
     END;



   PROCEDURE GETEXPR;

    VAR
      STACKPO: INTEGER; {INDEX of VALSTACK}
      VALSTACK: ARRAY [1..40] OF INTEGER;
      FIRSTELEMENT, {weil GETSYM schon gemacht ist}
      SYMCHAR {lokales SYM=CHAR} : BOOLEAN;
      LOCALCH: CHAR;


      PROCEDURE KONSTANT;

       BEGIN
         TXT0:=FALSE;
         CASE SYM OF
           IDENT :  BEGIN
                      LABL:=ID;
                      SUCHEN(TRUE)
                    END;

           NUMBER:  VAL:=NUM;

           STRNG :  BEGIN
                      TXT0:=TRUE;
                      VAL:=PTEXT.VAL;
                      NTEXT:=PTEXT
                    END;

           CHARS :  IF LOCALCH # '$'
                      THEN ERROR(11) {illegal Symbol}
                      ELSE VAL:=ALCNT;

          END {CASE};
       END {KONSTANT};



      PROCEDURE PUSHNUM(VAR X:INTEGER);

       BEGIN
       STACKPO:=STACKPO+1;
       IF STACKPO<=40
         THEN VALSTACK[STACKPO]:=X
         ELSE ERROR(44); {EXPRESSION NESTING TOO DEEP}
       END {PUSHNUM};



      PROCEDURE PULLNUM(VAR X:INTEGER);
       BEGIN
         X:=VALSTACK[STACKPO];
         STACKPO:=STACKPO-1;
       END {PULLNUM};

      PROCEDURE CALCULATE(OP:CHAR);
      BEGIN

        CASE OP OF
{or}    '!': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] OR VALSTACK[STACKPO+1];
             END;

{add}   '+': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] + VALSTACK[STACKPO+1];
             END;

{sub}   '-': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] - VALSTACK[STACKPO+1];
             END;


{and}   '&': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] AND VALSTACK[STACKPO+1];
             END;

{mul}   '*': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] * VALSTACK[STACKPO+1];
             END;

{div}   '/': BEGIN
               STACKPO:=STACKPO-1;
               VALSTACK[STACKPO]:=VALSTACK[STACKPO] DIV VALSTACK[STACKPO+1];
             END;


{not}       '^': VALSTACK[STACKPO]:= NOT VALSTACK[STACKPO];

{negate}    '=': VALSTACK[STACKPO]:=-VALSTACK[STACKPO];

{high Byte} '>': VALSTACK[STACKPO]:=((VALSTACK[STACKPO] DIV 256) AND 377B);

{low byte}  '<': VALSTACK[STACKPO]:=VALSTACK[STACKPO] AND 377B;

        END {CASE};

        TXT1:=FALSE {es wurde gerechnet};
        LASTOPERATION:=OP  {fuer REDUCE};

      END {CALCULATE};

   PROCEDURE NEXTELEMENT;
{

   dies ist eine "Anpass-Procedur" zwischen GETSYM und den FORMEL-Prozeduren
   AUSDRUCK, TERM und FACTOR, welche eine andere INPUT-Schnittstelle haben:
   - R65 hat GETSYM schon gemacht, FORMEL will selber einlesen,
   - GETSYM liefert z.T. zwei Elemente: Symbol und Delimiter, FORMEL will
     nur ein Element aufs Mal

   Eine spaetere direkte Anpassung ist nicht ausgeschlossen

}

   BEGIN {NEXTELEMENT}
     IF FIRSTELEMENT
     THEN
      BEGIN
        FIRSTELEMENT:=FALSE; 
        IF SYM=CHARS
         THEN
          BEGIN
            LOCALCH:=CH; SYMCHAR:=TRUE;
          END
         ELSE
          BEGIN
            LOCALCH:='S' {SYMBOL}; SYMCHAR:=FALSE;
          END
      END
     ELSE
      BEGIN {NOT FIRST ELEMENT}
        IF SYMCHAR
         THEN
          BEGIN
            GETSYM(FALSE,FALSE);
            IF SYM=CHARS
             THEN
              BEGIN
                LOCALCH:=CH; SYMCHAR:=TRUE;
              END
             ELSE
              BEGIN
                LOCALCH:='S' {SYMBOL}; SYMCHAR:=FALSE;
              END
          END
         ELSE
          BEGIN
            LOCALCH:=CH; SYMCHAR:=TRUE; SYM:=CHARS;
          END;
      END;

      ERRPOS2:=CC;

   END {NEXTELEMENT};

  PROCEDURE Ausdruck;
  VAR
      adop : CHAR;
      func1,func2,func3 : CHAR;

    PROCEDURE Term;
    VAR
      mulop : CHAR;

      PROCEDURE Factor;
       BEGIN {Factor}
       NEXTELEMENT;
         IF (LOCALCH='+') OR (LOCALCH='-')
          THEN
           BEGIN
             IF LOCALCH='+'
              THEN func1:='.'
              ELSE func1:='=';
             NEXTELEMENT;
           END
          ELSE func1:='.';

         func3:='.';
         IF (LOCALCH='<') OR (LOCALCH='>') OR (LOCALCH='^')
          THEN
           BEGIN
             func2:=LOCALCH;
             NEXTELEMENT;
             IF (LOCALCH='+') OR (LOCALCH='-')
              THEN
               BEGIN
                 IF LOCALCH='+'
                  THEN func3:='.'
                  ELSE func3:='=';
                 NEXTELEMENT;
               END
           END
          ELSE func2:='.';


         IF (LOCALCH = '(')
          THEN
           BEGIN
             Ausdruck;
             IF LOCALCH = ')'
              THEN
              BEGIN
                IF func3#'.' THEN CALCULATE(func3);
                IF func2#'.' THEN CALCULATE(func2);
                IF func1#'.' THEN CALCULATE(func1);
              END
              ELSE
              BEGIN
                ERROR(30) { ')' expected }
              END
           END
          ELSE
           BEGIN
             KONSTANT;
             PUSHNUM(VAL);
             IF func3#'.' THEN CALCULATE(func3);
             IF func2#'.' THEN CALCULATE(func2);
             IF func1#'.' THEN CALCULATE(func1);
           END;
          CHS:=LOCALCH;
          NEXTELEMENT;
          IF (CHS='$') AND (NOT SYMCHAR) THEN ERROR(11) {illegales Symbol};
        END {Factor};

     BEGIN {Term}
       Factor;
       WHILE (LOCALCH IN ['*','/','&']) DO
        BEGIN
          mulop := LOCALCH;
          Factor;
          CALCULATE(mulop);
        END;
     END {Term};


   BEGIN {Ausdruck}
     Term;
     WHILE (LOCALCH IN ['+','-','!']) DO
      BEGIN
        adop := LOCALCH;
        term;
        CALCULATE (adop);
      END;
   END {Ausdruck};

 BEGIN {GETEXPR}
   FIRSTELEMENT:=TRUE;
   OK:= TRUE;
   STACKPO:=0;
   TXT1:=TRUE;

   Ausdruck;
   PULLNUM(VAL);

   IF NOT (LOCALCH IN [' ',',',']'])
     THEN  Error(34) {illegal operator or delimiter};

   CHS:=LOCALCH;       {fuer R65}
   TXT:=TXT0 AND TXT1; {fuer R65}
 END{GETEXPR};

    PROCEDURE SWITCHOVER;
    VAR
      LEN:INTEGER;
     BEGIN
       LNOR:=0;
       CLOSE(INPUT);
       FATAL:=TRUE;
       GETSYM(TRUE,FALSE);
       FATAL:=FALSE;
       IF (SYM#IDENT) THEN ERROR(4);
       FILNAM:=ID;
       RESET(INPUT,FILNAM,'.AIM',LEN);
       IF LEN<=0 THEN ERROR(5)
     END;



    PROCEDURE SWITCHAWAY;
     BEGIN
       IF LEV>20 THEN ERROR(2);
       WITH FILESTACK[LEV] DO
        BEGIN
          NAME:=FILNAM;
          NUM:=LNOR
        END;
       SWITCHOVER;
       LEV:=LEV+1
     END;


    PROCEDURE SWITCHBACK;
    VAR
      J:INTEGER;

     BEGIN
       LEV:=LEV-1;
       IF LEV<1 THEN ERROR(3);
       CLOSE(INPUT);
       FILNAM:=FILESTACK[LEV].NAME;
       RESET(INPUT,FILNAM,'.AIM');
       LNOR:=FILESTACK[LEV].NUM;
       FOR J:=1 TO LNOR DO READLN
     END;


    PROCEDURE GETOPRD;

     BEGIN
       IF TXT
        THEN
         BEGIN
           ERRPOS4:=CC-NTEXT.LEN+OPLEN-1;
           IF NTEXT.LEN>OPLEN THEN ERROR(46+OPLEN);
           IF NTEXT.LEN=1
            THEN
             BEGIN
               HBT:='00';
               LBT:=NTEXT.ASCII[1]
             END
            ELSE
             BEGIN
               HBT:=NTEXT.ASCII[1];
               LBT:=NTEXT.ASCII[2]
             END
         END
        ELSE
        IF OK
         THEN
         GETWORD(VAL,HBT,LBT)
         ELSE
          BEGIN
            HBT:='  ';
            LBT:='  ';
            STATSTORE^.DONE:=FALSE
          END
     END;


    PROCEDURE ASSIGNMENT;

    VAR
      ID1      : ALFA;

     BEGIN
       IF LAB
        THEN
         BEGIN
           ID1:=LABL;
           GETSYM(TRUE,FALSE);
           GETEXPR;
           IF LABMRK AND (NOT(MRKR OR MRKBLK)) THEN ERROR(56);
           IF NOT OK THEN STATSTORE^.DONE:=FALSE;
           LABL:=ID1;
           SUCHEN(FALSE);
           IF  (CHS#' ') THEN ERROR(33)
         END
        ELSE
        ERROR(18)
     END;


    PROCEDURE ALCCHANGE;

     BEGIN
       GETSYM(TRUE,FALSE);
       GETEXPR;
       IF LABMRK AND (NOT(MRKR OR MRKBLK)) THEN ERROR(56);
       IF (CHS#' ') THEN ERROR(33);
       IF OK
        THEN
        CASE INSTR OF
          BSS : ALCNT:=ALCNT+VAL;
          ORG : ALCNT:=VAL
         END
        ELSE ERROR(35)
     END;


    PROCEDURE PUSHSTRNG;

    VAR
      CODE : BYTE;
      J : INTEGER;

     BEGIN
       GETSYM(TRUE,FALSE);
       J:=0;
       IF SYM=STRNG
        THEN
         REPEAT
          J:=J+1;
          CODE:=PTEXT.ASCII[J];
          PUSHBYTE(CODE)
         UNTIL J=PTEXT.LEN
        ELSE
        ERROR(19);
       ALCNT:=ALCNT+J
     END;


    PROCEDURE GETDAT;

    VAR
      K: INTEGER;

     BEGIN
       IF INSTR IN [WORDS,ADDR] THEN OPLEN:=2 ELSE OPLEN:=1;
       K:=0;

        REPEAT
         K:=K+OPLEN;
         GETSYM(TRUE,FALSE);
         GETEXPR;
         IF K>NOPRD THEN
         BEGIN
           ALCNT:=ALCNT-(K-OPLEN); { 4-Okt-83 }
           ERROR(49);
         END;
         GETOPRD;

         CASE INSTR OF
           WORDS : PUSHWORD(HBT,LBT);
           ADDR  : PUSHWORD(LBT,HBT);
           BYTES : PUSHBYTE(LBT)
          END;

         IF NOT (CHS IN [',',' ']) THEN
         BEGIN
           ALCNT:=ALCNT-(K-OPLEN); { 4-Okt-83 }
           ERROR(32);
         END;

         ALCNT:=ALCNT+OPLEN;   { 3-Okt-83 }

        UNTIL CHS#',';

{ 3-Okt-83  ALCNT:=ALCNT+K }

     END;


    PROCEDURE MACHOP;


      PROCEDURE INDIRECT;

       BEGIN
         GETSYM(FALSE,FALSE);
         GETEXPR;
         GETSYM(FALSE,FALSE);
         CASE CHS OF {CHS ist Delimiter nach GETEXPR}
           ',' :
                   IF (SYM=IDENT) AND (ID='X         ')
                    THEN
                     BEGIN
                       ADDRM:=INDABSX; OPLEN:=2; {25-May-84}
                       IF CH#']' THEN ERROR(29){] exp};
                     END
                    ELSE
                    ERROR(20);
           ']' :
                   IF SYM=CHARS
                    THEN
                    CASE CH OF
                    ',':
                         BEGIN
                           GETSYM(FALSE,FALSE);
                           IF (SYM=IDENT) AND (ID='Y         ')
                            THEN
                             BEGIN
                               ADDRM:=INDZPAGY; OPLEN:=1;
                               IF CH#' ' THEN ERROR(26){space exp};
                               GETOPRD;
                               IF OK THEN IF (HBT#'00') THEN ERROR(10)
                             END
                            ELSE ERROR(21)
                         END;
                    ' ':
                         BEGIN
                           ADDRM:=INDABS; OPLEN:=2
                         END;

                    ELSE ERROR(22)
                 END {CASE CH}
                 ELSE ERROR(22){SYM#CHARS};

          ELSE ERROR(31){, or ] exp}
          END {CASE CHS};

       END;

      PROCEDURE IMMEDIATE;

       BEGIN
         ADDRM:=IMM; OPLEN:=1;
         GETSYM(FALSE,FALSE);
         GETEXPR;
         GETOPRD;
         IF OK THEN
           IF (HBT<>'00') THEN
            IF (HBT='FF') {negative value}
            THEN HBT:='00'
            ELSE ERROR(50){only 1 byte allowed};

         IF CHS#' ' THEN ERROR(33){space exp.}
       END;



      PROCEDURE RELATIVE;

      VAR
        OFFSET : UNSIGNED;

       BEGIN
         IF OK
          THEN
           BEGIN
             OFFSET:=VAL-ALCNT-OPLEN-1; {Branch: OPLEN=1, BBxx: OPLEN=2}
             GETWORD(OFFSET,HBT,LBT);
             IF HBT='00'
              THEN
               BEGIN
                 IF LBT>'7F' THEN ERROR(36)
               END
              ELSE
              IF HBT='FF'
               THEN
                BEGIN
                  IF LBT<'80' THEN ERROR(36);
                  HBT:='00';
                END
               ELSE ERROR(36)
           END
          ELSE
           BEGIN
             LBT:='  ';
             STATSTORE^.DONE:=FALSE
           END
       END;



      PROCEDURE INDEXED;

       VAR SAVLBT: BYTE;
           SAVERRPOS2: INTEGER;

       BEGIN
         SAVERRPOS2:=ERRPOS2;
         GETSYM(FALSE,FALSE);
         IF SYM=IDENT
          THEN
          IF ID='X         '
           THEN ADDRM:=ABSX
           ELSE
           IF ID='Y         '
            THEN ADDRM:=ABSY
            ELSE
             IF INSTRTAB[POS].OPCODE[ZPAGREL] <> '  ' THEN
              BEGIN {BRANCH ON SINGLE BIT}
                OPLEN:=1; GETOPRD;
                SAVLBT:=LBT; {ZPAGE-ADR fuer Branch}
                ADDRM:=ZPAGREL; OPLEN:=2;
                IF OK AND (HBT <> '00') THEN ERROR(10) {not zpage-adr};
                GETEXPR;
                RELATIVE {Offset rechnen und pruefen};
                IF CHS <> ' ' THEN ERROR(33){space exp.};
                HBT:=LBT{OFFSET};
                LBT:=SAVLBT{ZEROPAGE ADR};
              END
             ELSE
                ERROR(23)

          ELSE ERROR(23);
          IF CH#' ' THEN ERROR(26) {space exp. };
       END;


      PROCEDURE REDUCE;
      VAR
        OPCZ : BYTE;
        REDUCEFLG : BOOLEAN;
        REDUCEAM: ADDRMODE;

       BEGIN
         REDUCEFLG:=(PASS=1) AND (HBT='00')
                    AND NOT(LABMRK AND NOT(MRKR OR MRKBLK));

         CASE ADDRM OF

           ABSX:    REDUCEAM:=ZPAGX;
           ABSY:    REDUCEAM:=ZPAGY;
           ABS:     REDUCEAM:=ZPAG;
           INDABS:  REDUCEAM:=INDZPAG;
           INDABSX: REDUCEAM:=INDZPAGX;

         END{CASE};


         IF INSTRTAB[POS].OPCODE[REDUCEAM] <> '  ' THEN
          BEGIN
            IF INSTRTAB[POS].OPCODE[ADDRM] = '  ' THEN
             BEGIN
               OPLEN:=1; ADDRM:=REDUCEAM;
               IF OK AND (HBT<>'00') THEN ERROR(10);
             END{IF ZPAG ONLY}
            ELSE
             BEGIN
               IF REDUCEFLG THEN
                BEGIN
                  OPLEN:=1; ADDRM:=REDUCEAM;
                END{IF REDUCE}
             END{IF ABS AND ZPAG}
          END{IF NO ZPAG};


       END{REDUCE};



     BEGIN { MACHOP }
       IF INSTRTAB[POS].OPCODE[IMPL]<>'  '
        THEN
         BEGIN
           ADDRM:=IMPL; OPLEN:=0
         END
        ELSE
         BEGIN
           GETSYM(TRUE,FALSE);
           IF (SYM=IDENT) AND (ID='A         ')
            THEN
             BEGIN
               ADDRM:=ACCU; OPLEN:=0;
               IF CH#' ' THEN ERROR(26){space exp.};
             END
            ELSE
             BEGIN
               IF (SYM=CHARS) AND (CH IN ['#','['])
                THEN
                CASE CH OF
                  '#' : IMMEDIATE;
                  '[' : INDIRECT
                 END
                ELSE
                 BEGIN
                   GETEXPR;
                   CASE CHS OF
                     ',' : INDEXED; {V3: auch 'Zpage,Rel'}
                     ' ' :
                        IF INSTRTAB[POS].OPCODE[REL]<>'  '
                         THEN
                          BEGIN
                            ADDRM:=REL; OPLEN:=1;
                            RELATIVE;
                          END
                         ELSE
                          BEGIN
                            ADDRM:=ABS; OPLEN:=2;
                          END;
                     ELSE ERROR(32)
                    END {CASE};

                 END{ELSE}
             END{ELSE};

             IF ADDRM IN [ABS,ABSX,ABSY,INDABS,INDABSX] THEN
              BEGIN
                OPLEN:=2;
                GETOPRD;
                REDUCE
              END{IF REDUCE VERSUCHEN};

         IF OK AND (OPLEN=1) THEN IF (HBT#'00') THEN ERROR(50)

         END{ELSE};

       OPC:=INSTRTAB[POS].OPCODE[ADDRM];
       PUSHBYTE(OPC);
       PUSHWORD(LBT,HBT);
       ALCNT:=ALCNT+OPLEN+1;
       IF OPC='  ' THEN ERROR(39)
     END{MACHOP};

    PROCEDURE PUTLIST(VAR LNO : INTEGER);
    VAR
      K : INTEGER;

      PROCEDURE LISTSUCH;
       BEGIN
         K:=2;
         WHILE (LISTE1[K] < LNO) AND (K <= 256) DO K:=K+1;
       END;


      PROCEDURE SORT(VAR K : INTEGER);
      VAR
        I : INTEGER;

       BEGIN
         FOR I:=LISTE1[1]+1 DOWNTO K DO LISTE1[I+1]:=LISTE1[I];
         LISTE1[K]:=LNO;
         LISTE1[1]:=LISTE1[1]+1;
       END;

     BEGIN { PUTLIST }
       IF LISTE1[1] = 0
        THEN
         BEGIN
           LISTE1[2]:=LNO;
            LISTE1[1]:=1
         END
        ELSE
         BEGIN
           IF LISTE1[1]>=254 THEN ERROR(53);
           IF LNO > LISTE1[LISTE1[1]+1]
            THEN
             BEGIN
               LISTE1[LISTE1[1]+2]:=LNO;
               LISTE1[1]:=LISTE1[1]+1;
             END
            ELSE
             BEGIN
               LISTSUCH;
               IF LISTE1[K] <> LNO THEN SORT(K);
             END
         END
     END;

    PROCEDURE MARKPR;
    VAR
      K : INTEGER;

      PROCEDURE NOPINS;
       BEGIN
         PUT(STATSTORE);
         LNO:=LNO+1;
         WITH STATSTORE^,DATA,ERROR DO
          BEGIN
            DONE:=TRUE;
            ALC:=K;
            DAT[1]:='EA';
            LEN:=1;
            OK:=TRUE;
          END;
       END;


      PROCEDURE EAINS;
      VAR
        C : INTEGER;

       BEGIN
         WHILE LISTE2[CNTL2+1]-(LNO+1) < LISTE2[CNTL2]-ALCNT DO
          BEGIN
            PUT(STATSTORE);
            LNO:=LNO+1;
            SEEK(STATSTORE,LNO);
            C:=0;

            WITH STATSTORE^,ERROR DO
             BEGIN
               DONE:=TRUE;
               ALC:=ALCNT;
               OK:=TRUE;
             END;

            WHILE (LISTE2[CNTL2+1]-LNO <= LISTE2[CNTL2]-ALCNT)
            AND (STATSTORE^.DATA.LEN < 8) DO
             BEGIN
               C:=C+1;
               WITH STATSTORE^.DATA DO
                BEGIN
                  DAT[C]:='EA';
                  LEN:=C;
                END;
               ALCNT:=ALCNT+1;
             END;
          END;

         WHILE ALCNT < LISTE2[CNTL2] DO
          BEGIN
            PUT(STATSTORE);
            LNO:=LNO+1;
            SEEK(STATSTORE,LNO);

            WITH STATSTORE^,DATA,ERROR DO
             BEGIN
               DONE:=TRUE;
               ALC:=ALCNT;
               DAT[1]:='EA';
               LEN:=1;
               OK:=TRUE;
             END;
            ALCNT:=ALCNT+1;
          END;

         WHILE LNO < LISTE2[CNTL2+1]-1 DO
          BEGIN
            PUT(STATSTORE);
            LNO:=LNO+1;
            SEEK(STATSTORE,LNO);
            WITH STATSTORE^,DATA,ERROR DO
             BEGIN
               DONE:=TRUE;
               ALC:=ALCNT;
               LEN:=0;
               OK:=TRUE;
             END;
          END;
       END{EAINS};

      PROCEDURE MARKPLUS;
       BEGIN
         STATSTORE^.DONE:=FALSE;
         IF NOT SHORT
          THEN
           BEGIN                     { full assembly }
             IF MRKR THEN ERROR(54);
             IF CNTL2>=256 THEN ERROR(9){too many MARK-Blocks};
             PUTLIST(LNO);
             MRK:=TRUE;
             MRKR:=TRUE;
           END
          ELSE
           BEGIN                     { short assembly }
             MRKBLK:=TRUE;
             SHORT:=FALSE;
             LST:=TRUE
           END
       END;

      PROCEDURE MARKMINUS;

      VAR ERR52: BOOLEAN;

       BEGIN
         IF NOT MRKBLK
          THEN
           BEGIN                    { full assembly }
             IF NOT MRKR THEN ERROR(55);
             MRKR:=FALSE;
             IF PASS=1
              THEN
               BEGIN
                 STATSTORE^.DONE:=FALSE;

                  IF VAL > 8192 {z.B. mehr als 8K, und negativ!} THEN
                  BEGIN
                    VAL:=0; ERR52:=TRUE;
                  END
                  ELSE
                  BEGIN
                    FOR K:=ALCNT TO ALCNT+VAL-1 DO NOPINS;
                    ERR52:=FALSE;
                  END;

                 ALCNT:=ALCNT+VAL;
                 LISTE2[CNTL2]:=ALCNT; CNTL2:=CNTL2+1;
                 LISTE2[CNTL2]:=LNO+1; CNTL2:=CNTL2+1;
                 LISTE2[1]:=LISTE2[1]+2;

                 IF ERR52 THEN ERROR(52){negativ};

               END
              ELSE
               BEGIN  {Pass 2, full}
                 CNTL2:=CNTL2+1;
                 IF LISTNG
                  THEN MRKMIN:=TRUE
                  ELSE
                   BEGIN
                     LNO:=LISTE2[CNTL2]-1;
                     CNTL2:=CNTL2+1
                   END
               END
           END
          ELSE

           BEGIN                           { short assembly }
             SHORT:=TRUE;
             MRKBLK:=FALSE;
             LST:=FALSE;
             IF PASS=1
              THEN
               BEGIN
                 STATSTORE^.DONE:=FALSE;
                 IF ALCNT > LISTE2[CNTL2] THEN ERROR(7);
                 IF LNO > LISTE2[CNTL2+1] THEN ERROR(6);
                 EAINS;
                 ALCNT:=LISTE2[CNTL2];
                 CNTL2:=CNTL2+1;
                 IF LNO > LISTE2[CNTL2] THEN ERROR(6);
                 LNO:=LISTE2[CNTL2]-1;
                 CNTL2:=CNTL2+1;
               END
              ELSE
               BEGIN {Pass 2}
                 IF ALCNT > LISTE2[CNTL2] THEN ERROR(7);
                 IF LNO > LISTE2[CNTL2+1] THEN ERROR(6);
                 CNTL2:=CNTL2+1;
                 IF LISTNG
                  THEN MRKMIN:=TRUE
                  ELSE
                   BEGIN
                     LNO:=LISTE2[CNTL2]-1;
                     CNTL2:=CNTL2+1
                   END
               END;
           END;
       END{MARKMINUS};

     BEGIN { MARKPR }
       GETSYM(TRUE,FALSE);
       IF SYM=CHARS
        THEN
        IF CH='+'
         THEN MARKPLUS
         ELSE
         IF CH='-'
          THEN
           BEGIN
             GETSYM(TRUE,FALSE);
             GETEXPR;
                 IF NOT OK THEN ERROR(37){forward reference}; 
                 IF NOT OK THEN VAL:=0{dieses Statement wird nie erreicht !?};
             MARKMINUS
           END
          ELSE ERROR(51)
        ELSE ERROR(51) {+ or - expected}
     END {MARKPR};

   BEGIN { STATEMENT }
     IF CMND
      THEN
      GETSYM(FALSE,FALSE)
      ELSE

       BEGIN
         LABMRK:=FALSE;
         LNO:=LNO+1;
         LNOR:=LNOR+1;

         IF SHORT
          THEN
           BEGIN
             FOR KZ:=LNO TO LISTE1[CNTL1]-1  DO
              BEGIN
                READLN; { ueberlesen, was nicht gebraucht }
                LNOR:=LNOR+1;
              END;
             LNO:=LISTE1[CNTL1];
             CNTL1:=CNTL1+1;
             IF PASS=1
              THEN
               BEGIN
                 INSTR:=IDENT;
                 SEEK(STATSTORE,LNO);
                 ALCNT:=STATSTORE^.ALC;
               END;
           END;

         IF PASS=1
          THEN
            WITH STATSTORE^,ERROR DO
             BEGIN
               DONE      :=TRUE;
               ALC       :=ALCNT;
               OK        :=TRUE;
               PASS1     :=FALSE;
             END
          ELSE
           BEGIN { Pass 2 }
             INSTR:=IDENT;
             SEEK(STATSTORE,LNO);
             ALCNT:=STATSTORE^.ALC
           END;

         IF (PASS=1) OR NOT STATSTORE^.DONE
          THEN
           BEGIN
             STATSTORE^.DATA.LEN:=0;
             NEWST:=TRUE;
             GETSYM(FALSE,FALSE);
             IF SHORT
              THEN
               BEGIN
                 COMM:=FALSE;
                 LAB:=FALSE
               END
              ELSE
              CASE SYM OF
                CHARS :
                CASE CH OF
                  '*',';' :COMM:=TRUE;
                      ' ' :LAB:=FALSE;
                  ELSE ERROR(24)
                 END;
                IDENT:
                 BEGIN
                   LAB:=TRUE;
                   LABL:=ID;
                   ERRPOS3:=CC-1;
                   IF PASS = 1
                    THEN
                     BEGIN
                       ASS:=TRUE;
                       SUCHEN(TRUE);
                     END;
                   IF (CH#' ') THEN ERROR(43);
                 END;
                ELSE ERROR(24)
               END;

             IF NOT COMM
              THEN
               BEGIN
                 GETSYM(TRUE,TRUE);
                 IF LAB AND ((SYM<>EQU) AND (PASS=1))
                  THEN
                   BEGIN
                     VAL:=ALCNT;
                     OK:=TRUE;
                     SUCHEN(FALSE)
                   END;

                 IF (SYM IN [CHARS..STRNG]) THEN ERROR(25);
                 IF (CH#' ') THEN ERROR(43);
                 INSTR:=SYM;
                 CASE INSTR OF
                   ORG,BSS          :ALCCHANGE;
                   ADDR,BYTES,WORDS :GETDAT;
                   MNEMS            :MACHOP;
                   EQU              :ASSIGNMENT;
                   NEWFILE          :SWITCHOVER;
                   SUBFILE          :SWITCHAWAY;
                   RETURN           :SWITCHBACK;
                   TEXTS            :PUSHSTRNG;
                   ENDS             :
                    BEGIN
                      PASSEND:=TRUE;
                      IF MRKR
                       THEN
                        BEGIN
                          SHPOSS:=FALSE;
                          ERROR(16)
                        END
                    END;
                   MARK             :MARKPR
                  END; { CASE }

                 IF INSTR IN [LIST..ENDS] THEN STATSTORE^.DONE:=FALSE;
                 IF (INSTR IN [NEWFILE..ENDS])
                  AND (NOT(SHORT OR MRKBLK OR MRKR))
                    THEN PUTLIST(LNO)
               END
           END
          ELSE
           BEGIN
             READLN(LINE); {FALLS IM 2. PASS NICHTS ZU UEBERSETZEN}

                IF LINE[1]=FF THEN
                 BEGIN
                   LINE[1]:=' ';
                   LINE[2]:='N'; LINE[3]:='E'; LINE[4]:='W';
                   LINE[5]:='P'; LINE[6]:='A'; LINE[7]:='G';
                   LINE[8]:=' ';
                   LINE[9]:='<'; LINE[10]:='f'; LINE[11]:='f'; LINE[12]:='>';
                   CC:=12; 
                 END

            END;
2: { STATEMENT ABORT mit ERROR( ) }

         IF LABMRK AND (NOT(MRKR OR SHORT OR MRKBLK)) THEN PUTLIST(LNO);

3: { PUTLIST mit ERROR(53) }

         IF PASS=2
          THEN
           BEGIN
             IF (LISTNG AND LST) OR (NOT STATSTORE^.ERROR.OK) OR MRKMIN
              THEN
               BEGIN
                 PRINTOUT;
                 IF ((INSTR=NEWPAG) AND (LNCNT<>0)) THEN NEWPAGE
               END;

             CASE INSTR OF
               LIST   : LST:=TRUE;
               NOLIST : LST:=FALSE
              END

           END {Pass 2};

           IF MRKBLK {'MARK -' not yet found}
           THEN
             IF (LNO >= (LISTE2[CNTL2+1]-1))
               THEN ERROR(8) {write past MARK-Block, RETURN to here!}
               ELSE PUT(STATSTORE)
           ELSE PUT(STATSTORE);

       END
   END;


  PROCEDURE GETCMND;

  VAR
    LEN,K : INTEGER;
    TAKEOLDCMD : BOOLEAN;

    PROCEDURE GETSOURCE;
     BEGIN
       STATEMENT;
       IF SYM=IDENT THEN SRCFIL:=ID ELSE CMNDERR(0);

       WHILE CH = '/' DO
        BEGIN
          STATEMENT;
          IF SYM = IDENT
           THEN
           IF ID='C         '
            THEN CREF:=TRUE
            ELSE
            IF ID='S         '
             THEN SHORT:=TRUE
             ELSE CMNDERR(0)
           ELSE CMNDERR(0)
        END
     END;


    PROCEDURE GETLIST;
     BEGIN
       STATEMENT;
       IF SYM=IDENT THEN LISTFIL:=ID ELSE CMNDERR(0);
       IF CH='=' THEN GETSOURCE ELSE CMNDERR(0)
     END;

   BEGIN {GETCMND}
     LOAD:=TRUE;
     LISTNG:=TRUE;
     CMND:=TRUE;
     SHORT:=FALSE;
     FULLOAD:=FALSE;
     CREF:=FALSE;
     TAKEOLDCMD:=FALSE;

     RESET(OLDCMND,'R65COM','.ASM',LEN);
     IF LEN>0
      THEN
       BEGIN
         WRITE('Old command: ');
         LINE:=OLDCMND^; K:=1;
         WHILE LINE[K]#' ' DO
         BEGIN
           WRITE(LINE[K]); K:=K+1;
         END;
         WRITELN;
         WRITE('New command: ');
         NEWST:=TRUE;
         STATEMENT;
         IF (SYM=CHARS) AND (CH=' ')
          THEN
           BEGIN
             TAKEOLDCMD:=TRUE;
             LINE:=OLDCMND^;
             CC:=0;
             STATEMENT
           END
       END
      ELSE
       BEGIN { No OLD found }
         NEWST:=TRUE;
         WRITE('New command: ');
         STATEMENT
       END;

     CASE SYM OF
       CHARS:
       CASE CH OF
       ',':
         BEGIN
           LOAD:=FALSE; GETLIST
         END;
       '*':
         BEGIN
           LOAD:=TRUE; LISTNG:=TRUE; GETSOURCE;
           LOADFIL:=SRCFIL; LISTFIL:=SRCFIL;
         END;
        ELSE
        CMNDERR(0);
       END {CASE};
       IDENT:
        BEGIN
          LOADFIL:=ID;
          CASE CH OF
            ',':GETLIST;
            '=':
             BEGIN
               LISTNG:=FALSE; GETSOURCE
             END;
            ELSE
            CMNDERR(0)
           END
        END;
       ELSE
       CMNDERR(0)
      END;
     CMND:=FALSE;

     IF NOT TAKEOLDCMD
     THEN
     BEGIN
       REWRITE(OLDCMND,'R65COM.ASM/SIZE:1');
       OLDCMND^:=LINE;
       PUT(OLDCMND);
     END;

     CLOSE(OLDCMND)

   END;

   PROCEDURE DOPASS;
  VAR
    LEN:INTEGER;

   BEGIN
     FILNAM:=SRCFIL;
     RESET(INPUT,FILNAM,'.AIM',LEN);
     IF LEN<=0 THEN CMNDERR(1);

     CNTL1:=2;CNTL2:=2;
     MRKMIN:=FALSE;
     MRKR:=FALSE;
     MRKBLK:=FALSE;
     ASS:=FALSE;
     FATAL:=FALSE;
     LNO:=0;
     LNOR:=0;
     LEV:=1;
     PASSEND:=FALSE;

     REPEAT
       STATEMENT
     UNTIL PASSEND OR (LNO=NOL)

   END;


  PROCEDURE LOADOUT;

  VAR
    VAL,NOBTS,NOREC,ADDR,J,K       : UNSIGNED;
    HBT,LBT                        : BYTE;
    BTSTORE                        : ARRAY[1..24] OF BYTE;

    PROCEDURE CHECKSUM(VAR BT:BYTE);

    VAR
      K,NIB1,NIB2 :INTEGER;

     BEGIN
       NIB1:=ORD(BT[1])-ORD('0');
       IF NIB1 > 9 THEN NIB1:=NIB1-7; { HEX A..F }
       NIB2:=ORD(BT[2])-ORD('0');
       IF NIB2 > 9 THEN NIB2:=NIB2-7; { HEX A..F }
       VAL:=VAL + (16*NIB1) + NIB2;
     END;

    PROCEDURE RECOUT;

     BEGIN
       WRITE(LDAFIL,';');
       VAL:=0; {CHECKSUM}
       K:=NOBTS;
       GETBYTE(K,HBT);
       CHECKSUM(HBT);
       WRITE(LDAFIL,HBT);
       GETWORD(ADDR,HBT,LBT);
       CHECKSUM(HBT); CHECKSUM(LBT);
       WRITE(LDAFIL,HBT,LBT);
       FOR J:=1 TO NOBTS DO
        BEGIN
          CHECKSUM(BTSTORE[J]);
          WRITE(LDAFIL,BTSTORE[J]);
        END;
       GETWORD(VAL,HBT,LBT);
       WRITELN(LDAFIL,HBT,LBT);
       NOREC:=NOREC+1;
       ADDR:=STATSTORE^.ALC;
       NOBTS:=0
     END;


   BEGIN {LOADOUT}
     WRITELN('R65 Load-File');
     LDASIZ:=50;
     REWRITE(LDAFIL,LOADFIL,'.LOD',LDASIZ);
     IF LDASIZ <=0 THEN WRITELN('R65 Kein Platz fuer .LOD-File')
     ELSE
     BEGIN
     PAGE(LDAFIL);
     WRITE(LDAFIL,'AIM-File: ',SRCFIL:6,' R65 Crossassembler ',VersionNumber);
     IF SHORT OR MRKBLK THEN WRITE(LDAFIL,' Short') ELSE WRITE(LDAFIL,' Full ');
     WRITELN(LDAFIL,'  ',DAT);

     LNO:=0; VAL:=0; NOREC:=0; NOBTS:=0;

      REPEAT
       LNO:=LNO+1;
       SEEK(STATSTORE,LNO);
       IF NOT (STATSTORE^.DATA.LEN=0)
        THEN
         BEGIN
           IF (NOREC=0) AND (NOBTS=0)
            THEN
             BEGIN
               ADDR:=STATSTORE^.ALC;
               K:=ADDR
             END;
           IF (K<>STATSTORE^.ALC) OR (STATSTORE^.DATA.LEN>24-NOBTS)
            THEN
            RECOUT;
           FOR J:=1 TO STATSTORE^.DATA.LEN DO
            BEGIN
              NOBTS:=NOBTS+1;
              BTSTORE[NOBTS]:=STATSTORE^.DATA.DAT[J]
            END;
           K:=STATSTORE^.ALC+STATSTORE^.DATA.LEN
         END
      UNTIL LNO=NOL;

     IF (NOBTS#0) THEN RECOUT;

     WRITE(LDAFIL,';00'); { last record }
     NOREC:=NOREC+1;
     GETWORD(NOREC,HBT,LBT);
     CHECKSUM(HBT); CHECKSUM(LBT);
     WRITE(LDAFIL,HBT,LBT);
     GETWORD(VAL,HBT,LBT);
     WRITE(LDAFIL,HBT,LBT);
     WRITELN(LDAFIL); WRITELN(LDAFIL);
     CLOSE(LDAFIL);
    END;
   END;


 BEGIN { MAIN }

   WRITELN('R65 ',VersionNumber,' (',VersionDate,')');
   TAB:=CHR(11B); FF:=CHR(14B); DATE(DAT); ZEIT:=TIME;

   GETCMND; { CSI-like }
   WRITELN('R65 working ... !'); ZEIT:=TIME {nur Rechenzeit angeben};

   IF NOT SHORT THEN { "delete" all old Files }
   BEGIN
     REWRITE(DELETFILE,'STATST.ASM/SIZE:1'); CLOSE(DELETFILE);
     REWRITE(DELETFILE,'SYMTAB.ASM/SIZE:1'); CLOSE(DELETFILE);
     REWRITE(DELETFILE,'MRKLST.ASM/SIZE:1'); CLOSE(DELETFILE);
   END;

   IF LOAD THEN { "delete" old File }
   BEGIN
     REWRITE(DELETFILE,LOADFIL,'.LOD/SIZE:1'); CLOSE(DELETFILE);
   END;

   FILNAM:=SRCFIL;
   IF LISTNG OR CREF
    THEN
     BEGIN
       IF LISTNG
       THEN
       BEGIN
         REWRITE(DELETFILE,LISTFIL,'.LST/SIZE:1'); CLOSE(DELETFILE);
         LSTSIZ:=400; REWRITE(LSTFIL,LISTFIL,'.LST',LSTSIZ);
       END
       ELSE
       BEGIN { CREF ONLY }
         REWRITE(DELETFILE,SRCFIL,'.LST/SIZE:1'); CLOSE(DELETFILE);
         LSTSIZ:=80; REWRITE(LSTFIL,SRCFIL,'.LST',LSTSIZ);
       END;

       IF LSTSIZ < 0 THEN
       BEGIN
         WRITELN('R65 Kein Platz fuer das .LST-File');
         LISTNG:=FALSE; CREF:=FALSE;
       END;

     END
    ELSE
     BEGIN
       LNCNT:=0; { muss das hier stehen ? }
       REWRITE(LSTFIL,'TT:') { FUER FEHLERMELDUNGEN }
     END;

   IF NOT SHORT { full assembly }
    THEN
     BEGIN
       LISTE1[1]:=0; LISTE2[1]:=0;
       STASIZ:=300;
       REWRITE(STATSTORE,'STATST.ASM','/SEEK/BUFF:35.',STASIZ);
       IF STASIZ <=0 THEN
       BEGIN
         WRITELN('R65 Kein Platz fuer STATST.ASM'); GOTO 1 { exit };
       END;

       SYMSIZ:=104;
       REWRITE(SYMTAB,'SYMTAB.ASM','/SEEK/BUFF:1024.',SYMSIZ);
       IF SYMSIZ <=0 THEN
       BEGIN
         WRITELN('R65 Kein Platz fuer Symbol-Tabelle'); GOTO 1 { exit };
       END;

       FOR CHIN:='A' TO 'Z' DO
        BEGIN {init SYMTAB}
         SYMTAB^.LETTER:=CHIN; SYMTAB^.ANZ:=0; PUT(SYMTAB);
         SYMTAB^.LETTER:=CHIN; SYMTAB^.ANZ:=0; PUT(SYMTAB);
        END
     END

    ELSE

     BEGIN { short assembly }
       RESET(MRKLST,'MRKLST.ASM','/SEEK',LEN);
       IF (LEN<=0) THEN CMNDERR(5);
       IF EOF(MRKLST) THEN CMNDERR(2);
       LISTE1:=MRKLST^;
       SEEK(MRKLST,2);
       LISTE2:=MRKLST^;
       CLOSE(MRKLST);
       RESET(STATSTORE,'STATST.ASM','/SEEK/BUFF:35.',KZ);
       IF KZ<=0 THEN CMNDERR(4);
       SYMTABRST;
     END;

   RESET(INSTRFIL,'R65INS.ASM','/SEEK',KZ); { Befehls-Satz/Code einlesen }
   IF KZ<=0 THEN CMNDERR(6);
   FOR J:=1 TO NOINSTR DO
    BEGIN
      SEEK(INSTRFIL,J);
      INSTRTAB[J]:=INSTRFIL^
    END;
   CLOSE(INSTRFIL);
   MRK:=FALSE;
   SHPOSS:=TRUE;
   STBOUT:=FALSE;

   WRITELN('R65 Pass 1');
   PASS:=1;
   ALCNT:=0;
   NOL:=0;
   NOERR:=0;
   DOPASS;
   NOL:=LNO;

   WRITE('R65 Pass 2');
   NOPG:=0;
   LST:= NOT SHORT;
   IF NOT LISTNG THEN LNCNT:=0;
   IF LISTNG THEN WRITELN(', Listing') ELSE WRITELN;
   PASS:=2;
   ERRMES:=TRUE;
   RESET(ERRTAB,'R65ERR.ASM','/SEEK',KZ);
   IF KZ<=0 THEN
   BEGIN
     WRITELN('R65 File R65ERR.ASM fehlt'); ERRMES:=FALSE;
   END;
   DOPASS;

   IF NOT (SHORT OR MRKBLK)
    THEN
     BEGIN
       IF SHPOSS AND MRK
       THEN
        BEGIN
           MRKSIZ:=2;
           REWRITE(MRKLST,'MRKLST.ASM','/SEEK',MRKSIZ);
           IF MRKSIZ <=0 THEN
           BEGIN
             WRITELN('R65 Kein Platz fuer MRKLST.ASM');
             SHPOSS:=FALSE;
           END
           ELSE
           BEGIN
             MRKLST^:=LISTE1;
             PUT(MRKLST);
             MRKLST^:=LISTE2;
             PUT(MRKLST);
             CLOSE(MRKLST);
           END
        END
     END;


   IF LISTNG THEN
   BEGIN
     WRITELN(LSTFIL); WRITELN(LSTFIL,'errors detected:',NOERR:4);

     IF NOT SHORT AND MRK THEN
     BEGIN
       IF NOT SHPOSS THEN WRITE(LSTFIL,'no ');
       WRITELN(LSTFIL,'short assembly possible');
     END;
   END;

   WRITELN; WRITELN('R65 Errors detected:',NOERR:4);

   IF NOT SHORT AND MRK
    THEN
     BEGIN
       WRITE('R65 ');
       IF NOT SHPOSS THEN WRITE('no ');
       WRITELN('short assembly possible');
     END;

   WRITELN;

   IF CREF OR (NOERR <> 0) THEN SYMTABOUT;

   CLOSE(LSTFIL);

   IF LOAD AND (NOERR=0) THEN LOADOUT;

   CLOSE(STATSTORE);

   IF NOT (SHORT OR (MRK AND SHPOSS)) THEN { "delete" all old Files }
   BEGIN
     WRITELN('R65 Temporaer-Files loeschen');
     REWRITE(DELETFILE,'STATST.ASM/SIZE:1'); CLOSE(DELETFILE);
     REWRITE(DELETFILE,'SYMTAB.ASM/SIZE:1'); CLOSE(DELETFILE);
   END;

WRITELN;
WRITE('R65 AIM-File: ');
J:=1; WHILE SRCFIL[J]#' ' DO BEGIN WRITE(SRCFIL[J]); J:=J+1 END; WRITELN;

ZEIT:=(TIME-ZEIT) * 3600.;
MM:=TRUNC(ZEIT) DIV 60;
SS:=TRUNC(ZEIT) MOD 60;
WRITELN('R65 die Arbeit ist getan:',MM:6,' min',SS:3,' sec',CHR(7B));

1: { exit }
WRITELN;

 END.