(*==============================================*)
(* 9.8.1986                                     *)
(* 28.6.1989  U1: TYPECHECK SETS                *)
(* INCLUDE-FILE "P.VARS.P"                      *)
(*==============================================*)
                                                  
PROCEDURE EXPAND (VAR TYP:INTEGER);               
(* AUSSCHNITT-TYP AN GRUNDTYP ANPASSEN          *)
BEGIN                                             
 IF TABART[TYP]=AUSSCH THEN TYP:=TABA2[TYP]       
END;(* EXPAND *)                                  
                                                  
PROCEDURE MAKESTRING(VAR TYP: INTEGER);           
(* VERSUCHE DEN WERT AUF DEM STACK MIT DIESEM   *)
(* TYP IN EINEN STRING UMZUWANDELN. TYP BE-     *)
(* SCHREIBT BEI RUECKKEHR DEN ERZEUGTEN STRING. *)
BEGIN                                             
 IF TABART[TYP]<>STRTYP THEN                      
  BEGIN                                           
   IF (TABART[TYP]=FELDTYP) AND                   
      (TABA3 [TYP]=CHART) THEN                    
    BEGIN                      (* ARRAY OF CHAR *)
     GEN(LDARSTRSYM); GEN(TABA1[TYP]);            
     TYP:= STRNG; TABA1[STRNG]:=TABA1[TYP]+1;     
     TABA2[STRNG]:=1                              
    END ELSE                                      
   IF TYP=CHART THEN                    (* CHAR *)
    BEGIN GEN(LDCHSTRSYM);                        
     TYP:=STRNG; TABA1[STRNG]:=2; TABA2[STRNG]:=1 
    END                                           
   ELSE ERROR(112);                               
  END; (* ELSE BEREITS OK *)                      
END; (* MAKESTRING *)                             
                                                  
PROCEDURE TYPTEST (VAR TYP1:INTEGER;              
                   TYP2,ERR:INTEGER);             
(* TYPANPASSUNG TYP1 AN TYP 2, EVTL. ERROR(ERR) *)
(* IN DEN FOLGENDEN FAELLEN MUSS OBJEKT MIT     *)
(* TYP1 AUF DEM STACK LIEGEN:                   *)
(* - LAUFZEITTEST BEI ZUWEISUNG AN AUSSCHNITTYP *)
(* - EXPANDIEREN INTEGER --> REAL               *)
(* - EXPANDIEREN (ARRAY OF) CHAR --> STRING     *)
 VAR RANGE: INTEGER;                              
