home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol097 / block.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  13.6 KB  |  484 lines
  1.  External Cross::Block(2);{$L-}{$E-}{$C-}{$T-}
  2.   PROCEDURE BLOCK;
  3.   VAR
  4.     DBL_DECF,
  5.     (*ZEIGER AUF ERSTE UND LETZTE VARIABLE DIE ALS PROCEDURE*)
  6.     DBL_DECL : ^DBL_DEC;    (*IN DIESEM BLOCK DOPPELT DEKLARIERT WURDEN*)
  7.     CURPROC : LIST_PTR_TY;
  8.     Exit_Set:Set Of Symbol;
  9.     Exit:Boolean;
  10.     (*ZEIGER AUF DIE PROZEDUR IN DEREN
  11.      ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
  12.     {%E}
  13.     PROCEDURE RECDEF;
  14.     VAR
  15.       OLD_SPACES_MARK  : INTEGER;
  16.       (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
  17.       PROCEDURE CASEDEF;
  18.       VAR
  19.         OLD_SPACES_MARK  : INTEGER;
  20.         (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
  21.         PROCEDURE PARENTHESE;
  22.         VAR
  23.           OLD_SPACES_MARK : INTEGER;
  24.           (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG
  25.            VON KLAMMERN INNERHALB VON VARIANT PARTS*)
  26.         BEGIN (*PARENTHESE*)
  27.           OLD_SPACES_MARK := SPACES;
  28.           IF OLDSPACES
  29.             THEN SPACES := LASTSPACES
  30.             ELSE LASTSPACES := SPACES;
  31.           SPACES := SPACES + BUFFERPTR - 2;
  32.           OLDSPACES := TRUE;
  33.           REPEAT
  34.             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  35.             CASE SYTY OF
  36.               LBRACK :
  37.                      PARENTHESE;
  38.               CASESY :
  39.                      CASEDEF;
  40.               RECORDSY :
  41.                      RECDEF;
  42.               Else:{}
  43.             END;
  44.           UNTIL SYTY IN [RPARENT,EOBSY];
  45.           SPACES := OLD_SPACES_MARK;
  46.           OLDSPACES := TRUE;
  47.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  48.         END (*PARENTHESE*) ;
  49.         {%E}
  50.       BEGIN (*CASEDEF*)
  51.         DELSY ['('] := LBRACK;
  52.         OLD_SPACES_MARK := SPACES;
  53.         IF OLDSPACES
  54.           THEN SPACES := LASTSPACES
  55.           ELSE LASTSPACES := SPACES;
  56.         SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG + 3;
  57.         OLDSPACES := TRUE;
  58.         REPEAT
  59.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  60.           CASE SYTY OF
  61.             LBRACK :
  62.                    PARENTHESE;
  63.             CASESY :
  64.                    CASEDEF;
  65.             RECORDSY:
  66.                    RECDEF;
  67.             Else: {}
  68.           END;
  69.         UNTIL SYTY IN [ENDSY,RPARENT,EOBSY];
  70.         SPACES := OLD_SPACES_MARK;
  71.         DELSY ['('] := LPARENT;
  72.       END (*CASEDEF*) ;
  73.     BEGIN (*RECDEF*)
  74.       OLD_SPACES_MARK := SPACES;
  75.       SPACES := BUFFERPTR - BUFFMARK + SPACES - SYLENG - 2 + FEED;
  76.       OLDSPACES := TRUE;
  77.       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  78.       WR_LINE ( BUFFERPTR-SYLENG);
  79.       REPEAT
  80.         CASE SYTY OF
  81.           CASESY :
  82.                  CASEDEF;
  83.           RECORDSY :
  84.                  RECDEF;
  85.           Else:
  86.                  INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
  87.         END;
  88.       UNTIL SYTY IN [ENDSY,EOBSY];
  89.       WR_LINE (BUFFERPTR-SYLENG);
  90.       OLDSPACES := TRUE;
  91.       LASTSPACES := SPACES - FEED;
  92.       SPACES := OLD_SPACES_MARK;
  93.       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  94.     END (*RECDEF*) ;
  95.     {%E}
  96.     PROCEDURE ERROR (ERRNR : INTEGER);
  97.     BEGIN (*ERROR*)
  98.       ERRFLAG := TRUE;
  99.       WR_LINE (BUFFERPTR);
  100.       WRITE (CROSSLIST,' ':17,' **** ');
  101.       CASE ERRNR OF
  102.         1 :
  103.                WRITELN (CROSSLIST,SY,' ? ? ? ',MESSAGE);
  104.         2 :
  105.     WRITELN (CROSSLIST,'Missing ''End'' OR ''Until'' Number ',EMARKNR : 4);
  106.         3 :
  107.                WRITELN (CROSSLIST,'Missing ''Then'' Number ',EMARKNR : 4);
  108.         4 :
  109.       WRITELN (CROSSLIST,'Missing ''Of'' To ''Case'' Number ',BMARKNR : 4);
  110.         5 :
  111.                WRITELN (CROSSLIST,' Only one ''Exit'' allowed');
  112.         6 :
  113.             WRITELN (CROSSLIST,'Missing ''Exit'' in ''Loop'' ',EMARKNR : 4)
  114.       END;
  115.     END (*ERROR*) ;
  116.     {%E}
  117.     PROCEDURE STATEMENT ;
  118.     VAR
  119.       CURBLOCKNR : INTEGER;     (*AKTUELLE BLOCKNUMMER*)
  120.       PROCEDURE COMPSTAT;
  121. Var Exit:Boolean;
  122.       BEGIN (*COMPSTAT*)
  123.         BMARKTEXT := 'B';
  124.         OLDSPACES := TRUE;
  125.         LASTSPACES := SPACES - BACKFEED;
  126.         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  127.         WR_LINE (BUFFERPTR-SYLENG);
  128.         REPEAT
  129. Exit:=False;
  130.           REPEAT
  131.             STATEMENT ;
  132.           UNTIL SYTY IN ENDSYM;
  133.           IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
  134.             THEN Exit:=True;
  135. If Not Exit Then
  136. Begin
  137.           ERROR (1);
  138.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  139. End;
  140.         UNTIL Exit;
  141.         WR_LINE (BUFFERPTR-SYLENG);
  142.         EMARKTEXT := 'E';
  143.         EMARKNR := CURBLOCKNR;
  144.         LASTSPACES := SPACES-BACKFEED;
  145.         OLDSPACES := TRUE;
  146.         IF SYTY = ENDSY
  147.           THEN
  148.             BEGIN
  149.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  150.               WR_LINE (BUFFERPTR-SYLENG);
  151.             END
  152.           ELSE ERROR (2);
  153.       END (*COMPSTAT*) ;
  154.       {%E}
  155.       PROCEDURE CASESTAT;
  156.       VAR
  157.         OLD_SPACES_MARK : INTEGER;
  158.         (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON CASE-STATEMENTS*)
  159. Exit:Boolean;
  160. Exit_Set,Exit_S2:Set Of Symbol;
  161.       BEGIN (*CASESTAT*)
  162.         BMARKTEXT := 'C';
  163.         OLDSPACES := TRUE;
  164.         LASTSPACES := SPACES-BACKFEED;
  165.         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  166.         STATEMENT ;
  167.         IF SYTY = OFSY
  168.           THEN WR_LINE (BUFFERPTR)
  169.           ELSE ERROR (3);
  170.         REPEAT
  171. Exit:=False;
  172.           REPEAT
  173.             REPEAT
  174.               If SyTy<>Other_Wise
  175.                 Then
  176.                   INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  177. Exit_Set:=(EndSym-[ElseSy]+[Colon,Other_Wise]);
  178.             UNTIL SYTY IN Exit_Set;
  179.             IF (SYTY = COLON)Or(SyTy=Other_Wise)
  180.               THEN
  181.                 BEGIN
  182.                   OLD_SPACES_MARK := SPACES;
  183.                   LASTSPACES := SPACES;
  184.                   SPACES := OLD_SPACES_MARK + CASEFEED;
  185.                   OLDSPACES := TRUE;
  186.                   INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  187.                   IF NOT ( SYTY IN BEGSYM )
  188.                     THEN
  189.                       BEGIN
  190.                         WR_LINE ( BUFFERPTR - SYLENG );
  191.                         SPACES := SPACES +1;
  192.                       END;
  193.                   STATEMENT ;
  194.                   SPACES := OLD_SPACES_MARK;
  195.                 END;
  196. Exit_S2:=EndSym-[ElseSy];
  197.           UNTIL SYTY IN Exit_S2;
  198.           IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
  199.             THEN Exit:=True;
  200. If Not Exit Then
  201.           ERROR (1);
  202.         UNTIL Exit;
  203.         WR_LINE (BUFFERPTR-SYLENG);
  204.         EMARKTEXT := 'E';
  205.         EMARKNR := CURBLOCKNR;
  206.         LASTSPACES := SPACES-BACKFEED;
  207.         OLDSPACES := TRUE;
  208.         IF SYTY = ENDSY
  209.           THEN
  210.             BEGIN
  211.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  212.               WR_LINE (BUFFERPTR-SYLENG);
  213.             END
  214.           ELSE ERROR (2);
  215.       END (*CASESTAT*) ;
  216.       {%E
  217.        PROCEDURE LOOPSTAT;
  218.        VAR
  219.        LOOPFLAG : BOOLEAN;     (*GESETZT BEIM AUFTRETEN VON EXIT-STATEMENTS
  220.        BEGIN (*LOOPSTAT
  221.        BMARKTEXT := 'L';
  222.        OLDSPACES := TRUE;
  223.        LASTSPACES := SPACES - BACKFEED;
  224.        INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  225.        WR_LINE (BUFFERPTR-SYLENG);
  226.        LOOPFLAG := FALSE;
  227.        REPEAT
  228.        REPEAT
  229.        STATEMENT ;
  230.        IF SYTY = EXITSY
  231.        THEN
  232.        BEGIN
  233.        WR_LINE (BUFFERPTR-SYLENG);
  234.        IF LOOPFLAG
  235.        THEN ERROR (5);
  236.        OLDSPACES := TRUE;
  237.        LASTSPACES := SPACES-BACKFEED;
  238.        LOOPFLAG := TRUE;
  239.        EMARKTEXT := 'X';
  240.        EMARKNR := CURBLOCKNR;
  241.        INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC); INSYMBOL(Dbl_DecL,CurProc);
  242.        END;
  243.        UNTIL SYTY IN ENDSYM;
  244.        IF SYTY IN [ENDSY,EOBSY,PROC_SY,FUNCT_SY]
  245.        THEN Exit:=True;
  246. If Not Exit Then
  247. Begin
  248.        ERROR (1);
  249.        INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  250. End;
  251.        UNTIL Exit;
  252.        WR_LINE (BUFFERPTR-SYLENG);
  253.        EMARKTEXT := 'E';
  254.        EMARKNR := CURBLOCKNR;
  255.        LASTSPACES := SPACES-BACKFEED;
  256.        OLDSPACES := TRUE;
  257.        IF SYTY = ENDSY
  258.        THEN
  259.        BEGIN
  260.        INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  261.        WR_LINE (BUFFERPTR-SYLENG);
  262.        END
  263.        ELSE ERROR (2);
  264.        IF NOT LOOPFLAG
  265.        THEN ERROR (6);
  266.        END (*LOOPSTAT ;
  267.        }
  268.       {%E}
  269.       PROCEDURE IFSTAT ;
  270.       BEGIN (*IFSTAT*)
  271.         BMARKTEXT := 'I';
  272.         LASTSPACES := SPACES - BACKFEED;
  273.         OLDSPACES := TRUE;
  274.         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  275.         STATEMENT ;
  276.         SPACES:=SPACES+FEED;
  277.         IF SYTY = THENSY
  278.           THEN
  279.             BEGIN
  280.               WR_LINE (BUFFERPTR-SYLENG);
  281.               LASTSPACES := SPACES - BACKFEED;
  282.               OLDSPACES := TRUE;
  283.               EMARKTEXT := 'T';
  284.               EMARKNR := CURBLOCKNR;
  285.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  286.               STATEMENT ;
  287.             END
  288.           ELSE ERROR (4);
  289.         IF SYTY = ELSESY
  290.           THEN
  291.             BEGIN
  292.               OLDSPACES := TRUE;
  293.               LASTSPACES := SPACES - BACKFEED;
  294.               WR_LINE (BUFFERPTR-SYLENG);
  295.               EMARKTEXT := 'S';
  296.               EMARKNR := CURBLOCKNR;
  297.               LASTSPACES := SPACES - BACKFEED;
  298.               OLDSPACES := TRUE;
  299.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  300.               STATEMENT ;
  301.             END;
  302.         SPACES:=SPACES-FEED;
  303.       END (*IFSTAT*) ;
  304.       {%E}
  305.       PROCEDURE LABELSTAT;
  306.       BEGIN (*LABELSTAT*)
  307.         LASTSPACES := 0;
  308.         OLDSPACES := TRUE;
  309.         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  310.         WR_LINE (BUFFERPTR-SYLENG);
  311.       END (*LABELSTAT*) ;
  312.       PROCEDURE REPEATSTAT;
  313. Var Exit:Boolean;
  314.       BEGIN (*REPEATSTAT*)
  315.         BMARKTEXT := 'R';
  316.         OLDSPACES := TRUE;
  317.         LASTSPACES := SPACES - BACKFEED;
  318.         INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  319.         WR_LINE (BUFFERPTR-SYLENG);
  320.         REPEAT
  321. Exit:=False;
  322.           REPEAT
  323.             STATEMENT ;
  324.           UNTIL SYTY IN ENDSYM;
  325.           IF SYTY IN [UNTILSY,EOBSY,PROC_SY,FUNCT_SY]
  326.             THEN Exit:=True;
  327. If Not Exit Then
  328. Begin
  329.           ERROR (1);
  330.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  331. End;
  332.         UNTIL EXIT;
  333.         WR_LINE (BUFFERPTR-SYLENG);
  334.         EMARKTEXT := 'U';
  335.         EMARKNR := CURBLOCKNR;
  336.         OLDSPACES := TRUE;
  337.         LASTSPACES := SPACES-BACKFEED;
  338.         IF SYTY = UNTILSY
  339.           THEN
  340.             BEGIN
  341.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  342.               STATEMENT ;
  343.             END
  344.           ELSE ERROR (2);
  345.       END (*REPEATSTAT*) ;
  346.       {%E}
  347.     BEGIN (*STATEMENT*)
  348.       IF SYTY = INTCONST
  349.         THEN
  350.           BEGIN
  351.             INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  352.             IF SYTY = COLON
  353.               THEN LABELSTAT;
  354.           END;
  355.       IF SYTY IN BEGSYM
  356.         Then
  357.           BEGIN
  358.             BLOCKNR := BLOCKNR + 1;
  359.             CURBLOCKNR := BLOCKNR;
  360.             BMARKNR := CURBLOCKNR;
  361.             WR_LINE (BUFFERPTR-SYLENG);
  362.             SPACES := SPACES + FEED;
  363.             CASE SYTY OF
  364.               BEGINSY :
  365.                      COMPSTAT;
  366.                      {             LOOPSY  :
  367.                       LOOPSTAT;         }
  368.               CASESY  :
  369.                      CASESTAT;
  370.               IFSY    :
  371.                      IFSTAT ;
  372.               REPEATSY :
  373.                      REPEATSTAT ;
  374.               Else:{}
  375.             END;
  376.             SPACES := SPACES - FEED;
  377.           END
  378.  ELSE
  379.  WHILE NOT(SYTY IN([SEMICOLON,Colon]+ENDSYM))DO
  380. INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  381.       IF (SYTY = SEMICOLON)Or(SyTy=Colon)
  382.         THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
  383.         ELSE
  384.           IF SYTY = DOSY
  385.             THEN
  386.               BEGIN
  387.                 INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  388.                 STATEMENT ;
  389.               END;
  390.     END (*STATEMENT*) ;
  391.     {%E}
  392.   BEGIN (*BLOCK*)
  393.     DBL_DECF := NIL;
  394.     LEVEL := LEVEL + 1;
  395.     CURPROC := LISTPTR;
  396. If Level=1 Then
  397. Begin
  398.   Insymbol(Dbl_DecF,Dbl_DecL,CurProc);
  399.   No_Main:=SyTy=ExternSy;
  400.   While SyTy<>Semicolon Do InSymbol(Dbl_DecF,Dbl_DecL,CurProc);
  401. End;
  402.     SPACES := LEVEL * FEED;
  403.     REPEAT
  404.       INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
  405.     UNTIL (SYTY IN RELEVANTSYM);
  406.     Repeat
  407.       WHILE SYTY IN (DECSYM) DO
  408.       BEGIN
  409.         WR_LINE (BUFFERPTR-SYLENG);
  410.         SPACES := SPACES - FEED;
  411.         WR_LINE (BUFFERPTR);
  412.         SPACES := SPACES + FEED;
  413.         REPEAT
  414.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  415.           IF SYTY = RECORDSY
  416.             THEN RECDEF;
  417.         UNTIL SYTY IN RELEVANTSYM;
  418.       END;
  419.       WHILE SYTY IN PROSYM DO
  420.       BEGIN
  421.         WR_LINE (BUFFERPTR-SYLENG);
  422.         OLDSPACES := TRUE;
  423.         IF SYTY <> INITPROCSY
  424.           THEN
  425.             BEGIN
  426.               IF SYTY = PROC_SY
  427.                 THEN PROCDEC := 1
  428.                 ELSE PROCDEC := 2;
  429.               INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  430.             END;
  431.         BLOCK;
  432.         IF SYTY = SEMICOLON
  433.           THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  434.       END;
  435. Exit_Set:=ProSym+DecSym;
  436. Exit:=Not (SyTy In Exit_Set);
  437.     Until Exit;
  438.     LEVEL := LEVEL - 1;
  439.  
  440.     SPACES := LEVEL * FEED;
  441.     IF NOT ((SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,FORTRANSY,EobSy])
  442.             Or((No_Main)And (SyTy=Point)))
  443.       THEN
  444.         BEGIN
  445.           ERROR (1);
  446. WHILE NOT
  447. (SYTY IN [BEGINSY,FORWARDSY,EXTERNSY,FORTRANSY,EOBSY])
  448.  DO INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
  449.         END;
  450.         {%E}
  451.     IF SYTY = BEGINSY
  452.       THEN STATEMENT
  453.       ELSE
  454.         BEGIN
  455.           INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  456.           IF SYTY = FORTRANSY
  457.             THEN INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC) ;
  458.         END ;
  459.     IF DBL_DECF <> NIL
  460.       THEN
  461.         REPEAT
  462.           DBL_DECF^.PROCORT^.PROCVAR := 0;
  463.           DBL_DECF := DBL_DECF^.NEXTPROC;
  464.         UNTIL  DBL_DECF = NIL;
  465.     IF (LEVEL = 0)And (Not No_Main)
  466.       THEN
  467.         BEGIN
  468.           IF SYTY <> POINT
  469.             THEN
  470.               BEGIN
  471.                 WRITELN (OUTPUT,'Missing point at program end');
  472.                 WRITELN (OUTPUT);
  473.    WRITELN (CROSSLIST,' ' : 17, ' **** Missing point at program end ****');
  474.                 INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC);
  475.               END;
  476.           IF SYTY <> EOBSY
  477.             THEN
  478.               REPEAT
  479.                 INSYMBOL(DBL_DECF,Dbl_DecL,CURPROC)
  480.               UNTIL SYTY = EOBSY;
  481.         END;
  482.   END (*BLOCK*) ;
  483. .
  484.