(*13.6.1985                                    *) 
FUNCTION LEN(INDEX:INTEGER):INTEGER;              
(*LIEFERT DIE LAENGE EINES OBJEKTES (IN BYTES)  *)
(*DES INDIZIERTEN TYPS                          *)
BEGIN                                             
 CASE TABART[INDEX]OF                             
    STDTYP,AUFZHL,AUSSCH:                         
      BEGIN                                       
       IF INDEX=REALS THEN LEN:=5                 
                      ELSE LEN:=2                 
      END;                                        
    ELSE LEN:=TABA1[INDEX]                        
 END                                              
END;(*LEN*)                                       
                                                  
FUNCTION PARLENGTH(I:INTEGER):INTEGER;            
(*LIEFERT DIE LAENGE DES PARAMETERTEILS DES     *)
(*UNTERPROGRAMMS (IN BYTES)                     *)
 VAR J:INTEGER;                                   
BEGIN                                             
 J:=TABA2[I]+I;IF I=J THEN (*KEINE PARAMETER    *)
   PARLENGTH:=HEAD                                
 ELSE                                             
  IF TABA3[J]<0 THEN PARLENGTH:=TABA1[J]+2        
  ELSE PARLENGTH:=TABA1[J]+LEN(TABA3[J])          
END;(*PARLENGTH*)                                 
                                                  
FUNCTION ISLONG(I:INTEGER):BOOLEAN;               
(*TRUE, FALLS REAL ODER ZUSAMMENGESETZTER TYP   *)
BEGIN                                             
 CASE TABART[I] OF                                
  STDTYP,AUFZHL,AUSSCH:ISLONG:=I=REALS;           
  ELSE ISLONG:=TRUE                               
 END;(*CASE*)                                     
END;(*ISLONG*)                                    
                                                  
PROCEDURE FIXFRE;                                 
(*DER BLOCK BEGINNT NICHT HIER. (CODIERT SPRUNG)*)
BEGIN                                             
 IF FIXADR=0 THEN                                 
  BEGIN GEN(JMPSYM);FIXADR:=PC;FRE END            
END;(*FIXFRE*)                                    
                                                  
FUNCTION UNSCONST(COMP:BOOLEAN):INTEGER;          
(*LIEST KONSTANTE UND LIEFERT INDEX DES GRUND-  *)
(*TYPS. WERT BZW. ADRESSE IN NUM. STRINGLAENGE  *)
(*IN TABA1[STRNG].                              *)
(*FALLS COMP=TRUE,WIRD KONSTANTE MIT LADEBE-    *)
(*BEFEHLEN  AUF DEN STACK GEBRACHT.             *)
 VAR I,ADR,ADR1:INTEGER;                          
BEGIN                                             
 CASE SYM OF                                      
 INTNUM :BEGIN I:=INT;GETSYM END;                 
 REALNUM:BEGIN (*WERT IN FLOAT;NUM ENTHAELT ADR.*)
          IF COMP THEN                            
           BEGIN GEN(LRCSYM);COMP:=FALSE;         
            FOR I:=0 TO 4 DO GEN(PEEK(NUM+I));    
           END;                                   
          I:=REALS;GETSYM                         
         END;                                     
 34     :BEGIN (*ANFUEHRUNGSZEICHEN:            *)
          GETSYM;NUM:=SYM;I:=CHART;GETSYM;        
          IF SYM<>34 THEN (*STRING COMPILIEREN  *)
           BEGIN                                  
            IF COMP THEN                          
             BEGIN GEN(CSTSYM);ADR1:=PC;FRE END   
            ELSE FIXFRE;                          
            ADR:=PC;I:=STRNG;GENA(NUM);           
            REPEAT GENA(SYM);GETSYM UNTIL SYM=34; 
            TABA1[STRNG]:=ADDU(PC,-ADR);          
            IF COMP THEN                          
             BEGIN (*CST LIEFERT ADRESSE->STACK*) 
              FIXUP(ADR1,PC);COMP:=FALSE          
             END;                                 
            NUM:=ADR                              
           END;                                   
          GETSYM                                  
         END;                                     
 147(*NIL*):BEGIN I:=NILS;GETSYM;NUM:=0 END       
 ELSE(*CASE*)                                     
         BEGIN I:=GETID;                          
          IF TABART[I]<>KONST THEN                
           BEGIN ERROR(103);I:=INT;NUM:=0 END     
          ELSE                                    
           BEGIN                                  
            TABA1[STRNG]:=TABA3[I]; (*LAENGE    *)
            NUM:=TABA2[I];I:=TABA1[I];            
           END                                    
         END                                      
 END;(*CASE*)                                     
 IF COMP THEN                                     
  BEGIN                                           
   GENLDC(NUM);IF I=REALS THEN GEN(LRSYM+3)       
  END;                                            
 UNSCONST:=I                                      