BEGIN   (* ZUNAECHST AUSSCHNITTYPEN ELIMINIEREN *)
 IF TABART[TYP2]=AUSSCH THEN                      
  BEGIN                                           
   IF TYP1=TABA2[TYP2] THEN                       
     BEGIN                                        
      IF TSTFLG THEN (* LAUFZEITTEST COMPILIEREN*)
       BEGIN GEN(TSTSYM); GENA(TABA3[TYP2]);      
        GENA(TABA3[TYP2]+TABA1[TYP2])             
       END;                                       
      TYP2:= TYP1                                 
     END;            (* ELSE ERROR WEITER UNTEN *)
  END                                             
 ELSE                                             
  EXPAND(TYP1);                                   
                                                  
 IF TYP2=REALS THEN                               
  IF TYP1=INT THEN                                
   BEGIN GEN(FLTSYM); TYP1:=REALS END;            
                                                  
 IF TYP1<>TYP2 THEN  (* SONDERFAELLE BEHANDELN: *)
  CASE TABART[TYP2] OF                            
   ZEIGTYP:BEGIN (* AUSNAHME: T1 IST NIL        *)
            IF(TABART[TYP1]<>ZEIGTYP) OR          
              ((TABA2[TYP1]<>TABA2[TYP2]) AND     
               (TABA2[TYP1]>=0)) THEN ERROR(ERR); 
           END;                                   
   MENGE:  BEGIN                                  
            IF TABART[TYP1]<>MENGE THEN ERROR(ERR)
            ELSE                                  
             BEGIN                                
              TYP2:=TABA2[TYP2]; EXPAND(TYP2);    
 (* >> U1: *) RANGE:=TABA2[TYP1];                 
              IF RANGE>=0 THEN                    
               BEGIN                              
                EXPAND(RANGE);                    
                IF RANGE<>TYP2 THEN ERROR(ERR);   
               END;                               
 (* << U1> *) (* ELSE: AUSNAHME: LEERE MENGE    *)
             END                                  
           END;                                   
   FELDTYP:BEGIN (*AUSNAHME:T2 IST ARRAY OF CHAR*)
            IF TABA3[TYP2]<>CHART THEN ERROR(ERR) 
            ELSE    (* UND T1 IST ARRAY OF CHAR *)
             IF (TABART[TYP1]<>FELDTYP) OR        
                (TABA3 [TYP1]<>CHART) OR          
                (TABA1 [TYP2]<>TABA1[TYP1]) THEN  
              BEGIN                               
               (* ODER TYP1 IST STRINGKONSTANTE *)
               (* (RICHTIGE LAENGE IM SPEICHER) *)
               IF (TYP1=STRNG) AND                
                  (TABA1[STRNG]-1=TABA1[TYP2]) AND
                  (TABA2[STRNG]=0) THEN           
                BEGIN   (* ZIEL, QUELLE+1 MOV]  *)
                 GENLDC(1); GEN(ADUSYM);          
                 TYP1:=TYP2; (* MERKE AENDERUNG *)
                END                               
               ELSE ERROR(ERR);                   
              END                                 
            (* ELSE OK,WEIL [ZIEL,QUELLE MOV]   *)
           END;(* FELDTYP *)                      
   STRTYP :BEGIN                                  
            MAKESTRING(TYP1);                     
            (* PRUEFE AUF UEBERSCHREITUNG DER   *)
            (* MAXIMALLAENGE VON STRING2.       *)
            (* FALLS TYP1 STRINGKONSTANTE/CHAR  *)
            (* ODER ARRAY OF CHAR               *)
            IF (TYP1=STRNG) AND                   
               (TABA1[STRNG]>TABA1[TYP2])         
               (* ALSO INSB. >0 *)                
              THEN ERROR(108);                    
           END; (* STRTYP *)                      
   ELSE (* CASE *) ERROR(ERR)                     
  END (* CASE *)                                  
END; (* TYPTEST *)                                
                                                  
PROCEDURE GENLS (OPC  :INTEGER;                   
                 VAR V:VARDESCRIPTOR);            
(* LADE- ODER SPEICHERBEFEHL KOMPILIEREN. OPC   *)
(* DEFINIERT OPERATION UND TYP (INT, BYTE, REAL)*)
BEGIN                                             
 CASE V.ACCESS OF                                 
  BASEOFFSET:BEGIN                                
              IF LVL=V.LEVEL THEN                 
               BEGIN                              
                GEN(OPC+2); GENA(V.OFFSET)        
               END                                
              ELSE                                
               BEGIN GEN(OPC);                    
                GENA(V.OFFSET); GEN(LVL-V.LEVEL)  
               END                                
             END;                                 
  ABSOLUTE  :GEN(OPC+3);                          
  BASESTACK :BEGIN                                
              GEN(OPC+1); GEN(LVL-V.LEVEL)        
             END                                  
 END; (* CASE *)                                  
END; (* GENLS *)                                  
                                                  
PROCEDURE GENF (VAR V:VARDESCRIPTOR);             
(* LADE DIE ADRESSE EINER VARIABLEN             *)
BEGIN                                             
 CASE V.ACCESS OF                                 
  BASEOFFSET:BEGIN                                
              IF LVL=V.LEVEL THEN                 
               BEGIN                              
                GEN(FSYM+2); GENA(V.OFFSET)       
               END                                
              ELSE                                
               BEGIN GEN(FSYM);                   
                GENA(V.OFFSET); GEN(LVL-V.LEVEL)  
               END                                
             END;                                 
  BASESTACK :BEGIN                                
              GEN(FSYM+1); GEN(LVL-V.LEVEL)       
             END                                  
  ELSE (* CASE,LEER *)                            
 END; (* CASE *)                                  
END; (* GENF *)                                   
                                                  
PROCEDURE VARIABLE(    I:INTEGER;                 
                   VAR V:VARDESCRIPTOR);          
