(*==============================================*)
(* 16.10.1986                                   *)
(* 30.6.1989  U1: HEAP = 53, COMPILINGPARAMETER *)
(* INCLUDE-FILE "P.BLOCK.P"                     *)
(*==============================================*)
                                                  
FUNCTION FPARM: INTEGER;                          
(* LIEST DEN FORMALEN PARAMETERTEIL UND LIEFERT *)
(* DIE ANZAHL DER PARAMETER ALS ERGEBNIS. ALLE  *)
(* PARAMETER WERDEN LUECKENLOS AB TX ABGELEGT.  *)
(* DX WIRD MIT STACKLEN(...) HOCHGEZAEHLT.      *)
  VAR OLDTX,I:INTEGER;                            
 BEGIN                                            
  OLDTX:=TX;                                      
  IF SYM=KLAUF THEN                               
   BEGIN GETSYM;                                  
    REPEAT                                        
     IF SYM=161 (* VAR *) THEN                    
       BEGIN GETSYM; PARDCL(TRUE,TRUE) END        
     ELSE                                         
       PARDCL(TRUE,FALSE);                        
     I:=SYM; GETSYM                               
    UNTIL I<>SEMI;                                
    IF I<>KLZU THEN ERROR(4);                     
   END;                                           
  FPARM:= TX-OLDTX                                
 END; (* FPARM *)                                 
                                                  
 PROCEDURE MOVE (UPROIND:INTEGER);                
 (* FALLS ZUSAMMENGESETZTE VALUE-PARAMETER, MOV *)
 (* SEQUENZ AM PROZEDURANFANG KOMPILIEREN.      *)
 (* FALLS 'LANGES FUNKTIONSERGEBNIS', ADRESSE   *)
 (* VORBELEGEN. FALLS 1-BYTE ERGEBNIS, H-BYTE   *)
 (* MIT 0 VORBELEGEN.                           *)
  VAR I,TYP:INTEGER;                              
      V    :VARDESCRIPTOR;                        
 BEGIN                                            
  FOR I:=UPROIND+1 TO UPROIND+TABA2[UPROIND] DO   
   BEGIN                                          
    TYP:=TABA3[I];                                
    IF TYP>=0 THEN                                
     IF (TABART[TYP]=FELDTYP) OR                  
        (TABART[TYP]=VERBTYP) THEN                
      BEGIN                                       
       V.ACCESS:=BASEOFFSET; V.OFFSET:=TABA1[I];  
       V.LEVEL:=TABA2[I];                         
       GENF(V); GENLS(LSYM,V);                    
       GEN(MOVSYM); GENA(MEMLEN(TYP))             
      END                                         
   END; (* FOR *)                                 
  IF TABART[UPROIND]=FKT THEN                     
   BEGIN                                          
    I:= UPROIND+TABA2[UPROIND]+1;                 
    V.ACCESS:=BASEOFFSET;                         
    V.OFFSET:=TABA1[I]; V.LEVEL:=TABA2[I];        
    CASE TABART[ABS(TABA3[I])] OF                 
     STDTYP,AUFZHL,AUSSCH:                        
       IF MEMLEN(TABA3[I])=1 THEN                 
         BEGIN GENLDC(0); GENLS(SSYM,V) END;      
     FELDTYP,STRTYP,VERBTYP,SEQTYP:               
       BEGIN                                      
         GENF(V); V.OFFSET:=0; GENLS(SSYM,V);     
       END;                                       
     ELSE (* LEER *)                              
    END; (* CASE *)                               
   END;                                           
 END; (* MOVE *)                                  
                                                  
 PROCEDURE CHANGE(BLK:INTEGER);                   
 (* STEUERT ZUGRIFF AUF DIE PARAMETER DES UNTER-*)
 (* PROGRAMMES MIT DEM INDEX 'BLK'.(IDEMPOTENT) *)
  VAR K:INTEGER;                                  
 BEGIN                                            
  FOR K:=1 TO TABA2[BLK] DO                       
   TABBEZ[BLK+K,0]:=CHR(-ORD(TABBEZ[BLK+K,0]));   
 END; (* CHANGE *)                                
                                                  
 PROCEDURE READERGTYP;                            
 (* BEI FUNKTIONEN ERGEBNISVARIABLE EINFUEHREN. *)
 (* DX BEI LANGEN PARAMETERN HOCHZAEHLEN        *)
   VAR TYP,OFFSET: INTEGER;                       
 BEGIN                                            
  TEST(DPKT,5); TYP:=GETID;                       
  IF TABART[TYP]=SAMET THEN TYP:=TABA1[TYP];      
  CASE TABART[TYP] OF                             
   STDTYP,AUFZHL,AUSSCH,ZEIGTYP,MENGE:            
     (* WERT UNTERHALB DESKRIPTOR. BEI 1-BYTE   *)
     (* WERTEN WIRD H-BYTE BEI MOV NULLGESETZT  *)
     OFFSET:= 2 - STACKLEN(TYP);                  
   FELDTYP,STRTYP,VERBTYP,SEQTYP:                 
     (* ABS. ADRESSE UNTERHALB DESKRIPTOR. WERT *)
     (* HINTER PARAMETERN. ADRESSE WIRD BEI     *)
     (* MOVE VORBELEGT.                         *)
     BEGIN                                        
       OFFSET:=DX; DX:= DX + MEMLEN(TYP);         
     END;                                         
   ELSE                                           
     BEGIN ERROR(120); OFFSET:=0; TYP:=INT END    
  END; (* CASE *)                                 
  EINTRAG(DUMMY, VARBLE, OFFSET, LVL, TYP)        
 END; (* READERGTYP *)                            
                                                  
 PROCEDURE GETPARAM(VAR VALUE: INTEGER;           
                      DEFAULT: INTEGER);          
 (* HOLE COMPILERPARAMETER IM PROGRAMMKOPF      *)
  VAR TYP:INTEGER;                                
 BEGIN                                            
  VALUE:=DEFAULT;                                 
  IF SYM=SEMI THEN                                
   BEGIN GETSYM;                                  
    IF SYM<>SEMI THEN                             
     BEGIN TYP:=GETCONST;                         
      IF TYP<>INT THEN ERROR(142)                 
      ELSE VALUE:=NUM                             
     END                                          
   END;                                           
 END; (* GETPARAM *)                              
                                                  
 PROCEDURE COMPILENAME;                           
 (* FALLS OPTION 'CHAIN', BLOCKNAMEN RUECKWAERTS*)
 (* KOMPILIEREN, SONST NUR '?'                  *)
 (* CHECKSUMME PRUEFEN                          *)
  VAR I: INTEGER;                                 
 BEGIN                                            
  IF CHAIN THEN                                   
   BEGIN I:=ALEN;                                 
    WHILE BLOCKNAME[I]=" " DO I:=I-1;             
    GEN(ORD(BLOCKNAME[I])+128);                   
    WHILE I>0 DO                                  
     BEGIN I:=I-1;GEN(ORD(BLOCKNAME[I])) END;     
   END                                            
  ELSE GEN(ORD("?")+128);                         
  IF CHECKSUM<>13259 THEN GOTO 9;                 
 END; (* COMPILENAME *)                           
                                                  
 BEGIN (* BLOCK *)                                
  LAST2:=LAST; GETSYM;                            
  IF SYM<>IDENT THEN ERROR(2);                    
  BLOCKNAME:=ID; BLK:=POSITION(ID);               
  IF BLKTYP=NUL THEN           (* HAUPTPROGRAMM *)
   BEGIN                                          
    GETSYM; IF SYM<>KLAUF THEN ERROR(505);        
    GRAFPROGRAM:=FALSE;                           
    REPEAT                                        
     GETSYM; K:=GETID;                            
     IF K=GRAFIK THEN GRAFPROGRAM:=TRUE ELSE      
     IF (K<>INFILE) AND (K<>OUTFILE)              
      THEN ERROR(503);                            
    UNTIL SYM<>KOMMA;                             
    GETPARAM(STARTPC       ,7391);                
    GETPARAM(ORGKC         ,8192);                
    GETPARAM(OFFSET        ,0   );                
    GETPARAM(TABA1[INFILE ],1024);                
    GETPARAM(TABA1[OUTFILE],1032);                
    GETPARAM(TABA1[15]     ,1040); (* FUER BANK *)
    GETPARAM(HEAPPTR       ,53  ); (* U1: HEAP  *)
    IF GRAFPROGRAM THEN                           
     BEGIN STARTPC:=STARTPC+GRAFOFFSET;           
      OFFSET:=-GRAFOFFSET                         
     END;                                         
    TEST(KLZU,4);                                 
    (* JETZT ALLE ANFANGSWERTE KOMPLETT         *)
    PC:=STARTPC;                                  
    KC:=ORGKC; KBUFFERROOT:=NIL;                  
    KBUFFERZ:=KBUFFERSIZE+1;                      
    FRE; FRE; (* ANFANG / ENDE DER KONSTANTEN   *)
    GENA(ORGKC);        (* ZIEL FUER KONSTANTEN *)
    FRE;                (* ADRESSE CODEANFANG = *)
                        (* DUMMY RETURN ADDRESS *)
    GEN(ORD(GRAFPROGRAM)); (* FLAG FUER GRAFIK  *)
    COMPILENAME;                                  
    STACKPC:=PC; FIXUP(STARTPC+6,STACKPC);        
    FRE;                (* STACKANFANG          *)
    DX:=HEAD+2; LAST:=TX; ISFWD:=TRUE             
   END                                            
  ELSE                                            
   BEGIN              (* FUNKTION ODER PROZEDUR *)
    ISFWD:= BLK>=LAST;                            
    IF ISFWD THEN                                 
     ISFWD:= (TABART[BLK]=BLKTYP) AND             
             (TABA3[BLK]<0);                      
    IF ISFWD THEN                                 
     (* VERVOLLSTAENDIGE DEKLARATION MIT RUMPF *) 
     BEGIN FWD:=FWD-1;                            
      FIXUP(ADDU(TABA1[BLK],3),PC);               
      TABA3[BLK]:= -TABA3[BLK];                   
      IF TABA3[BLK]<>LVL-1 THEN ERROR(510);       
      (* ANFANGSWERT FUER OFFSET REKONSTRUIEREN *)
      DX:= HEAD+2+LENPARAM(BLK)+LENFCTRES2(BLK);  
      LAST:=TX; CHANGE(BLK); GETSYM               
     END                                          
    ELSE              (* PROZEDURKOPF AUSWERTEN *)
     BEGIN                                        
      COMPILENAME; DX:=HEAD+2; BLK:=TX;           
      EINTRAG(ID,BLKTYP,PC,0,LVL-1); GETSYM;      
      LAST:=TX; K:=FPARM; TABA2[BLK]:=K;          
      IF BLKTYP=FKT THEN READERGTYP;    (* DX ^ *)
      (* DIFFERENZ (<T - <B) BEI AUSFUEHRUNG:   *)
      IF K=0 THEN                                 
        GENA(-LENFCTRES1(BLK))                    
      ELSE                                        
        GENA(HEAD+LENPARAM(BLK))                  
     END                                          
   END;                                           
                                                  
  TEST(SEMI,14);                                  
  TX2:=TX; FIXADR:=0; LBLI2:=LBLIND; FWDTYP:=-1;  
  IF SYM=140 (* FORWARD *) THEN                   
   BEGIN                                          
    IF ISFWD THEN ERROR(161);                     
    TABA3[BLK]:=-TABA3[BLK];(* LVL<0 => FORWARD *)
    FWD:=FWD+1; GEN(JMPSYM); FRE; CHANGE(BLK);    
    GETSYM; TEST(SEMI,14);                        
   END                                            
  ELSE                                            
   BEGIN                    (* RUMPF VORHANDEN: *)
    BLOCKSTART:=FALSE;                            
    REPEAT                                        
     CASE SYM OF                                  
      145: (* LABEL *)                            
        BEGIN GETSYM; LBLDECL END;                
      132: (* CONST *)                            
        BEGIN GETSYM; CSTDECL END;                
      159: (* TYPE  *)                            
        BEGIN                                     
         GETSYM; TYPDECL;                         
         IF FWDTYP<>-1 THEN                       
          BEGIN ERROR(117); FWDTYP:=-1 END;       
        END;                                      
      161: (* VAR *)                              
        BEGIN GETSYM; VARDECL END;                
      152: (* PROCDURE *)                         
        BEGIN                                     
         FIXFRE; BLOCK(PROZ, LVL+1, LBLIND);      
        END;                                      
      141: (* FUNCTION *)                         
        BEGIN                                     
         FIXFRE; BLOCK(FKT,  LVL+1, LBLIND);      
        END;                                      
      130: (* BEGIN *)                            
        BLOCKSTART:=TRUE;                         
      139,142,143,155,162,163:                    
        (* FOR, GOTO, IF, REPEAT, WHILE, WITH   *)
        (* (STATEMENT-START-SYMBOLE)            *)
        BEGIN                                     
         BLOCKSTART:=TRUE; ERROR(17);             
        END                                       
      ELSE (* CASE *)                             
        BEGIN ERROR(56); GETSYM END               
     END; (* CASE *)                              
    UNTIL BLOCKSTART;                             
    IF FIXADR<>0 THEN FIXUP(FIXADR,PC);           
    (* ALLOCIERE PLATZ FUER LOKALE VARIABLEN    *)
    (* UND 'LANGES' FUNKTIONSERGEBNIS. FALLS    *)
    (* KEINE PARAMETER, AUCH FUER HEAD UND      *)
    (* EINFACHES FUNKTIONSERGEBNIS              *)
    IF BLKTYP = NUL THEN                          
      K:= DX - HEAD - 2                           
    ELSE                                          
      IF TABA2[BLK]=0 THEN                        
        K:= LENFCTRES1(BLK) - 2 + DX              
      ELSE                                        
        K:= DX - LENPARAM(BLK) - HEAD - 2;        
    IF K<>0 THEN                                  
      BEGIN GEN(ALCSYM); GENA(K) END;             
    IF BLKTYP<>NUL THEN MOVE(BLK);                
                                                  
    GETKEY(CH); IF ORD(CH)=3 THEN ERROR(-1);      
    STATEMENT;                                    
                                                  
    WHILE LBLIND>LBLI2 DO                         
     BEGIN                                        
      LBLIND:= LBLIND-1;                          
      IF LBL[LBLIND].LEV<0 THEN ERROR(168)        
     END;                                         
    IF BLKTYP = NUL THEN       (* HAUPTPROGRAMM *)
     BEGIN                                        
      GEN(HLTSYM); IF SYM<>PUNKT THEN ERROR(20)   
     END                                          
    ELSE                                          
     BEGIN                                        
      TEST(SEMI,14); GEN(RPRSYM); CHANGE(BLK)     
     END;                                         
   END; (* RUMPF VORHANDEN *)                     
  LAST:=LAST2;                                    
  TX:=TX2;      (* BEHALTE PARAMETER UND ERGTYP *)
 END;(* BLOCK *)                                  
                                                  
 PROCEDURE LOAD(S: STRING);                       
  VAR I:INTEGER;                                  
 BEGIN                                            
  WITH REGS DO                                    
   BEGIN BANK:=15;                                
    AKKU:=0; X:=1;          (* NACH BANK 0 *)     
    SYS(-152,REGS);         (* SETBNK *)          
    AKKU:=LENGTH(S);                              
    I:= ADDU(ADR(S),1); X:=I; Y:=HBYTE(I);        
    SYS( -67,REGS);         (* SETNAM *)          
    AKKU:=0; X:=8; Y:=1;                          
    SYS( -70,REGS);         (* SETLFS *)          
    AKKU:=0; SYS(-43,REGS); (* LOAD   *)          
   END;                                           
 END; (* LOAD *)                                  
                                                  
 PROCEDURE MAKEVORBEL(VAR T: TBEZ);               
 (* DUMMY-ARGUMENT FUER DEN ASSEMBLER-CODE *)     
 (* AUSSERDEM PRUEFSUMME UEBER DEN TEXT    *)     
 (* BERECHNEN.                             *)     
   VAR S,P: INTEGER;                              
 BEGIN                                            
  BANK:=1; SYS(UVORBEL);                          
  P:=-2752; S:=0;                                 
  FOR I:= 1 TO PEEK(P) DO                         
   BEGIN S:=S+PEEK(P); P:=P+1 END;                
  CHECKSUM:=S;                                    
 END; (* MAKEVORBEL *)                            
                                                  