END;(*UNSCONST*)                                  
                                                  
FUNCTION GETCONST:INTEGER;                        
(*LIEFERT DEN INDEX DES GRUNDTYPS. WERT IN NUM  *)
 VAR I,X:INTEGER;                                 
BEGIN                                             
 IF(SYM=PLUS)OR(SYM=MINUS)THEN                    
  BEGIN X:=SYM;GETSYM END                         
 ELSE X:=STERN;                                   
 I:=UNSCONST(FALSE);                              
 IF X<>STERN THEN                                 
  BEGIN                                           
   IF I=INT THEN                                  
    BEGIN IF X=MINUS THEN NUM:=-NUM END ELSE      
   IF I=REALS THEN                                
    BEGIN IF X=MINUS THEN FLOAT:=-FLOAT END       
   ELSE  ERROR(105);                              
  END;                                            
 GETCONST:=I                                      
END;(*GETCONST*)                                  
                                                  
PROCEDURE CHECKCONST(TYP,ERR:INTEGER);            
(*PRUEFT KONSTANTEN AUF TYP.(NICHT REAL/STRING) *)
 VAR I:INTEGER;                                   
BEGIN                                             
 I:=GETCONST;                                     
 IF TABART[TYP]=AUSSCH THEN                       
  BEGIN                                           
   IF(NUM<TABA3[TYP])OR(NUM>TABA3[TYP]+TABA1[TYP])
   THEN ERROR(ERR);                               
   TYP:=TABA2[TYP]                                
  END;                                            
 IF I<>TYP THEN ERROR(ERR)                        
END;(*CHECKCONST*)                                
                                                  
PROCEDURE LBLDECL;                                
(*LIEST DEKLARATION. FUER JEDES LABEL WIRD EIN  *)
(*SPRUNGBEFEHL ERZEUGT. AUSSERDEM WIRD MIT 'ALC'*)
(*DER STACKPOINTER KORREKT INITIALISIERT.       *)
 VAR X:INTEGER;                                   
BEGIN                                             
 FIXFRE;                                          
 REPEAT                                           
  IF SYM<>INTNUM THEN ERROR(106)                  
  ELSE                                            
   BEGIN GETSYM;                                  
    FOR X:=0 TO LBLIND-1 DO                       
     IF LBL[X].VAL=NUM THEN ERROR(166);           
    IF LBLIND>MXLBL THEN ERROR(401)               
    ELSE                                          
     BEGIN                                        
      WITH LBL[LBLIND] DO                         
       BEGIN                                      
        ADR:=PC;VAL:=NUM;LEV:=-LVL;(*UNDEFINIERT*)
       END;                                       
      GEN(ALCSYM);FRE;GEN(JMPSYM);FRE;            
      (*PLATZ FUER DX-2 UND SPRUNGZIEL FREI!    *)
      LBLIND:=LBLIND+1                            
     END                                          
   END;                                           
  X:=SYM;GETSYM                                   
 UNTIL X<>KOMMA;                                  
 IF X<>SEMI THEN ERROR(14)                        
END;(*LBLDECL*)                                   
                                                  
PROCEDURE CSTDECL;                                
 VAR I,ADR:INTEGER;NAME:TBEZ;                     