(* AUFRUF: I ZEIGT AUF VARIABLEN- ODER SELEKTOR-*)
(*         EINTRAG; SYM=IDENT.                  *)
(* BEI RUECKKEHR:                               *)
(* V ENTHAELT INFORMATIONEN FUER GENLS/GENF     *)
(* VARIABLE BENUTZT DEN STACK BEI MEHRSTUFIGEN  *)
(* UND KOMPLIZIERTEN ADRESSIERUNGSARTEN.        *)
 VAR W: INTEGER;                                  
     R: REAL;                                     
                                                  
BEGIN                                             
 WITH V DO BEGIN                                  
 IF (I>=0) AND (TABART[I]=VARBLE) THEN            
  BEGIN                                           
   OFFSET:=TABA1[I]; LEVEL:=TABA2[I];             
   VTYP:=TABA3[I]; ACCESS:=BASEOFFSET;            
   IF LEVEL=0 THEN          (* ABSOLUTE ADRESSE *)
    BEGIN GENLDC(OFFSET);                         
     OFFSET:=0; ACCESS:=ABSOLUTE                  
    END;                                          
   IF VTYP<0 THEN         (* CALL BY REFERENCE: *)
    BEGIN                                         
     GENLS(LSYM,V); OFFSET:=0;                    
     VTYP:=-VTYP; ACCESS:=ABSOLUTE                
    END                                           
  END                                             
 ELSE                  (* VIELLEICHT SELEKTOR ? *)
  IF TABART[I]=SELECT THEN                        
   BEGIN    (* ABSOLUTE  RECORDADRESSE => STACK *)
    ACCESS:=BASEOFFSET; LEVEL:=LVL;               
    OFFSET:=WITHADR; GENLS(LSYM,V);               
    ACCESS:=ABSOLUTE; OFFSET:=TABA1[I];           
    VTYP  :=TABA3[I];                             
   END                                            
  ELSE                                            
   BEGIN (* UNDEFINIERTER BEZEICHNER => DEFAULT *)
    ERROR(59); VTYP:=INT; LEVEL:=LVL;             
    OFFSET:=0; ACCESS:=BASEOFFSET                 
   END;                                           
 GETSYM;       (*RECORD V ENTHAELT BESCHREIBUNG *)
                                                  
 WHILE (SYM=EKLAUF) OR (SYM=PUNKT) OR (SYM=PFEIL) 
  DO                                              
  CASE SYM OF                                     
  EKLAUF:(* ARRAY/STRING *)                       
   BEGIN GETSYM;                                  
    REPEAT                                        
     IF TABART[VTYP]=FELDTYP THEN                 
      BEGIN                                       
       W:=TABA2[VTYP]; VTYP:=TABA3[VTYP];         
       I:=EXPRESSION; TYPTEST(I,W,139);           
      END ELSE                                    
     IF TABART[VTYP]=STRTYP THEN                  
      BEGIN                                       
       W:=INT; I:=EXPRESSION; TYPTEST(I,W,139);   
       IF TSTFLG THEN                             
        BEGIN                                     
         GEN(TSTSYM); GENA(0); GENA(TABA1[VTYP]-1)
        END;                                      
       VTYP:= CHART                               
      END                                         
     ELSE ERROR(138);                             
     (* W: INDEXTYP, VTYP: ELEMENTTYP           *)
     I:=MEMLEN(VTYP);                             
     IF TABART[W] = AUSSCH THEN                   
      BEGIN (*UG SUBTRAHIEREN / OFFSET ANPASSEN *)
       R:=TABA3[W];                               
       IF ABS(R*I)>=4096 THEN                     
        BEGIN              (* VERMEIDE OVERFLOW *)
         GENLDC(TABA3[W]); GENOP(MINUS)           
        END                                       
       ELSE OFFSET:=ADDU(OFFSET,-I*TABA3[W])      
      END;                                        
     IF I<>1 THEN                                 
      BEGIN GENLDC(I);GENOP(STERN) END;           
     IF ACCESS=BASEOFFSET THEN ACCESS:=BASESTACK  
     ELSE GEN(ADUSYM);                            
     I:=SYM; GETSYM;                              
    UNTIL I<>KOMMA;                               
    IF I<>EKLZU THEN ERROR(12);                   
   END;                                           
  PUNKT:                                          
   BEGIN GETSYM;                                  
    IF TABART[VTYP]<>VERBTYP THEN ERROR(140)      
    ELSE                                          
     BEGIN                                        
      IF SYM<>IDENT THEN ERROR(2);                
      I:=SELSEARCH(VTYP);GETSYM;                  
      IF I>=0 THEN                                
       BEGIN                                      
        OFFSET:=OFFSET+TABA1[I];                  
        VTYP:=TABA3[I];                           
       END                                        
      ELSE ERROR(152)                             
     END                                          
   END;                                           
  PFEIL:                                          
   BEGIN GETSYM;                                  
    IF TABART[VTYP]=ZEIGTYP THEN                  
     BEGIN    (* HOLE ADRESSE DES DYN. OBJEKTES *)
      IF (ACCESS<>BASEOFFSET) AND (OFFSET<>0) THEN
       BEGIN                                      
        GENLDC(OFFSET); GEN(ADUSYM); OFFSET:=0    
       END;                                       
      GENLS(LSYM,V); ACCESS:=ABSOLUTE;            
      OFFSET:=0; VTYP:=TABA2[VTYP]                
     END ELSE                                     
    IF TABART[VTYP]=SEQTYP THEN                   
     BEGIN   (* FILE-BUFFER ADRESSE UEBERGEBEN: *)
      OFFSET:=OFFSET+6;VTYP:=TABA2[VTYP]          
     END                                          
    ELSE ERROR(141)                               
   END                                            
  END; (* CASE & WHILE *)                         
                                                  
 IF (ACCESS<>BASEOFFSET) AND (OFFSET<>0) THEN     
  BEGIN        (* GESAMTE ADRESSE AUF DEN STACK *)
   GENLDC(OFFSET);GEN(ADUSYM);     (* OFFSET:=0 *)
  END;                                            
 END; (* WITH *)                                  
