External Cross::Block(2);{$L-}{$E-}{$C-}{$T-}
 PROCEDURE BLOCK;
 VAR
   DBL_DECF,
   (*ZEIGER AUF ERSTE UND LETZTE VARIABLE DIE ALS PROCEDURE*)
   DBL_DECL : ^DBL_DEC;    (*IN DIESEM BLOCK DOPPELT DEKLARIERT WURDEN*)
   CURPROC : LIST_PTR_TY;
   Exit_Set:Set Of Symbol;
   Exit:Boolean;
   (*ZEIGER AUF DIE PROZEDUR IN DEREN
    ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
   {%E}
   PROCEDURE RECDEF;
   VAR
     OLD_SPACES_MARK  : INTEGER;
     (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
     PROCEDURE CASEDEF;
     VAR
       OLD_SPACES_MARK  : INTEGER;
       (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
       PROCEDURE PARENTHESE;
       VAR
         OLD_SPACES_MARK : INTEGER;
         (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG
          VON KLAMMERN INNERHALB VON VARIANT PARTS*)
       BEGIN (*PARENTHESE*)
         OLD_SPACES_MARK := SPACES;
         IF OLDSPACES
           THEN SPACES := LASTSPACES
           ELSE LASTSPACES := SPACES;
         SPACES := SPACES + BUFFERPTR - 2;
         OLDSPACES := TRUE;
         REPEAT
           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
           CASE SYTY OF
             LBRACK :
                    PARENTHESE;
             CASESY :
                    CASEDEF;
             RECORDSY :
                    RECDEF;
             Else:{}
           END;
         UNTIL SYTY IN [RPARENT,EOBSY];
         SPACES := OLD_SPACES_MARK;
         OLDSPACES := TRUE;
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
       END (*PARENTHESE*) ;
       {%E}
     BEGIN (*CASEDEF*)
       DELSY ['('] := LBRACK;
       OLD_SPACES_MARK := SPACES;
       IF OLDSPACES
         THEN SPACES := LASTSPACES
         ELSE LASTSPACES := SPACES;
       SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG + 3;
       OLDSPACES := TRUE;
       REPEAT
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
         CASE SYTY OF
           LBRACK :
                  PARENTHESE;
           CASESY :
                  CASEDEF;
           RECORDSY:
                  RECDEF;
           Else: {}
         END;
       UNTIL SYTY IN [ENDSY,RPARENT,EOBSY];
       SPACES := OLD_SPACES_MARK;
       DELSY ['('] := LPARENT;
     END (*CASEDEF*) ;
   BEGIN (*RECDEF*)
     OLD_SPACES_MARK := SPACES;
     SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG - 2 + FEED;
     OLDSPACES := TRUE;
     INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
     WR_LINE ( BUFFERPTR-SYLENG);
     REPEAT
       CASE SYTY OF
         CASESY :
                CASEDEF;
         RECORDSY :
                RECDEF;
         Else:
                INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
       END;
     UNTIL SYTY IN [ENDSY,EOBSY];
     WR_LINE (BUFFERPTR-SYLENG);
     OLDSPACES := TRUE;
     LASTSPACES := SPACES - FEED;
     SPACES := OLD_SPACES_MARK;
     INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
   END (*RECDEF*) ;
   {%E}
   PROCEDURE ERROR (ERRNR : INTEGER);
   BEGIN (*ERROR*)
     ERRFLAG := TRUE;
     WR_LINE (BUFFERPTR);
     WRITE (CROSSLIST,' ':17,' **** ');
     CASE ERRNR OF
       1 :
              WRITELN (CROSSLIST,SY,' ? ? ? ',MESSAGE);
       2 :
   WRITELN (CROSSLIST,'Missing ''End'' OR ''Until'' Number ',EMARKNR : 4);
       3 :
              WRITELN (CROSSLIST,'Missing ''Then'' Number ',EMARKNR : 4);
       4 :
     WRITELN (CROSSLIST,'Missing ''Of'' To ''Case'' Number ',BMARKNR : 4);
       5 :
              WRITELN (CROSSLIST,' Only one ''Exit'' allowed');
       6 :
           WRITELN (CROSSLIST,'Missing ''Exit'' in ''Loop'' ',EMARKNR : 4)
     END;
   END (*ERROR*) ;
   {%E}
   PROCEDURE STATEMENT ;
   VAR
     CURBLOCKNR : INTEGER;     (*AKTUELLE BLOCKNUMMER*)
     PROCEDURE COMPSTAT;
Var Exit:Boolean;
     BEGIN (*COMPSTAT*)
       BMARKTEXT := 'B';
       OLDSPACES := TRUE;
       LASTSPACES := SPACES - BACKFEED;
       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
       WR_LINE (BUFFERPTR-SYLENG);
       REPEAT
Exit:=False;
         REPEAT
           STATEMENT ;
         UNTIL SYTY IN ENDSYM;
         IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
           THEN Exit:=True;
If Not Exit Then
Begin
         ERROR (1);
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
End;
       UNTIL Exit;
       WR_LINE (BUFFERPTR-SYLENG);
       EMARKTEXT := 'E';
       EMARKNR := CURBLOCKNR;
       LASTSPACES := SPACES-BACKFEED;
       OLDSPACES := TRUE;
       IF SYTY = ENDSY
         THEN
           BEGIN
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
             WR_LINE (BUFFERPTR-SYLENG);
           END
         ELSE ERROR (2);
     END (*COMPSTAT*) ;
     {%E}
     PROCEDURE CASESTAT;
     VAR
       OLD_SPACES_MARK : INTEGER;
       (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON CASE-STATEMENTS*)
Exit:Boolean;
Exit_Set,Exit_S2:Set Of Symbol;
     BEGIN (*CASESTAT*)
       BMARKTEXT := 'C';
       OLDSPACES := TRUE;
       LASTSPACES := SPACES-BACKFEED;
       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
       STATEMENT ;
       IF SYTY = OFSY
         THEN WR_LINE (BUFFERPTR)
         ELSE ERROR (3);
       REPEAT
Exit:=False;
         REPEAT
           REPEAT
             If SyTy<>Other_Wise
               Then
                 INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
Exit_Set:=(EndSym-[ElseSy]+[Colon,Other_Wise]);
           UNTIL SYTY IN Exit_Set;
           IF (SYTY = COLON)Or(SyTy=Other_Wise)
             THEN
               BEGIN
                 OLD_SPACES_MARK := SPACES;
                 LASTSPACES := SPACES;
                 SPACES := OLD_SPACES_MARK + CASEFEED;
                 OLDSPACES := TRUE;
                 INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
                 IF NOT ( SYTY IN BEGSYM )
                   THEN
                     BEGIN
                       WR_LINE ( BUFFERPTR - SYLENG );
                       SPACES := SPACES +1;
                     END;
                 STATEMENT ;
                 SPACES := OLD_SPACES_MARK;
               END;
Exit_S2:=EndSym-[ElseSy];
         UNTIL SYTY IN Exit_S2;
         IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
           THEN Exit:=True;
If Not Exit Then
         ERROR (1);
       UNTIL Exit;
       WR_LINE (BUFFERPTR-SYLENG);
       EMARKTEXT := 'E';
       EMARKNR := CURBLOCKNR;
       LASTSPACES := SPACES-BACKFEED;
       OLDSPACES := TRUE;
       IF SYTY = ENDSY
         THEN
           BEGIN
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
             WR_LINE (BUFFERPTR-SYLENG);
           END
         ELSE ERROR (2);
     END (*CASESTAT*) ;
     {%E
      PROCEDURE LOOPSTAT;
      VAR
      LOOPFLAG : BOOLEAN;     (*GESETZT BEIM AUFTRETEN VON EXIT-STATEMENTS
      BEGIN (*LOOPSTAT
      BMARKTEXT := 'L';
      OLDSPACES := TRUE;
      LASTSPACES := SPACES - BACKFEED;
      INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
      WR_LINE (BUFFERPTR-SYLENG);
      LOOPFLAG := FALSE;
      REPEAT
      REPEAT
      STATEMENT ;
      IF SYTY = EXITSY
      THEN
      BEGIN
      WR_LINE (BUFFERPTR-SYLENG);
      IF LOOPFLAG
      THEN ERROR (5);
      OLDSPACES := TRUE;
      LASTSPACES := SPACES-BACKFEED;
      LOOPFLAG := TRUE;
      EMARKTEXT := 'X';
      EMARKNR := CURBLOCKNR;
      INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC); INSYMBOL(Dbl_DecL,CurProc);
      END;
      UNTIL SYTY IN ENDSYM;
      IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
      THEN Exit:=True;
If Not Exit Then
Begin
      ERROR (1);
      INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
End;
      UNTIL Exit;
      WR_LINE (BUFFERPTR-SYLENG);
      EMARKTEXT := 'E';
      EMARKNR := CURBLOCKNR;
      LASTSPACES := SPACES-BACKFEED;
      OLDSPACES := TRUE;
      IF SYTY = ENDSY
      THEN
      BEGIN
      INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
      WR_LINE (BUFFERPTR-SYLENG);
      END
      ELSE ERROR (2);
      IF NOT LOOPFLAG
      THEN ERROR (6);
      END (*LOOPSTAT ;
      }
     {%E}
     PROCEDURE IFSTAT ;
     BEGIN (*IFSTAT*)
       BMARKTEXT := 'I';
       LASTSPACES := SPACES - BACKFEED;
       OLDSPACES := TRUE;
       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
       STATEMENT ;
       SPACES:=SPACES+FEED;
       IF SYTY = THENSY
         THEN
           BEGIN
             WR_LINE (BUFFERPTR-SYLENG);
             LASTSPACES := SPACES - BACKFEED;
             OLDSPACES := TRUE;
             EMARKTEXT := 'T';
             EMARKNR := CURBLOCKNR;
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
             STATEMENT ;
           END
         ELSE ERROR (4);
       IF SYTY = ELSESY
         THEN
           BEGIN
             OLDSPACES := TRUE;
             LASTSPACES := SPACES - BACKFEED;
             WR_LINE (BUFFERPTR-SYLENG);
             EMARKTEXT := 'S';
             EMARKNR := CURBLOCKNR;
             LASTSPACES := SPACES - BACKFEED;
             OLDSPACES := TRUE;
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
             STATEMENT ;
           END;
       SPACES:=SPACES-FEED;
     END (*IFSTAT*) ;
     {%E}
     PROCEDURE LABELSTAT;
     BEGIN (*LABELSTAT*)
       LASTSPACES := 0;
       OLDSPACES := TRUE;
       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
       WR_LINE (BUFFERPTR-SYLENG);
     END (*LABELSTAT*) ;
     PROCEDURE REPEATSTAT;
Var Exit:Boolean;
     BEGIN (*REPEATSTAT*)
       BMARKTEXT := 'R';
       OLDSPACES := TRUE;
       LASTSPACES := SPACES - BACKFEED;
       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
       WR_LINE (BUFFERPTR-SYLENG);
       REPEAT
Exit:=False;
         REPEAT
           STATEMENT ;
         UNTIL SYTY IN ENDSYM;
         IF SYTY IN [UNTILSY,EOBSY,PROC_SY,FUNCT_SY]
           THEN Exit:=True;
If Not Exit Then
Begin
         ERROR (1);
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
End;
       UNTIL EXIT;
       WR_LINE (BUFFERPTR-SYLENG);
       EMARKTEXT := 'U';
       EMARKNR := CURBLOCKNR;
       OLDSPACES := TRUE;
       LASTSPACES := SPACES-BACKFEED;
       IF SYTY = UNTILSY
         THEN
           BEGIN
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
             STATEMENT ;
           END
         ELSE ERROR (2);
     END (*REPEATSTAT*) ;
     {%E}
   BEGIN (*STATEMENT*)
     IF SYTY = INTCONST
       THEN
         BEGIN
           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
           IF SYTY = COLON
             THEN LABELSTAT;
         END;
     IF SYTY IN BEGSYM
       Then
         BEGIN
           BLOCKNR := BLOCKNR + 1;
           CURBLOCKNR := BLOCKNR;
           BMARKNR := CURBLOCKNR;
           WR_LINE (BUFFERPTR-SYLENG);
           SPACES := SPACES + FEED;
           CASE SYTY OF
             BEGINSY :
                    COMPSTAT;
                    {             LOOPSY  :
                     LOOPSTAT;         }
             CASESY  :
                    CASESTAT;
             IFSY    :
                    IFSTAT ;
             REPEATSY :
                    REPEATSTAT ;
             Else:{}
           END;
           SPACES := SPACES - FEED;
         END
ELSE
WHILE NOT(SYTY IN([SEMICOLON,Colon]+ENDSYM))DO
INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
     IF (SYTY = SEMICOLON)Or(SyTy=Colon)
       THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
       ELSE
         IF SYTY = DOSY
           THEN
             BEGIN
               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
               STATEMENT ;
             END;
   END (*STATEMENT*) ;
   {%E}
 BEGIN (*BLOCK*)
   DBL_DECF := NIL;
   LEVEL := LEVEL + 1;
   CURPROC := LISTPTR;
If Level=1 Then
Begin
 Insymbol(Dbl_DecF,Dbl_DecL,CurProc);
 No_Main:=SyTy=ExternSy;
 While SyTy<>Semicolon Do InSymbol(Dbl_DecF,Dbl_DecL,CurProc);
End;
   SPACES := LEVEL * FEED;
   REPEAT
     INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
   UNTIL (SYTY IN RELEVANTSYM);
   Repeat
     WHILE SYTY IN (DECSYM) DO
     BEGIN
       WR_LINE (BUFFERPTR-SYLENG);
       SPACES := SPACES - FEED;
       WR_LINE (BUFFERPTR);
       SPACES := SPACES + FEED;
       REPEAT
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
         IF SYTY = RECORDSY
           THEN RECDEF;
       UNTIL SYTY IN RELEVANTSYM;
     END;
     WHILE SYTY IN PROSYM DO
     BEGIN
       WR_LINE (BUFFERPTR-SYLENG);
       OLDSPACES := TRUE;
       IF SYTY <> INITPROCSY
         THEN
           BEGIN
             IF SYTY = PROC_SY
               THEN PROCDEC := 1
               ELSE PROCDEC := 2;
             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
           END;
       BLOCK;
       IF SYTY = SEMICOLON
         THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
     END;
Exit_Set:=ProSym+DecSym;
Exit:=Not (SyTy In Exit_Set);
   Until Exit;
   LEVEL := LEVEL - 1;

   SPACES := LEVEL * FEED;
   IF NOT ((SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,FORTRANSY,EobSy])
           Or((No_Main)And (SyTy=Point)))
     THEN
       BEGIN
         ERROR (1);
WHILE NOT
(SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,FORTRANSY,EOBSY])
DO INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
       END;
       {%E}
   IF SYTY = BEGINSY
     THEN STATEMENT
     ELSE
       BEGIN
         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
         IF SYTY = FORTRANSY
           THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
       END ;
   IF DBL_DECF <> NIL
     THEN
       REPEAT
         DBL_DECF^.PROCORT^.PROCVAR := 0;
         DBL_DECF := DBL_DECF^.NEXTPROC;
       UNTIL  DBL_DECF = NIL;
   IF (LEVEL = 0)And (Not No_Main)
     THEN
       BEGIN
         IF SYTY <> POINT
           THEN
             BEGIN
               WRITELN (OUTPUT,'Missing point at program end');
               WRITELN (OUTPUT);
  WRITELN (CROSSLIST,' ' : 17, ' **** Missing point at program end ****');
               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
             END;
         IF SYTY <> EOBSY
           THEN
             REPEAT
               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
             UNTIL SYTY = EOBSY;
       END;
 END (*BLOCK*) ;

You are viewing proxied material from gopher.floodgap.com. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.