BEGIN                                             
 REPEAT                                           
  IF SYM<>IDENT THEN ERROR(2)                     
  ELSE                                            
   BEGIN NAME:=ID;                                
    GETSYM;TEST(GLEICH,16);I:=GETCONST;           
    IF I=NILS THEN                                
     BEGIN I:=INT;NUM:=0;ERROR(506) END;          
    IF I=REALS THEN                               
     BEGIN FIXFRE;ADR:=PC;                        
      FOR I:=0 TO 4 DO GEN(PEEK(NUM+I));          
      NUM:=ADR;I:=REALS;                          
     END;                                         
    (*STRINGLAENGE NUR FUER STRING RELEVANT     *)
    EINTRAG(NAME,KONST,I,NUM,TABA1[STRNG]);       
   END;                                           
  TEST(SEMI,14);                                  
 UNTIL SYM<>IDENT                                 
END;(*CSTDECL*)                                   
                                                  
FUNCTION TYP:INTEGER;                             
(*LIEFERT INDEX AUF TYPEINTRAG UND MACHT EVTL.  *)
(*SELBST NEUE EINTRAEGE IN DER BEZEICHNERTABELLE*)
(*DIE LOKALEN FUNKTIONEN LIEFERN TYP-ZEIGER     *)
 VAR ISPACKED:BOOLEAN;                            
                                                  
 FUNCTION PACKEDLENGTH(VAR I:INTEGER):INTEGER;    
 (*LIEFERT DIE LAENGE DES GEPACKTEN TYPS I.     *)
 (*FALLS GEPACKT WURDE, VORZEICHENWECHSEL VON I *)
 BEGIN                                            
  PACKEDLENGTH:=LEN(I);                           
  IF ISPACKED THEN                                
  CASE TABART[I] OF                               
   STDTYP,AUFZHL:                                 
    IF TABA1[I]<256 THEN                          
      BEGIN I:=-I;PACKEDLENGTH:=1 END;            
   AUSSCH:                                        
    BEGIN                                         
     IF(TABA3[I]>=0)AND(TABA1[I]+TABA3[I]<256)THEN
       BEGIN I:=-I;PACKEDLENGTH:=1 END            
    END                                           
   ELSE(*CASE LEER*)                              
  END(*CASE*)                                     
 END;(*PACKEDLENGTH*)                             
                                                  
 FUNCTION SIMPLETYPE:INTEGER;                     
  VAR I,J:INTEGER;                                
                                                  
  FUNCTION AUSTYP:INTEGER;                        
   VAR X:INTEGER;                                 
  BEGIN                                           
   I:=GETCONST;X:=NUM;TEST(174,1);J:=GETCONST;    
   IF ISLONG(J) THEN                              
     BEGIN ERROR(50);I:=INT;NUM:=0 END;           
   IF I<>J THEN BEGIN ERROR(107);J:=I END;        
   IF X>NUM THEN BEGIN ERROR(102);NUM:=X END;     
   AUSTYP:=TX;EINTRAG(DUMMY,AUSSCH,NUM-X,I,X);    
  END;(*AUSTYP*)                                  
                                                  
 BEGIN(*SIMPLETYPE*)                              
  CASE SYM OF                                     
  KLAUF:BEGIN J:=TX;I:=0;                         
       REPEAT GETSYM;                             
        IF SYM<>IDENT THEN ERROR(2)               
        ELSE                                      
         BEGIN EINTRAG(ID,KONST,0,I,0);I:=I+1 END;
        GETSYM                                    
       UNTIL SYM<>KOMMA;                          
       TEST(KLZU,4);EINTRAG(DUMMY,AUFZHL,I-1,0,0);
       (*VERWEISE AUF GRUNDTYP NACHTRAGEN       *)
       FOR I:=J TO TX-2 DO TABA1[I]:=TX-1;I:=TX-1 
      END;                                        
  IDENT:                                          
      BEGIN I:=POSITION(ID);                      
       IF(TABART[I]=KONST)AND(I>=0)THEN I:=AUSTYP 
       ELSE                                       
        BEGIN                                     
         IF I<0 THEN BEGIN ERROR(104);I:=INT END; 
         IF NOT INTEST(I,STDTYP,SAMET) THEN       
          BEGIN ERROR(103);I:=INT END;            
         IF TABART[I]=SAMET THEN I:=TABA1[I];     
         GETSYM;                                  
        END                                       
      END                                         
  ELSE(*CASE*)I:=AUSTYP                           
  END;(*CASE*)                                    
  SIMPLETYPE:=I                                   
 END;(*SIMPLETYPE*)                               
                                                  
 FUNCTION FELD:INTEGER;                           
 (*LIEST <SKALARTYP>,<SKTYP>...] OF.. UND       *)
 (*LIEFERT TYP-ZEIGER AUF GESAMTES FELD         *)
  VAR I,J,X:INTEGER;                              
 BEGIN                                            
  I:=SIMPLETYPE;                                  
  IF ISLONG(I)OR(I=INT)THEN ERROR(113);           
  IF SYM=KOMMA THEN                               
   BEGIN GETSYM;J:=FELD END                       
  ELSE                                            
   BEGIN                                          
    TEST(EKLZU,12);TEST(149(*OF*),8);J:=TYP       
   END;                                           
  FELD:=TX;X:=PACKEDLENGTH(J)*(TABA1[I]+1);       
  EINTRAG(DUMMY,FELDTYP,X,I,J)                    
 END;(*FELD*)                                     
                                                  
 FUNCTION RECRD:INTEGER;                          
 (*LIEFERT INDEX AUF RECORDEINTRAG, DER DEN KOPF*)
 (*DER SELEKTORLISTE BILDET (AENDERT TX)        *)
   VAR INDEX,LAENGE,LASTLINK:INTEGER;             
                                                  
  PROCEDURE FIELDLIST;                            
  (*REKURSIVE AUFRUFE UEBER VARIABEL!           *)
   VAR I,J,K:INTEGER;B1:BOOLEAN;                  
                                                  
   PROCEDURE DEFINIERE;                           
   (*DEFINIERE SELEKTOR I MIT TYP K (GLOBAL!)   *)
   (*ERWEITERE SELEKTOR-LISTE (LASTLINK/INDEX)  *)
   BEGIN                                          
    TABA1[I]:=LAENGE;TABA2[I]:=-1;                
    LAENGE:=LAENGE+PACKEDLENGTH(K);               
    TABA3[I]:=K;K:=ABS(K);                        
    IF LASTLINK<>-1 THEN TABA2[LASTLINK]:=I       
                    ELSE INDEX:=I;                
    LASTLINK:=I                                   
   END;(*DEFINIERE*)                              
                                                  
   PROCEDURE FEST;                                
   BEGIN                                          
    IF SYM=IDENT THEN                             
     BEGIN                                        
      I:=TX;ID[0]:=-ID[0];                        
      EINTRAG(ID,SELECT,0,0,0);GETSYM;            
      WHILE SYM=KOMMA DO                          
       BEGIN GETSYM;                              
        IF SYM<>IDENT THEN ERROR(2)               
        ELSE                                      
         BEGIN                                    
          ID[0]:=-ID[0];                          
          EINTRAG(ID,SELECT,0,0,0);GETSYM         
         END                                      
       END;                                       
      TEST(DPKT,5);J:=TX;K:=TYP;                  
      (*TYPEN NACHTRAGEN VON I BIS J-1*)          
      WHILE I<J DO                                
       BEGIN DEFINIERE;I:=I+1 END;                
     END                                          
   END;(*FEST*)                                   
                                                  
   PROCEDURE VARIABEL;                            
    VAR LENALT,MAX:INTEGER;COND:BOOLEAN;          
   BEGIN                                          
    IF SYM<>IDENT THEN ERROR(2);                  
    I:=POSITION(ID);                              
    IF I<0 THEN (*TAGFIELD*)                      
     BEGIN ID[0]:=-ID[0];                         
      EINTRAG(ID,SELECT,0,0,0);GETSYM;            
      TEST(DPKT,5)                                
     END;                                         
    K:=GETID;(*TAGFIELD TYPE*)                    
    IF ISLONG(K)THEN BEGIN ERROR(110);K:=INT END; 
    IF I<0 THEN (*TYP NACHTRAGEN*)                
      BEGIN I:=TX-1;DEFINIERE END;                
    TEST(149,8);(*OF*)                            
    LENALT:=LAENGE;MAX:=LAENGE;COND:=TRUE;        
    WHILE(SYM<>KLZU)AND(SYM<>137) (*END*) DO      
     BEGIN                                        
      IF NOT(COND)THEN ERROR(14);(*";" FEHLTE*)   
      IF SYM<>SEMI THEN                           
       BEGIN                                      
        REPEAT                                    
         CHECKCONST(K,111);                       
         COND:=SYM=KOMMA;IF COND THEN GETSYM;     
        UNTIL NOT COND;                           
        TEST(DPKT,5);TEST(KLAUF,9);FIELDLIST;     
        IF LAENGE>MAX THEN MAX:=LAENGE;           
        LAENGE:=LENALT;TEST(KLZU,4)               
       END;                                       
      COND:=SYM=SEMI;IF COND THEN GETSYM;         
     END;                                         
    LAENGE:=MAX;                                  
   END;(*VARIABEL*)                               
                                                  
  BEGIN (*FIELDLIST*)                             
   B1:=SYM<>131;(*CASE*)                          
   WHILE B1 DO                                    
    BEGIN FEST;B1:=SYM=SEMI;IF B1 THEN GETSYM;    
    END;                                          
   IF SYM=131 (*CASE*) THEN                       
    BEGIN GETSYM;VARIABEL END;                    
  END;(*FIELDLIST*)                               
                                                  
 BEGIN (*RECRD*)                                  
  GETSYM;INDEX:=-1;LASTLINK:=-1;LAENGE:=0;        
  FIELDLIST;TEST(137,13);(*END*)                  
  RECRD:=TX;EINTRAG(DUMMY,VERBTYP,LAENGE,INDEX,0) 
 END;(*RECRD*)                                    
                                                  
 FUNCTION POINT:INTEGER;                          
 (*ZEIGERTYP EVTL. MIT VORAUS-VEREINBARUNG      *)
  VAR I:INTEGER;                                  
 BEGIN                                            
  GETSYM;IF SYM<>IDENT THEN ERROR(2);             
  I:=POSITION(ID);                                
  IF I<0 THEN                                     
   (*VORAUS-VEREINBARUNG: ERWEITERE LISTE:      *)
   BEGIN ID[0]:=-ID[0];                           
    I:=TX;EINTRAG(ID,NUL,FWDTYP,0,0);FWDTYP:=I    
   END                                            
  ELSE                                            
   IF NOT INTEST(I,STDTYP,SAMET)THEN              
    BEGIN ERROR(103);I:=INT END;                  
  POINT:=TX;EINTRAG(DUMMY,ZEIGTYP,2,I,0);GETSYM   
 END;(*POINT*)                                    
                                                  
 FUNCTION SEQ:INTEGER;                            
  VAR I:INTEGER;                                  
 BEGIN                                            
  GETSYM;TEST(149,8);I:=TYP;SEQ:=TX;              
  EINTRAG(DUMMY,SEQTYP,6+LEN(I),I,0)              
 END;(*SEQ*)                                      
                                                  
 FUNCTION SETS:INTEGER;                           
  VAR I:INTEGER;                                  
 BEGIN                                            
  GETSYM;TEST(149,8);I:=SIMPLETYPE;SETS:=TX;      
  IF ISLONG(I) THEN BEGIN ERROR(109);I:=INT END;  
  IF(TABART[I]=AUSSCH)AND((TABA3[I]<0)OR          
    (TABA3[I]+TABA1[I]>95))THEN ERROR(501);       
  EINTRAG(DUMMY,MENGE,12,I,0)                     
 END;(*SETS*)                                     
                                                  