END; (* VARIABLE *)                               
                                                  
PROCEDURE ZUW1 (I:INTEGER);                       
(* BEREITE ZUWEISUNG VOR: VARIABLE I AUSWERTEN. *)
(* BEI ZUSAMMENGESETZTEN OBJEKTEN (FELDTYP,     *)
(* STRTYP, VERBTYP) WIRD DIE VOLLSTAENDIGE (!)  *)
(* ADRESSE AUF DEM STACK ABGELEGT.              *)
BEGIN                                             
 VARIABLE (I, ZU);                                
 IF(TABART[ZU.VTYP] IN [FELDTYP..SEQTYP])         
                      (* SEQTYP FUER READ/WRITE *)
   THEN GENF(ZU);                                 
END; (* ZUW1 *)                                   
                                                  
PROCEDURE ZUW2 (ERGTYP:INTEGER);                  
(* ZUWEISUNGSBEFEHLE CODIEREN, UM WERT VON ERG- *)
(* TYP AN 'ZU' (BELEGT MIT ZUW1) ZUZUWEISEN.    *)
(* BEI ARRAY, STRING, RECORD ZIELADRESSE SCHON  *)
(* DURCH ZUW1 AUF DEM STACK                     *)
BEGIN                                             
 TYPTEST (ERGTYP, ZU.VTYP, 144);                  
 CASE TABART [ZU.VTYP] OF                         
  FELDTYP,VERBTYP:                                
    BEGIN GEN(MOVSYM); GENA(MEMLEN(ZU.VTYP)) END; 
  STRTYP: BEGIN                                   
           GEN(STRMOVSYM); GEN(TABA1[ZU.VTYP]-1)  
           (* MAX. LAENGE NUR FUER LAUFZEITTEST *)
          END;                                    
  SEQTYP: ERROR(146);                             
  MENGE : GEN(SSASYM)                             
  ELSE                                            
   CASE MEMLEN(ZU.VTYP) OF                        
    2: GENLS(SSYM, ZU); (* ADR. / INTEGER  *)     
    5: GENLS(SRSYM,ZU); (* REAL            *)     
    1: GENLS(SBSYM,ZU); (* BOOLEAN/CHAR... *)     
   END (* CASE *)                                 
 END (* CASE *)                                   
END; (* ZUW2 *)