BEGIN (* MAIN PROGRAM *)                          
 WRITE(#147);                                     
 BANK:=0; POKE(TEMPFLG,0);                        
 HBYTEOVERFLOW:= PEEK(ORGSRC+1);                  
 IF PEEK(FIRSTFLAG)=0 THEN                        
  BEGIN                                           
   WRITE(COPYRIGHT); POKE(FIRSTFLAG,1);           
  END;                                            
 WRITE("PASCAL 2.1 (R0.1)"     #13                
       "-----------------"     #13 #13            
       "SELECT OPTION:"        #13                
       "0    CHECK SYNTAX"     #13                
       "1    GENERATE CODE"    #13                
       "ELSE LOCATE ADDRESS"   #13 #13            
       "==>1?");                                  
 READLN(ERRORPC);                                 
 CASE ERRORPC OF                                  
  0:   GENFLG:=SYNTAX;                            
  1:   GENFLG:=MEMORY;                            
  ELSE GENFLG:=DETECT                             
 END; (* CASE *)                                  
 WRITE(#13 "LISTING TO PRINTER?" #13 "==>N?");    
 READLN(CH); PRTFLG:= CH<>"N";                    
                                                  
 OPEN(INCLUDE,3,0);(* LOG. FILENUMMER 2 BELEGEN *)
 IF PRTFLG THEN OPEN(LIST,4,0)        (* FILE 3 *)
           ELSE OPEN(LIST,3,0);                   
 TX:=0; LAST:=0; FEHLER:=0; FWD:=0; TSTFLG:=FALSE;
 PARTEST:=FALSE; WITHIND:=0; (* KEIN WITH AKTIV *)
 FOR I:=0 TO ALEN DO EMPTY.LONG[I]:=" ";          
 DUMMY:= EMPTY.LONG; DUMMY[0]:="*";               
 COMPILINGPARAMETER:=FALSE;                       
                                                  
 OPCODE[0 ]:=PLUS    ;OPCODE[1 ]:=MINUS;          
 OPCODE[2 ]:=STERN   ;OPCODE[3 ]:=133;            
 OPCODE[4 ]:=146     ;OPCODE[5 ]:=128;            
 OPCODE[6 ]:=150     ;OPCODE[7 ]:=255;            
 OPCODE[8 ]:=GLEICH  ;OPCODE[9 ]:=172;            
 OPCODE[10]:=KLEINER ;OPCODE[11]:=173;            
 OPCODE[12]:=GROESSER;OPCODE[13]:=171;            
 EINTRAG(DUMMY,KONST  ,BOOL ,0    ,0);            
 EINTRAG(DUMMY,KONST  ,BOOL ,1    ,0);            
 EINTRAG(DUMMY,STDTYP ,1    ,BOOL ,0);            
 EINTRAG(DUMMY,KONST  ,INT  ,32767,0);            
 EINTRAG(DUMMY,STDTYP ,32767,INT  ,0);            
 EINTRAG(DUMMY,STDTYP ,255  ,CHART,0);            
 EINTRAG(DUMMY,STDTYP ,32767,REALS,0);            
 EINTRAG(DUMMY,ZEIGTYP,2    ,-1   ,0);            
 EINTRAG(DUMMY,STRTYP ,0    ,0    ,0);            
 EINTRAG(DUMMY,MENGE  ,SETBYTES,0 ,0);            
 EINTRAG(DUMMY,SEQTYP ,8    ,CHART,0);            
 EINTRAG(DUMMY,STRTYP ,81   ,0    ,0);            
 EINTRAG(DUMMY,VARBLE ,0    ,0    ,TXTF);         
 EINTRAG(DUMMY,VARBLE ,0    ,0    ,TXTF);         
 (* TABA1 WIRD MIT IBUF/OBUF-ADRESSE BELEGT!    *)
 EINTRAG(DUMMY,AUSSCH ,255  ,INT  ,0);            
 EINTRAG(DUMMY,VARBLE ,0    ,0    ,14);           
 (* TABA1 WIRD MIT BANK-ADRESSE BELEGT!         *)
 FOR I:=16 TO 34 DO EINTRAG(DUMMY,PROZ,0,0,0);    
 FOR I:=35 TO 68 DO EINTRAG(DUMMY,FKT ,0,0,0);    
 FOR I:=69 TO 85 DO EINTRAG(DUMMY,PROZ,0,0,0);    
 FOR I:=86 TO 92 DO EINTRAG(DUMMY,FKT ,0,0,0);    
 LAST:=TX;     (* HINTER GLOBALEN DEKLARATIONEN *)
 MAKEVORBEL(TABBEZ[0]);                           
                                                  
 BANK:=1; SYS(UINIT);                             
 IF SYM<>153 (* PROGRAM *) THEN ERROR(3);         
                                                  
 BLOCK(NUL,1,0);                                  
                                                  
 IF FWD<>0 THEN ERROR(119);                       
 WRITELN(LIST,"ERRORS DETECTED:",FEHLER);         
 IF GENFLG<>SYNTAX THEN                           
  BEGIN           (* ANFANG/ENDE DER KONSTANTEN *)
   FIXUP(STARTPC,ADDU(PC,OFFSET));                
   WHILE KBUFFERROOT<>NIL DO                      
    BEGIN                                         
     IF KBUFFERROOT=KBUFFER THEN LAST:=KBUFFERZ-1 
     ELSE LAST:=KBUFFERSIZE;                      
     FOR I:=0 TO LAST DO                          
      GEN(ORD(KBUFFERROOT^.B[I]));                
     KBUFFERROOT:=KBUFFERROOT^.NEXT               
    END;                                          
   FIXUP(STARTPC+2,ADDU(PC,OFFSET));              
                                                  
   FIXUP(STACKPC,KC);    (* = ANFANG DES STACKS *)
   I:= ADDU(PC,OFFSET); BANK :=0;                 
   POKE(ENDOBJ,I); POKE(ADDU(ENDOBJ,1),HBYTE(I)); 
   WRITELN(LIST,                                  
       "P-CODE FROM"   :16,STARTPC:6,"TO":3,PC:6, 
   #13,"CONSTANTS FROM":16,ORGKC  :6,"TO":3,KC:6);
                                                  
   IF GENFLG=ONFILE THEN                          
    BEGIN           (* HBYTE(PC)>=HBYTEOVERFLOW *)
     BANK:=15;                                    
     IF HBYTE(PC)>=HBYTE(PHYSTOP) THEN            
      BEGIN                                       
       WRITELN("EDITOR OVERWRITTEN");            
       POKE(TEMPFLG,255)                          
      END                                         
     ELSE                                         
      BEGIN                                       
       WRITELN("SOURCE OVERWRITTEN");            
       POKE(TEMPFLG,1)                            
      END;                                        
     CLOSE(FFILE); CLOSE(CFILE);                  
     LOAD("0:C$,P,R");                            
     OPEN(FFILE,8,FSEK,"0:F$,P,R");               
     BANK:=0;                                     
     WHILE NOT EOF(FFILE) DO                      
      BEGIN                                       
       GET(FFILE);                                
       POKE(FFILE^.V,FFILE^.N);                   
       POKE(ADDU(FFILE^.V,1),HBYTE(FFILE^.N));    
      END;                                        
    END; (* GENFLG=ONFILE *)                      
  END; (* GENFLG<>SYNTAX *)                       
                                                  
 8:WRITELN(#13 "(HIT RETURN FOR MENU)");          
   READLN(CH);                                    
 9: (* ABORT LABEL *)                             
 CLOSE(INCLUDE); CLOSE(LIST); CLOSE(COMMAND);     
END.