BEGIN (*TYP*)                                     
 ISPACKED:=SYM=151;IF ISPACKED THEN GETSYM;       
 CASE SYM OF                                      
  129(*ARRAY*):BEGIN                              
                GETSYM;TEST(EKLAUF,11);TYP:=FELD  
               END;                               
  154(*RECRD*):TYP:=RECRD;                        
  PFEIL       :TYP:=POINT;                        
  138(*FILE *):TYP:=SEQ;                          
  156(*SET  *):TYP:=SETS                          
  ELSE TYP:=SIMPLETYPE                            
 END(*CASE*)                                      
END;(*TYP*)                                       
                                                  
PROCEDURE TYPDECL;                                
 VAR I,J,P,Q:INTEGER;NAME:TBEZ;                   
BEGIN(*TYPDECL*)                                  
 REPEAT                                           
  IF SYM<>IDENT THEN ERROR(2)                     
  ELSE                                            
   BEGIN NAME:=ID;                                
    GETSYM;TEST(GLEICH,16);I:=TYP;                
    (*DURCHSUCHE LISTE DER FWD.TYPDECLARATIONEN:*)
    NAME[0]:=-NAME[0];                            
    P:=FWDTYP;WHILE P<>-1 DO                      
     BEGIN                                        
      IF TABBEZ[P]=NAME THEN                      
       BEGIN                                      
        TABA2[P+1]:=I;(*VERVOLLSTAENDIGE FWDDCL.*)
        IF P=FWDTYP THEN FWDTYP  :=TABA1[P]       
                    ELSE TABA1[Q]:=TABA1[P];      
       END;                                       
      Q:=P;P:=TABA1[P]                            
     END;                                         
    NAME[0]:=-NAME[0];                            
    IF(TABBEZ[I,0]=STERN)AND(TX-1=I) THEN         
     BEGIN TX:=TX-1;                              
      EINTRAG(NAME,TABART[I],TABA1[I],TABA2[I],   
            TABA3[I])                             
     END                                          
    ELSE EINTRAG(NAME,SAMET,I,0,0);               
   END;                                           
  TEST(SEMI,14)                                   
 UNTIL SYM<>IDENT;                                
