home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 02 / parser.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-08  |  28.9 KB  |  813 lines
  1. UNIT Parser;
  2.  
  3.  
  4. INTERFACE
  5.  
  6. USES Global, ScanCode;
  7.  
  8. PROCEDURE Programm (ESets: Symbolmenge);
  9.  
  10.  
  11. IMPLEMENTATION
  12.  
  13.  
  14. PROCEDURE Programm (ESets: Symbolmenge);
  15.  
  16. VAR ExtFP: ExtFileP;
  17.  
  18.  
  19.   PROCEDURE Block (ESets: Symbolmenge; ESet: Symbol; PInf: KonstP);
  20.  
  21.   VAR LastSymb: Symbol;  Stop: BOOLEAN;
  22.  
  23.  
  24.     (*$I DECLARE.PAS *)
  25.  
  26.  
  27.     PROCEDURE Body (ESets: Symbolmenge);
  28.  
  29.     VAR
  30.       StackTop,TopNew,StkMax: INTEGER;
  31.       templocc :KonstP;
  32.       SaveId: ALPHA;
  33.       KonstPtrIndex: INTEGER;
  34.       KonstPtr: CstPtrArray;
  35.       i,ProcEntryLab,ProcSize: INTEGER;
  36.       MaxLC,SavLocStk1: AddressRange;
  37.       locc: KonstP;
  38.       ActLab: LabPointer;
  39.  
  40.  
  41.       PROCEDURE Statement (ESets: Symbolmenge);
  42.  
  43.       LABEL 1;
  44.  
  45.       VAR locc: KonstP;  ActLab: LabPointer;
  46.  
  47.  
  48.         PROCEDURE Expression (ESets: Symbolmenge);
  49.         FORWARD;
  50.  
  51.  
  52.         PROCEDURE Selector (ESets: Symbolmenge;
  53.                             BezPtr: KonstP;
  54.                             VAR TopNew,StkMax: INTEGER;
  55.                             VAR KonstPtr: CstPtrArray;
  56.                             VAR KonstPtrIndex: INTEGER;
  57.                             VAR PInf: KonstP);
  58.  
  59.         VAR
  60.           LastAttr: Attribut;
  61.           locc: KonstP;
  62.           ActSize,lmin,lmax: INTEGER;
  63.  
  64.         BEGIN
  65.           WITH BezPtr^,Attr DO BEGIN
  66.             TyPtr := BezType;  Art := IsVar;
  67.             CASE Klass OF
  68.               VarClass: IF VarKind = Actual THEN BEGIN
  69.                           Zugriff := Direkt;  VarBSt := VarsBSt;
  70.                           OffSet := VarAddr
  71.                         END
  72.                         ELSE BEGIN
  73.                           G2T(54,BSt-VarsBSt,VarAddr,NilPtr,TopNew,StkMax);
  74.                           Zugriff := Indirekt;  IOffSet := 0
  75.                         END;
  76.             FieldClass: WITH DispVec[LastBSt] DO
  77.                           IF OccursIn = IsRec THEN BEGIN
  78.                             Zugriff := Direkt;  VarBSt := KonstBSt;
  79.                             OffSet := KonstOffSet+FieldAddress
  80.                           END
  81.                           ELSE BEGIN
  82.                             IF BSt = 1 THEN
  83.                               G1T(39,VarOffSet,NilPtr,TopNew,StkMax)
  84.                             ELSE
  85.                               G2T(54,0,VarOffSet,NilPtr,TopNew,StkMax);
  86.                             Zugriff := Indirekt;  IOffSet := FieldAddress
  87.                           END;
  88.              FuncClass: IF IsDeclDas = Standard THEN BEGIN
  89.                           Error(150);  TyPtr := NIL
  90.                         END
  91.                         ELSE BEGIN
  92.                           IF IsKind = Formal THEN
  93.                             Error(151)
  94.                           ELSE IF (ProcBSt+1 <> BSt) OR (PInf <> BezPtr) THEN
  95.                             Error(177);
  96.                           Zugriff := Direkt;  VarBSt := ProcBSt+1;
  97.                           OffSet := 0; (* LCAFTERMARKSTACK;  REL.ADR. FKTRESULT *)
  98.                         END
  99.             END (* CASE *)
  100.           END;  (* WITH *)
  101.           IF NOT (Symb IN SelectSys+ESets) THEN BEGIN
  102.             Error(59);  Recover(SelectSys+ESets)
  103.           END;
  104.           WHILE Symb IN SelectSys DO BEGIN
  105.             IF Symb = lBrack THEN BEGIN
  106.               REPEAT
  107.                 LastAttr := Attr;
  108.                 WITH LastAttr DO
  109.                   IF TyPtr <> NIL THEN
  110.                     IF TyPtr^.Form <> Arrays THEN BEGIN
  111.                       Error(138);  TyPtr := NIL
  112.                     END;
  113.                 PushAddress(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  114.                 GetSymbol;
  115.                 Expression(ESets+[CommaSymb,rBrack]);
  116.                 PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  117.                 IF Attr.TyPtr <> NIL THEN
  118.                   IF Attr.TyPtr^.Form <> Scalar THEN Error(113)
  119.                   ELSE IF NOT IsCompatible(Attr.TyPtr,IntPtr) THEN
  120.                     G0T(58,Attr.TyPtr,TopNew,StkMax);
  121.                 IF LastAttr.TyPtr <> NIL THEN
  122.                   WITH LastAttr.TyPtr^ DO BEGIN
  123.                     IF IsCompatible(IndexType,Attr.TyPtr) THEN BEGIN
  124.                       IF IndexType<>NIL THEN BEGIN
  125.                         GetBounds(IndexType,lmin,lmax);
  126.                         IF Debug THEN
  127.                           G2T(45,lmin,lmax,IntPtr,TopNew,StkMax);
  128.                         IF lmin > 0 THEN
  129.                           G1T(31,lmin,IntPtr,TopNew,StkMax)
  130.                         ELSE IF lmin < 0 THEN
  131.                           G1T(34,-lmin,IntPtr,TopNew,StkMax);
  132.                       END
  133.                     END
  134.                     ELSE Error(139);
  135.                     WITH Attr DO BEGIN
  136.                       TyPtr := ElemType;   Art := IsVar;
  137.                       Zugriff := Indirekt;   IOffSet := 0
  138.                     END;
  139.                     IF Attr.TyPtr <> NIL THEN BEGIN
  140.                       ActSize := Attr.TyPtr^.Size;
  141.                       G1(36,ActSize,TopNew,StkMax,KonstPtr)
  142.                     END
  143.                   END (* WITH *)
  144.               UNTIL Symb <> CommaSymb;
  145.               IF Symb = rBrack THEN GetSymbol ELSE Error(12)
  146.             END (* IF SYMB = LBRACK *)
  147.             ELSE IF Symb = UpTo THEN BEGIN
  148.               WITH Attr DO BEGIN
  149.                 IF TyPtr <> NIL THEN
  150.                   IF TyPtr^.Form<>Records THEN BEGIN
  151.                     Error(140);  TyPtr := NIL
  152.                   END;
  153.                 GetSymbol;
  154.                 IF Symb = Bezeich THEN BEGIN
  155.                   IF TyPtr <> NIL THEN BEGIN
  156.                     FindRecFields(TyPtr^.FirstField,locc);
  157.                     IF locc = NIL THEN BEGIN
  158.                       Error(152);  TyPtr := NIL
  159.                     END
  160.                     ELSE
  161.                       WITH locc^ DO BEGIN
  162.                         TyPtr := BezType;
  163.                         CASE Zugriff OF
  164.                           Direkt  : OffSet := OffSet+FieldAddress;
  165.                           Indirekt: IOffSet := IOffSet+FieldAddress;
  166.                           Indexed : Error(400)
  167.                         END
  168.                       END
  169.                   END;  (* IF TYPTR<>NIL *)
  170.                   GetSymbol
  171.                 END (* IF SYMB = BEZEICH *)
  172.                 ELSE Error(2)
  173.               END (* WITH ATTR *)
  174.             END (* ELSE IF SYMB = UPTO *)
  175.             ELSE BEGIN
  176.               IF Attr.TyPtr <> NIL THEN
  177.                 WITH Attr,TyPtr^ DO
  178.                   IF Form = Pointers THEN BEGIN
  179.                     PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  180.                     TyPtr := ElType;
  181.                     IF Debug THEN G2T(45,1,MaxAddr,NilPtr,TopNew,StkMax);
  182.                     WITH Attr DO BEGIN
  183.                       Art := IsVar;  Zugriff := Indirekt;  IOffSet := 0
  184.                     END
  185.                   END
  186.                   ELSE IF Form = Files THEN TyPtr := FileType
  187.                   ELSE Error(141);
  188.                   GetSymbol
  189.             END;  (* ELSE *)
  190.             IF NOT (Symb IN ESets+SelectSys) THEN BEGIN
  191.               Error(6);  Recover(ESets+SelectSys)
  192.             END
  193.           END;  (* WHILE SYMB IN SELECTSYS *)
  194.         END;  (* Selector *)
  195.  
  196.  
  197.         (*$I PROCCALL.PAS *)
  198.         (*$I EXPRESS.PAS *)
  199.  
  200.         PROCEDURE Assignment (BezPtr: KonstP);
  201.  
  202.         VAR LastAttr: Attribut;
  203.  
  204.         BEGIN
  205.           Selector(ESets+[AssignTo],BezPtr,TopNew,StkMax,
  206.                    KonstPtr,KonstPtrIndex,PInf);
  207.           IF Symb = AssignTo THEN BEGIN
  208.             IF Attr.TyPtr <> NIL THEN
  209.               IF (Attr.Zugriff <> Direkt) OR (Attr.TyPtr^.Form>Power) THEN
  210.                 PushAddress(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  211.             LastAttr := Attr;
  212.             GetSymbol;  Expression(ESets);
  213.             IF Attr.TyPtr <> NIL THEN
  214.             IF Attr.TyPtr^.Form <= Power THEN
  215.               PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex)
  216.             ELSE
  217.               PushAddress(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  218.             IF (LastAttr.TyPtr <> NIL) AND (Attr.TyPtr <> NIL) THEN BEGIN
  219.               IF IsCompatible(RealPtr,LastAttr.TyPtr) THEN BEGIN
  220.                 IF Attr.TyPtr = IntPtr THEN BEGIN
  221.                   G0(10,TopNew,StkMax);  Attr.TyPtr := RealPtr
  222.                 END
  223.                 ELSE IF Attr.TyPtr = LongPtr THEN BEGIN
  224.                   G0(71 (*LFT*),TopNew,StkMax);  Attr.TyPtr := RealPtr
  225.                 END;
  226.               END
  227.               ELSE IF IsCompatible(LongPtr,LastAttr.TyPtr) THEN
  228.                 IF Attr.TyPtr = IntPtr THEN BEGIN
  229.                   G0(67 (*ILT*),TopNew,StkMax);  Attr.TyPtr := LongPtr
  230.                 END;
  231.               IF IsCompatible(LastAttr.TyPtr,Attr.TyPtr) THEN
  232.                 CASE LastAttr.TyPtr^.Form OF
  233.                   Scalar,
  234.                   SubRange:
  235.                     BEGIN
  236.                       IF Debug THEN CheckBounds(LastAttr.TyPtr,TopNew,StkMax);
  237.                       Store(LastAttr,TopNew,StkMax)
  238.                     END;
  239.                   Pointers:
  240.                     BEGIN
  241.                       IF Debug THEN G2T(45,0,MaxAddr,NilPtr,TopNew,StkMax);
  242.                       Store(LastAttr,TopNew,StkMax)
  243.                     END;
  244.                   Power:
  245.                     Store(LastAttr,TopNew,StkMax);
  246.                   Arrays,
  247.                   Records:
  248.                     G1(40,LastAttr.TyPtr^.Size,TopNew,StkMax,KonstPtr);
  249.                   Files:
  250.                     Error(146)
  251.                 END
  252.               ELSE Error(129)
  253.             END
  254.           END
  255.           ELSE Error(51);
  256.         END; (* Assignment *)
  257.  
  258.  
  259.         PROCEDURE GotoStatement;
  260.  
  261.         VAR
  262.           ActLab: LabPointer;
  263.           Found: BOOLEAN;
  264.           SaveTop, SaveTop1: DispRange;
  265.  
  266.         BEGIN
  267.           IF Symb = IntConst THEN BEGIN
  268.             Found := FALSE;
  269.             SaveTop := DispTop;
  270.             WHILE DispVec[SaveTop].OccursIn <> IsBlock DO SaveTop := SaveTop-1;
  271.             SaveTop1 := SaveTop;
  272.             REPEAT
  273.               ActLab := DispVec[SaveTop].FirstLab;
  274.               WHILE (ActLab <> NIL) AND NOT Found DO
  275.                 WITH ACTLAB^ DO
  276.                   IF LabValue = LastConstVal.GanzeZahl THEN BEGIN
  277.                     Found := TRUE;
  278.                     IF SaveTop = SaveTop1 THEN GCase(57,LabName,TopNew,StkMax)
  279.                     ELSE Error(399)
  280.                   END
  281.                   ELSE ActLab := NextLab;
  282.               SaveTop := SaveTop-1
  283.             UNTIL Found OR (SaveTop = 0);
  284.             IF NOT Found THEN Error(167);
  285.             GetSymbol
  286.           END
  287.           ELSE Error(15);
  288.         END; (* GotoStatement *)
  289.  
  290.  
  291.         PROCEDURE CompoundStatement;
  292.  
  293.         BEGIN
  294.           REPEAT
  295.             REPEAT
  296.               Statement(ESets+[Semicolon,EndSymb])
  297.             UNTIL NOT (Symb IN StatStartSymb);
  298.             Stop := Symb <> Semicolon;
  299.             IF NOT Stop THEN GetSymbol
  300.           UNTIL Stop;
  301.           IF Symb = EndSymb THEN GetSymbol ELSE Error(13);
  302.         END; (* CompoundStatement *)
  303.  
  304.  
  305.         PROCEDURE IfStatement;
  306.  
  307.         VAR JumpLab1,JumpLab2: INTEGER;
  308.  
  309.         BEGIN
  310.           Expression(ESets+[ThenSy]);
  311.           GLab(JumpLab1);
  312.           GJump(JumpLab1,TopNew,StkMax,KonstPtr,KonstPtrIndex);
  313.           IF Symb = ThenSy THEN GetSymbol ELSE Error(52);
  314.           Statement(ESets+[ElseSymb]);
  315.           IF Symb = ElseSymb THEN BEGIN
  316.             GLab(JumpLab2);  GCase(57,JumpLab2,TopNew,StkMax);
  317.             PushLabel(JumpLab1);
  318.             GetSymbol;  Statement(ESets);
  319.             PushLabel(JumpLab2)
  320.           END
  321.           ELSE PushLabel(JumpLab1)
  322.         END; (* IfStatement *)
  323.  
  324.  
  325.         PROCEDURE CaseStatement;
  326.  
  327.         LABEL 1;
  328.  
  329.         TYPE
  330.           CaseTabPtr = ^CaseTable;
  331.           CaseTable = PACKED RECORD
  332.                         Next: CaseTabPtr;
  333.                         LabStart: INTEGER;
  334.                         LabNo: INTEGER
  335.                       END;
  336.  
  337.         VAR
  338.           SavSP,SavSP1: StP;
  339.           FirstPointer,CasTab1,CasTab2,CasTab3: CaseTabPtr;
  340.           SavVal: Value;
  341.           ToAddr,JumpLab,JumpLab1,lmin,lmax: INTEGER;
  342.  
  343.         BEGIN
  344.           Expression(ESets+[OfSymb,CommaSymb,ColonSymb]);
  345.           PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  346.           GLab(JumpLab);
  347.           SavSP := Attr.TyPtr;
  348.           IF SavSP <> NIL THEN
  349.             IF (SavSP^.Form <> Scalar) OR (SavSP = RealPtr) THEN BEGIN
  350.               Error(144);  SavSP := NIL
  351.             END
  352.             ELSE IF NOT IsCompatible(SavSP,IntPtr) THEN
  353.               G0T(58,SavSP,TopNew,StkMax);
  354.           GCase(57,JumpLab,TopNew,StkMax);
  355.           IF Symb = OfSymb THEN GetSymbol ELSE Error(8);
  356.           FirstPointer := NIL;  GLab(ToAddr);
  357.           REPEAT
  358.             CasTab3 := NIL;  GLab(JumpLab1);
  359.             IF NOT(Symb IN [Semicolon,EndSymb]) THEN BEGIN
  360.               REPEAT
  361.                 GConstant(ESets+[CommaSymb,ColonSymb],SavSP1,SavVal);
  362.                 IF SavSP <> NIL THEN
  363.                   IF IsCompatible(SavSP,SavSP1) THEN BEGIN
  364.                     CasTab1 := FirstPointer;  CasTab2 := NIL;
  365.                     WHILE CasTab1 <> NIL DO
  366.                       WITH CasTab1^ DO BEGIN
  367.                         IF LabNo <= SavVal.GanzeZahl THEN BEGIN
  368.                           IF LabNo = SavVal.GanzeZahl THEN Error(156);
  369.                           GOTO 1
  370.                         END;
  371.                         CasTab2 := CasTab1;  CasTab1 := Next
  372.                       END;
  373.                     1:
  374.                     New(CasTab3);
  375.                     WITH CasTab3^ DO BEGIN
  376.                       Next := CasTab1;  LabNo := SavVal.GanzeZahl;
  377.                       LabStart := JumpLab1;
  378.                     END;
  379.                     IF CasTab2 = NIL THEN FirstPointer := CasTab3
  380.                     ELSE CasTab2^.Next := CasTab3
  381.                   END
  382.                   ELSE Error(147);
  383.                 Stop := Symb <> CommaSymb;
  384.                 IF NOT Stop THEN GetSymbol
  385.               UNTIL Stop;
  386.               IF Symb = ColonSymb THEN GetSymbol ELSE Error(5);
  387.               PushLabel(JumpLab1);
  388.               REPEAT
  389.                 Statement(ESets+[Semicolon])
  390.               UNTIL NOT (Symb IN StatStartSymb);
  391.               IF CasTab3 <> NIL THEN
  392.                 GCase(57,ToAddr,TopNew,StkMax)
  393.             END;
  394.             Stop := Symb <> Semicolon;
  395.             IF NOT Stop THEN GetSymbol
  396.           UNTIL Stop;
  397.           PushLabel(JumpLab);
  398.           IF FirstPointer <> NIL THEN BEGIN
  399.             lmax := FirstPointer^.LabNo;
  400.             CasTab1 := FirstPointer;  FirstPointer := NIL;
  401.             REPEAT
  402.               CasTab2 := CasTab1^.Next;  CasTab1^.Next := FirstPointer;
  403.               FirstPointer := CasTab1;  CasTab1 := CasTab2
  404.             UNTIL CasTab1 = NIL;
  405.             lmin := FirstPointer^.LabNo;
  406.             IF lmax-lmin < MaxCases THEN BEGIN
  407.               G2T(45,lmin,lmax,IntPtr,TopNew,StkMax);
  408.               G2(51,1,lmin,TopNew,StkMax,KonstPtr);
  409.               G0(21,TopNew,StkMax);  GLab(JumpLab);
  410.               GCase(44,JumpLab,TopNew,StkMax);
  411.               PushLabel(JumpLab);
  412.               REPEAT
  413.                 WITH FirstPointer^ DO BEGIN
  414.                   WHILE LabNo>lmin DO BEGIN
  415.                     G0(60,TopNew,StkMax);
  416.                     lmin := lmin+1
  417.                   END;
  418.                   GCase(57,LabStart,TopNew,StkMax);
  419.                   FirstPointer := Next;  lmin := lmin+1
  420.                 END
  421.               UNTIL FirstPointer = NIL;
  422.               PushLabel(ToAddr)
  423.             END
  424.             ELSE Error(157)
  425.           END;
  426.           IF Symb = EndSymb THEN GetSymbol ELSE Error(13)
  427.         END; (* CaseStatement *)
  428.  
  429.  
  430.         PROCEDURE RepeatStatement;
  431.  
  432.         VAR ToAddr: INTEGER;
  433.   
  434.         BEGIN
  435.           GLab(ToAddr);  PushLabel(ToAddr);
  436.           REPEAT
  437.             Statement(ESets+[Semicolon,UntilSymb]);
  438.             IF Symb IN StatStartSymb THEN Error(14)
  439.           UNTIL NOT (Symb IN StatStartSymb);
  440.           WHILE Symb = Semicolon DO BEGIN
  441.             GetSymbol;
  442.             REPEAT
  443.               Statement(ESets+[Semicolon,UntilSymb]);
  444.               IF Symb IN StatStartSymb THEN Error(14)
  445.             UNTIL NOT (Symb IN StatStartSymb);
  446.           END;
  447.           IF Symb = UntilSymb THEN BEGIN
  448.             GetSymbol;
  449.             Expression(ESets);
  450.             GJump(ToAddr,TopNew,StkMax,KonstPtr,KonstPtrIndex)
  451.           END
  452.           ELSE Error(53)
  453.         END; (* RepeatStatement *)
  454.  
  455.  
  456.         PROCEDURE WhileStatement;
  457.  
  458.         VAR ToAddr,JumpLab: INTEGER;
  459.  
  460.         BEGIN
  461.           GLab(ToAddr);  PushLabel(ToAddr);
  462.           Expression(ESets+[DoSymb]);  GLab(JumpLab);
  463.           GJump(JumpLab,TopNew,StkMax,KonstPtr,KonstPtrIndex);
  464.           IF Symb = DoSymb THEN GetSymbol ELSE Error(54);
  465.           Statement(ESets);  GCase(57,ToAddr,TopNew,StkMax);  PushLabel(JumpLab);
  466.         END; (* WhileStatement *)
  467.  
  468.  
  469.         PROCEDURE ForStatement;
  470.  
  471.         VAR
  472.           LastAttr: Attribut;
  473.           SavSP: StP;
  474.           LastSymb: Symbol;
  475.           JumpLab,ToAddr: INTEGER;
  476.           SavLocStk: AddressRange;
  477.  
  478.         BEGIN
  479.           SavLocStk := LocStk;
  480.           WITH LastAttr DO BEGIN
  481.             TyPtr := NIL;  Art := IsVar;
  482.             Zugriff := Direkt;  VarBSt := Bst;  OffSet := 0
  483.           END;
  484.           IF Symb = Bezeich THEN BEGIN
  485.             FindeBez([VarClass],locc);
  486.             WITH locc^,LastAttr DO BEGIN
  487.               TyPtr := BezType;  Art := IsVar;
  488.               IF VarKind = Actual THEN BEGIN
  489.                 Zugriff := Direkt;  VarBSt := VarsBSt;  OffSet := VarAddr
  490.               END
  491.               ELSE BEGIN
  492.                 Error(155);  TyPtr := NIL
  493.               END
  494.             END;
  495.             IF LastAttr.TyPtr <> NIL THEN
  496.               IF (LastAttr.TyPtr^.Form > SubRange) OR
  497.                  IsCompatible(RealPtr,LastAttr.TyPtr) OR
  498.                  IsCompatible(LongPtr,LastAttr.TyPtr) THEN BEGIN
  499.                 Error(143);  LastAttr.TyPtr := NIL
  500.               END;
  501.             GetSymbol
  502.           END
  503.           ELSE BEGIN
  504.             Error(2);  Recover(ESets+[AssignTo,ToSymb,DownToSymb,DoSymb])
  505.           END;
  506.           IF Symb = AssignTo THEN BEGIN
  507.             GetSymbol;  Expression(ESets+[ToSymb,DownToSymb,DoSymb]);
  508.             IF Attr.TyPtr <> NIL THEN
  509.               IF Attr.TyPtr^.Form <> Scalar THEN Error(144)
  510.               ELSE IF IsCompatible(LastAttr.TyPtr,Attr.TyPtr) THEN BEGIN
  511.                 PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  512.                 Store(LastAttr,TopNew,StkMax)
  513.               END
  514.               ELSE Error(145)
  515.           END
  516.           ELSE BEGIN
  517.             Error(51);  Recover(ESets+[ToSymb,DownToSymb,DoSymb])
  518.           END;
  519.           IF Symb IN [ToSymb,DownToSymb] THEN BEGIN
  520.             LastSymb := Symb; GetSymbol;  Expression(ESets+[DoSymb]);
  521.             IF Attr.TyPtr <> NIL THEN
  522.               IF Attr.TyPtr^.Form <> Scalar THEN Error(144)
  523.               ELSE IF IsCompatible(LastAttr.TyPtr,Attr.TyPtr) THEN BEGIN
  524.                 PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  525.                 IF NOT IsCompatible(LastAttr.TyPtr,IntPtr) THEN
  526.                   G0T(58,Attr.TyPtr,TopNew,StkMax);
  527.                 G2T(56,0,LocStk,IntPtr,TopNew,StkMax);
  528.                 GLab(ToAddr);  PushLabel(ToAddr);
  529.                 Attr := LastAttr;
  530.                 PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  531.                 IF NOT IsCompatible(Attr.TyPtr,IntPtr) THEN
  532.                   G0T(58,Attr.TyPtr,TopNew,StkMax);
  533.                 G2T(54,0,LocStk,IntPtr,TopNew,StkMax);
  534.                 LocStk := LocStk+IntSize;
  535.                 IF ICount>MaxLC THEN MaxLC := LocStk;
  536.                 IF LastSymb = ToSymb THEN
  537.                   G2(52,Ord('i'),1,TopNew,StkMax,KonstPtr)
  538.                 ELSE
  539.                   G2(48,Ord('i'),1,TopNew,StkMax,KonstPtr);
  540.               END
  541.               ELSE Error(145)
  542.           END
  543.           ELSE BEGIN
  544.             Error(55);  Recover(ESets+[DoSymb])
  545.           END;
  546.           GLab(JumpLab);  GCase(33,JumpLab,TopNew,StkMax);
  547.           IF Symb = DoSymb THEN GetSymbol ELSE Error(54);
  548.           Statement(ESets);
  549.           Attr := LastAttr;
  550.           PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  551.           IF LastSymb = ToSymb THEN G1T(34,1,Attr.TyPtr,TopNew,StkMax)
  552.           ELSE G1T(31,1,Attr.TyPtr,TopNew,StkMax);
  553.           Store(LastAttr,TopNew,StkMax);
  554.           GCase(57,ToAddr,TopNew,StkMax);
  555.           PushLabel(JumpLab);
  556.           LocStk := SavLocStk
  557.         END; (* ForStatement *)
  558.  
  559.  
  560.         PROCEDURE WithStatement;
  561.  
  562.         VAR
  563.           locc: KonstP;
  564.           NoOfWithElems: DispRange;
  565.           SavLocStk: AddressRange;
  566.  
  567.         BEGIN
  568.           NoOfWithElems := 0;  SavLocStk := LocStk;
  569.           REPEAT
  570.             IF Symb = Bezeich THEN BEGIN
  571.               FindeBez([VarClass,FieldClass],locc);  GetSymbol
  572.             END
  573.             ELSE BEGIN
  574.               Error(2);  locc := UVarPtr
  575.             END;
  576.             Selector(ESets+[CommaSymb,DoSymb],locc,TopNew,StkMax,
  577.                      KonstPtr,KonstPtrIndex,PInf);
  578.             IF Attr.TyPtr <> NIL THEN
  579.               IF Attr.TyPtr^.Form = Records THEN
  580.                 IF DispTop < MaxDispVec THEN BEGIN
  581.                   DispTop := DispTop+1;  NoOfWithElems := NoOfWithElems+1;
  582.                   WITH DispVec[DispTop] DO BEGIN
  583.                     FirstDeclID := Attr.TyPtr^.FirstField;
  584.                     FirstLab := NIL
  585.                   END;
  586.                   IF Attr.Zugriff = Direkt THEN
  587.                     WITH DispVec[DispTop] DO BEGIN
  588.                       OccursIn := IsRec;  KonstBst := Attr.VarBSt;
  589.                       KonstOffSet := Attr.OffSet
  590.                     END
  591.                   ELSE BEGIN
  592.                     PushAddress(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  593.                     G2T(56,0,LocStk,NilPtr,TopNew,StkMax);
  594.                     WITH DispVec[DispTop] DO BEGIN
  595.                       OccursIn := InVariantRec;  VarOffSet := LocStk
  596.                     END;
  597.                     LocStk := LocStk+PtrSize;
  598.                     IF LocStk>MaxLC THEN MaxLC := LocStk
  599.                   END
  600.                 END
  601.                 ELSE Error(250)
  602.               ELSE Error(140);
  603.             Stop := Symb <> CommaSymb;
  604.             IF NOT Stop THEN GetSymbol
  605.           UNTIL Stop;
  606.           IF Symb = DoSymb THEN GetSymbol ELSE Error(54);
  607.           Statement(ESets);
  608.           DispTop := DispTop-NoOfWithElems; LocStk := SavLocStk
  609.         END; (* WithStatement *)
  610.  
  611.  
  612.       BEGIN (* Statement *)
  613.         IF Symb = IntConst THEN BEGIN
  614.           ActLab := DispVec[Bst].FirstLab;
  615.           WHILE ActLab <> NIL DO
  616.             WITH ACTLAB^ DO
  617.               IF LabValue = LastConstVal.GanzeZahl THEN BEGIN
  618.                 IF Defined THEN Error(165);
  619.                 PushLabel(LabName);  Defined := TRUE;
  620.                 GOTO 1
  621.               END
  622.               ELSE ActLab := NextLab;
  623.           Error(167);
  624.           1:
  625.           GetSymbol;
  626.           IF Symb = ColonSymb THEN GetSymbol ELSE Error(5)
  627.         END;
  628.         IF NOT (Symb IN ESets+[Bezeich]) THEN BEGIN
  629.           Error(6);  Recover(ESets)
  630.         END;
  631.         IF Symb IN StatStartSymb+[Bezeich] THEN BEGIN
  632.           CASE Symb OF
  633.             Bezeich   : BEGIN
  634.                           FindeBez([VarClass,FieldClass,FuncClass,ProcClass],
  635.                                    locc);
  636.                           GetSymbol;
  637.                           IF locc^.Klass = ProcClass THEN
  638.                             CallProcedure(ESets,locc)
  639.                           ELSE
  640.                             Assignment(locc)
  641.                         END;
  642.             BeginSymb : BEGIN  GetSymbol;  CompoundStatement  END;
  643.             GotoSymb  : BEGIN  GetSymbol;  GotoStatement  END;
  644.             IfSymb    : BEGIN  GetSymbol;  IfStatement  END;
  645.             CaseSymb  : BEGIN  GetSymbol;  CaseStatement  END;
  646.             WhileSymb : BEGIN  GetSymbol;  WhileStatement  END;
  647.             RepeatSymb: BEGIN  GetSymbol;  RepeatStatement  END;
  648.             ForSymb   : BEGIN  GetSymbol;  ForStatement  END;
  649.             WithSymb  : BEGIN  GetSymbol;  WithStatement  END
  650.           END;
  651.           IF NOT (Symb IN [Semicolon,EndSymb,ElseSymb,UntilSymb]) THEN BEGIN
  652.             Error(6); Recover(ESets)
  653.           END
  654.         END;
  655.       END;
  656.  
  657.     BEGIN (* Body *)
  658.       IF PInf <> NIL THEN ProcEntryLab := PINF^.ProcLabel
  659.       ELSE GLab(ProcEntryLab);
  660.       KonstPtrIndex := 0;
  661.       TopNew := VirginLocStk;
  662.       StkMax := VirginLocStk;
  663.       PushLabel(ProcEntryLab);GLab(ProcSize);  GLab(StackTop);
  664.       GProcCall(32,1,ProcSize,TopNew,StkMax);
  665.       GProcCall(32,2,StackTop,TopNew,StkMax);
  666.       IF PInf <> NIL THEN BEGIN
  667.         SavLocStk1 := VirginLocStk;
  668.         locc := PINF^.Next;
  669.         WHILE locc <> NIL DO
  670.           WITH locc^ DO BEGIN
  671.             IF Klass = VarClass THEN
  672.               IF BezType <> NIL THEN
  673.                 IF BezType^.Form > Power THEN BEGIN
  674.                   IF VarKind = Actual THEN BEGIN
  675.                     G2(50,0,VarAddr,TopNew,StkMax,KonstPtr);
  676.                     G2T(54,0,SavLocStk1,NilPtr,TopNew,StkMax);
  677.                     G1(40,BezType^.Size,TopNew,StkMax,KonstPtr)
  678.                   END;
  679.                   SavLocStk1 := SavLocStk1+PtrSize;
  680.                 END
  681.                 ELSE SavLocStk1 := SavLocStk1+BezType^.Size;
  682.                 locc := locc^.Next;
  683.           END;
  684.       END;
  685.       MaxLC := LocStk;
  686.       REPEAT
  687.         REPEAT
  688.           Statement(ESets+[Semicolon,EndSymb])
  689.         UNTIL NOT (Symb IN StatStartSymb);
  690.         Stop := Symb <> Semicolon;
  691.         IF NOT Stop THEN GetSymbol
  692.       UNTIL Stop;
  693.       IF Symb = EndSymb THEN GetSymbol ELSE Error(13);
  694.       ActLab := DispVec[DispTop].FirstLab;
  695.       WHILE ActLab <> NIL DO
  696.         WITH ACTLAB^ DO BEGIN
  697.           IF NOT Defined THEN Error(168);
  698.           ActLab := NextLab;
  699.         END;
  700.       IF PInf <> NIL THEN BEGIN
  701.         GenPopDBG;
  702.         IF PINF^.BezType = NIL THEN
  703.           G1(42,Ord('p'),TopNew,StkMax,KonstPtr)
  704.         ELSE
  705.           G0T(42(*RET*),PINF^.BezType,TopNew,StkMax);
  706.         IF IsPrtCode THEN BEGIN
  707.           WriteLn(Dat,'l ',ProcSize:4,' = ',MaxLC);
  708.           WriteLn(Dat,'l ',StackTop:4,' = ',StkMax)
  709.         END
  710.       END
  711.       ELSE BEGIN
  712.         GenPopDBG;
  713.         G1(42(*RET*),Ord('p'),TopNew,StkMax,KonstPtr);
  714.         IF IsPrtCode THEN BEGIN
  715.           WriteLn(Dat,'l ',ProcSize:4,' = ',MaxLC);
  716.           WriteLn(Dat,'l ',StackTop:4,' = ',StkMax);
  717.           WriteLn(Dat,'q')
  718.         END;
  719.         ICount := 0;
  720.         G1(41,0,TopNew,StkMax,KonstPtr);
  721.         GProcCall(46,0,ProcEntryLab,TopNew,StkMax);
  722.         G0(29,TopNew,StkMax);
  723.         IF IsPrtCode THEN WriteLn(Dat,'q');
  724.         SaveId := Bez;
  725.         WHILE FExtFileP <> NIL DO BEGIN
  726.           WITH FExtFileP^ DO
  727.             IF NOT ((FileName = 'INPUT   ') OR (FileName = 'OUTPUT  '))
  728.             THEN BEGIN
  729.               Bez := FileName;
  730.               FindeBez([VarClass],templocc);
  731.               IF templocc^.BezType <> NIL THEN
  732.                 IF templocc^.BezType^.Form <> Files THEN Error(172);
  733.             END;
  734.             FExtFileP := FExtFileP^.NextFile
  735.         END;
  736.         Bez := SaveId;
  737.       END;
  738.     END; (* Body *)
  739.  
  740.  
  741.   BEGIN (* Block *)
  742.     DP := TRUE;
  743.     REPEAT
  744.       IF Symb = LabelSymb THEN BEGIN
  745.         GetSymbol; LabelDeclaration(Stop,ESets)
  746.       END;
  747.       IF Symb = ConstSymb THEN BEGIN
  748.         GetSymbol; ConstDeclaration(ESets)
  749.       END;
  750.       IF Symb = TypeSymb THEN BEGIN
  751.         GetSymbol; TypeDeclaration(Stop,ESets)
  752.       END;
  753.       IF Symb = VarSymb THEN BEGIN
  754.         GetSymbol; VarDeclaration(Stop,ESets)
  755.       END;
  756.       WHILE Symb IN [ProcSymb,FuncSymb] DO BEGIN
  757.         LastSymb := Symb;
  758.         GetSymbol;
  759.         ProcDeclaration(LastSymb,Stop,ESets)
  760.       END;
  761.       IF Symb <> BeginSymb THEN BEGIN
  762.         Error(18); Recover(ESets)
  763.       END
  764.     UNTIL (Symb IN StatStartSymb) OR Eof(Source);
  765.     DP := FALSE;
  766.     IF Symb = BeginSymb THEN GetSymbol ELSE Error(17);
  767.     REPEAT
  768.       Body(ESets+[CaseSymb]);
  769.       IF Symb <> ESet THEN BEGIN
  770.         Error(6); Recover(ESets)
  771.       END
  772.     UNTIL ((Symb = ESet) OR (Symb IN BlockStartSy)) OR Eof(Source);
  773.   END; (* Block *)
  774.  
  775.  
  776. BEGIN (* Programm *)
  777.   IF Symb = ProgSymb THEN BEGIN
  778.     GetSymbol;
  779.     IF Symb <> Bezeich THEN Error(2);
  780.     GetSymbol;
  781.     IF NOT (Symb IN [lBraces,Semicolon]) THEN Error(14);
  782.     IF Symb = lBraces THEN BEGIN
  783.       REPEAT
  784.         GetSymbol;
  785.         IF Symb = Bezeich THEN BEGIN
  786.           New(ExtFP);
  787.           WITH ExtFP^ DO BEGIN
  788.             FileName := Bez;  NextFile := FExtFileP
  789.           END;
  790.           FExtFileP := ExtFP;
  791.           GetSymbol;
  792.           IF NOT (Symb IN [CommaSymb,rBrace]) THEN Error(20)
  793.         END
  794.         ELSE Error(2)
  795.       UNTIL Symb <> CommaSymb;
  796.       IF Symb <> rBrace THEN Error(4);
  797.       GetSymbol
  798.     END;
  799.     IF Symb <> Semicolon THEN Error(14)
  800.     ELSE GetSymbol;
  801.   END;
  802.   REPEAT
  803.     Block(ESets,UpTo,NIL);
  804.     IF Symb <> UpTo THEN Error(21)
  805.   UNTIL (Symb = UpTo) OR Eof(Source);
  806.   IF ErrorIndex <> 0 THEN BEGIN
  807.     ErrorIndex := 0;  DoEoLn;
  808.   END;
  809. END;
  810.  
  811.  
  812. BEGIN
  813. END.