END;(*TYPDECL*)                                   
                                                  
PROCEDURE PARDCL(ISPARM,ISREF:BOOLEAN);           
(*LIEST PARAMETERGRUPPE.                        *)
(*ISREF =TRUE => CALL BY REFERENCE              *)
(*ISPARM=TRUE => TYPBEZEICHNER MUSS FOLGEN      *)
 VAR I,J,K:INTEGER;ABSFLG:BOOLEAN;                
BEGIN I:=TX;                                      
 REPEAT (*SPEICHERE PROVISORISCH ALLE BEZEICHNER*)
  IF SYM<>IDENT THEN ERROR(2)                     
  ELSE BEGIN EINTRAG(ID,VARBLE,0,0,0);GETSYM END; 
  J:=SYM;GETSYM;                                  
 UNTIL J<>KOMMA;                                  
 IF J<>DPKT THEN ERROR(5);                        
 J:=TX;                                           
 IF ISPARM THEN                                   
  BEGIN K:=GETID;                                 
   IF NOT INTEST(K,STDTYP,SAMET) THEN             
    BEGIN ERROR(103);K:=INT END;                  
   IF TABART[K]=SAMET THEN K:=TABA1[K];           
  END                                             
 ELSE                                             
  BEGIN K:=TYP;IF FWDTYP<>-1 THEN ERROR(118) END; 
 IF ISPARM AND NOT ISREF AND (TABART[K]=SEQTYP)   
  THEN ERROR(121);                                
 IF SYM=EKLAUF THEN (*ABSOLUTE ADRESSIERUNG     *)
  BEGIN GETSYM;                                   
   IF GETCONST<>INT THEN ERROR(511);              
   TEST(EKLZU,12);ABSFLG:=TRUE;                   
   IF ISPARM THEN                                 
    BEGIN ERROR(512);ABSFLG:=FALSE END;           
  END                                             
 ELSE ABSFLG:=FALSE;                              
 (*TRAGE TYPEN IN BEZEICHNERTABELLE NACH        *)
 WHILE I<J DO                                     
  BEGIN                                           
   IF ABSFLG THEN                                 
    BEGIN TABA1[I]:=NUM;TABA2[I]:=0;TABA3[I]:=K   
   END ELSE                                       
    BEGIN TABA1[I]:=DX;TABA2[I]:=LVL;             
     IF ISREF                                     
      THEN BEGIN TABA3[I]:=-K;DX:=DX+2      END   
      ELSE BEGIN TABA3[I]:= K;DX:=DX+LEN(K) END;  
    END;                                          
   I:=I+1                                         
  END;                                            
END;(*PARDCL*)                                    
                                                  
PROCEDURE VARDECL;                                
(*VEREINBARE LOKALE VARIABLEN:                  *)
BEGIN                                             
 REPEAT PARDCL(FALSE,FALSE);                      
  TEST(SEMI,14)                                   
 UNTIL SYM<>IDENT;                                
END;(*VARDECL*)