Turbo Toolbox/Turbo_Toolbox.iso/spezial/02/scancode.pas

Pascal/Delphi Source File | 1988-02-12 | 32.0 KB | 1,126 lines

UNIT ScanCode;

INTERFACE

USES Global;


PROCEDURE LoadErrorText;
PROCEDURE WriteErrorText (No: INTEGER);
PROCEDURE WriteErrorLine;
PROCEDURE Error (ErrorNo: INTEGER);
PROCEDURE DoEoLn;
PROCEDURE EnterLine (c: CHAR);
PROCEDURE GetSymbol;
PROCEDURE InsertId (BezPtr: KonstP);
PROCEDURE FindRecFields (BezPtr: KonstP; VAR BezPtr1: KonstP);
PROCEDURE FindeBez (IdKind: BezMenge; VAR BezPtr: KonstP);
PROCEDURE GetBounds (St: StP; VAR Minimum, Maximum: INTEGER);
PROCEDURE GLab (VAR NxtLab: INTEGER);
PROCEDURE Recover (ESets: Symbolmenge);
PROCEDURE GConstant (ESets: Symbolmenge; VAR St: StP; VAR ParKonst: Value);
FUNCTION HasEqualBounds (st1, st2: StP): BOOLEAN;
FUNCTION IsCompatible (st1, st2: StP): BOOLEAN;
FUNCTION Strng (St: StP): BOOLEAN;
FUNCTION IsFileOfFile (SavSp: StP): BOOLEAN;
PROCEDURE MovStk (i: INTEGER; VAR TopNew, StkMax: INTEGER);
PROCEDURE PutIC;
PROCEDURE GenDBG (VAR Name: ALPHA);
PROCEDURE GenPopDBG;
PROCEDURE G0 (Operator: OpRange; VAR TopNew, StkMax: INTEGER);
PROCEDURE G1 (Operator: OpRange; Param2: INTEGER;
              VAR TopNew, StkMax: INTEGER; VAR KonstPtr: CstPtrArray);
PROCEDURE G2 (Operator: OpRange; Param1, Param2: INTEGER;
              VAR TopNew, StkMax: INTEGER; VAR KonstPtr: CstPtrArray);
PROCEDURE GenTypIndicator (St: StP);
PROCEDURE G0T (Operator: OpRange; St: StP; VAR TopNew, StkMax: INTEGER);
PROCEDURE G1T (Operator: OpRange; Param2: INTEGER; St: StP;
               VAR TopNew, StkMax: INTEGER);
PROCEDURE G2T (Operator: OpRange; Param1, Param2: INTEGER;
               St: StP; VAR TopNew, StkMax: INTEGER);
PROCEDURE PushContents (VAR TopNew, StkMax: INTEGER;
                        VAR KonstPtr: CstPtrArray; VAR KonstPtrIndex: INTEGER);
PROCEDURE Store (VAR StoreAttr: Attribut; VAR TopNew, StkMax: INTEGER);
PROCEDURE PushAddress (VAR TopNew, StkMax: INTEGER;
                       VAR KonstPtr: CstPtrArray; VAR KonstPtrIndex: INTEGER);
PROCEDURE GJump (JumpTo: INTEGER; VAR TopNew, StkMax: INTEGER;
                 VAR KonstPtr: CstPtrArray; VAR KonstPtrIndex: INTEGER);
PROCEDURE GCase (Operator: OpRange; Param2: INTEGER;
                 VAR TopNew, StkMax: INTEGER);
PROCEDURE GProcCall (Operator: OpRange;
                     Param1, Param2: INTEGER; VAR TopNew, StkMax: INTEGER);
PROCEDURE CheckBounds (St: StP; VAR TopNew, StkMax: INTEGER);
PROCEDURE PushLabel (LabName: INTEGER);


IMPLEMENTATION

PROCEDURE LoadErrorText;

VAR
  f: TEXT;
  s: ErrorString;
  No: INTEGER;

BEGIN
  (* RESET(F,'errors.txt');  *)
  Assign(f,'errors.txt');
  ReSet(f);
  WasLoadErrorText := TRUE;
  MaxErrors := 0;
  WHILE NOT Eof(f) DO BEGIN
    MaxErrors := MaxErrors+1;
    ReadLn(f,No,s);
    WITH ErrorTable[MaxErrors] DO BEGIN
      ErrorNo := No;  ErrorText := s;
    END;
  END
END;


PROCEDURE WriteErrorText (No: INTEGER);


  PROCEDURE SearchNo (PassFuncProc, ub:INTEGER);

  VAR mid: INTEGER;

  BEGIN
    IF PassFuncProc <> ub THEN BEGIN
      mid := (PassFuncProc+ub) DIV 2;
      WITH ErrorTable[mid] DO
        IF No < ErrorNo THEN SearchNo(PassFuncProc,mid)
        ELSE IF No > ErrorNo THEN SearchNo(mid,ub)
        ELSE WriteLn(ErrorText);
    END
    ELSE WriteLn('>> unbekannter Fehler <<');
  END;

BEGIN
  SearchNo(1,MaxErrors)
END;


PROCEDURE WriteErrorLine;

VAR i: INTEGER;

BEGIN
  FOR i := 1 TO LinePos-1 DO Write(Line[i]);
  WriteLn;
END;


PROCEDURE Error (ErrorNo: INTEGER);

BEGIN
  IF ErrorIndex >= 9 THEN BEGIN
    ErrorList[10].No := 255;  ErrorIndex := 10
  END
  ELSE BEGIN
    ErrorIndex := ErrorIndex+1;
    ErrorList[ErrorIndex].No := ErrorNo
  END;
  ErrorList[ErrorIndex].Pos := SymbStart;
END;


PROCEDURE DoEoLn;

VAR LastPos, ActErrorPos, ActErrorNo, k: INTEGER;

BEGIN
  IF ErrorIndex > 0 THEN BEGIN
    WriteLn;  WriteLn;  WriteLn('Zeile: ',LineCount);
    WriteErrorLine;
    LastPos := 0;
    FOR k := 1 TO ErrorIndex DO BEGIN
      WITH ErrorList[k] DO BEGIN
        ActErrorPos := Pos;  ActErrorNo := No
      END;
      IF ActErrorPos <> LastPos THEN BEGIN
        Write('^':ActErrorPos,ActErrorNo:4);
        NoOfErrors := NoOfErrors+1;
        IF IsErrorText THEN BEGIN
          IF NOT WasLoadErrorText THEN LoadErrorText;
          WriteErrorText(ActErrorNo);
        END;
        WriteLn;
      END;
    END; (* FOR *)
    WriteLn;  ErrorIndex := 0;
  END;
  IF LineCount MOD 20 = 0 THEN BEGIN
    WriteLn;  Write('<',LineCount+1:5,'>');
  END;
  LineCount := LineCount+1;  Write('.');
  IthChar := 0;
END;


PROCEDURE EnterLine (c: CHAR);

BEGIN
  Line[LinePos] := c;  LinePos := LinePos+1
END;


PROCEDURE GetSymbol;

LABEL 1;

VAR
  i,k: INTEGER;
  Ziffer: PACKED ARRAY[1..StringLength] OF CHAR;
  Strng : PACKED ARRAY[1..StringLength] OF CHAR;
  SavKonstPtr: KonstPointer;
  Stop: BOOLEAN;
  Wert: Long_Integer;


  PROCEDURE GetChar;

  BEGIN
    IF EoL THEN BEGIN
      DoEoLn;  LinePos := 1;
    END;
    IF NOT EoF(Source) THEN BEGIN
      EoL := EoLn(Source);  Read(Source,Zeichen);
      IF Zeichen < ' ' THEN Zeichen := ' ';
      EnterLine(Zeichen);  IthChar := IthChar+1;
    END
    ELSE BEGIN
      WriteLn(' *** Dateiende erreicht');
      Stop := FALSE
    END;
  END;


  PROCEDURE CompilerOptionen;

  BEGIN
    REPEAT
      GetChar;
      IF (Zeichen <> '*') AND (Zeichen <> '}') THEN BEGIN
        CASE UpCase(Zeichen) OF
          'D' : BEGIN
                  GetChar;  Debug := Zeichen = '+'
                END;
          'C' : BEGIN
                  GetChar;  IsPrtCode := Zeichen = '+'
                END;
          'E' : BEGIN
                  GetChar;  IsErrorText := Zeichen = '+'
                END;
        END;
        GetChar;
      END;
    UNTIL Zeichen <> ',';
  END;


  PROCEDURE SaveConstant (i: INTEGER);

  VAR k: INTEGER;

  BEGIN
    IF i > MaxZiffer THEN BEGIN
      Error(203);  LastConstVal.GanzeZahl := 0
    END
    ELSE
      WITH LastConstVal DO BEGIN
        Wert := 0;
        FOR k := 1 TO i DO
          Wert := Wert * 10 + (Ord(Ziffer[k]) - Ord('0'));
        IF Wert <= MaxInt THEN BEGIN
          Symb := IntConst;
          GanzeZahl := Wert;        (* GANZEZAHL := INT(WERT); *)
        END
        ELSE BEGIN
          Symb := LongConst;
          New(SavKonstPtr);
          SavKonstPtr^.KonstArt := Long;
          SavKonstPtr^.SavVal := Wert;
          LastConstVal.ValuePointer := SavKonstPtr;
        END;
      END
  END;


  PROCEDURE LiesZahl (VAR i,k: INTEGER);

  LABEL 1;

  VAR j: INTEGER;

  BEGIN
    Oper := NoOp;  i := 0;
    REPEAT
      i := i+1;
      IF i <= MaxZiffer THEN Ziffer[i] := Zeichen;
      GetChar
    UNTIL CharKind[Zeichen] <> Zahl;
    IF (Zeichen = '.') OR (UpCase(Zeichen) = 'E' ) THEN BEGIN
      k := i;
      IF Zeichen = '.' THEN BEGIN
        k := k+1;
        IF k <= MaxZiffer THEN Ziffer[k] := Zeichen;
        GetChar;
        IF Zeichen = '.' THEN BEGIN
          Zeichen := ':';  GOTO 1
        END;
        IF CharKind[Zeichen] <> Zahl THEN Error(201)
        ELSE
          REPEAT
            k := k+1;
            IF k <= MaxZiffer THEN Ziffer[k] := Zeichen;
            GetChar
          UNTIL CharKind[Zeichen] <> Zahl
    END;
    IF UpCase(Zeichen) = 'E' THEN BEGIN
      k := k+1;
      IF k <= MaxZiffer THEN Ziffer[k] := Zeichen;
      GetChar;
      IF(Zeichen = '+') OR (Zeichen = '-') THEN BEGIN
        k := k+1;
        IF k <= MaxZiffer THEN Ziffer[k] := Zeichen;
        GetChar
      END;
      IF CharKind[Zeichen] <> Zahl THEN Error(201)
      ELSE
        REPEAT
          k := k+1;
          IF k <= MaxZiffer THEN Ziffer[k] := Zeichen;
          GetChar
        UNTIL CharKind[Zeichen] <> Zahl
    END;
    New(SavKonstPtr);  Symb := RealConst;  SavKonstPtr^.KonstArt := Reell;
    WITH SavKonstPtr^ DO BEGIN
      FOR j := 1 TO StringLength DO RVal[j] := ' ';
      IF k <= MaxZiffer THEN
        FOR j := 2 TO k+1 DO RVal[j] := Ziffer[j-1]
      ELSE BEGIN
        Error(203);  RVal[2] := '0';  RVal[3] := '.';  RVal[4] := '0'
      END
    END;
    LastConstVal.ValuePointer := SavKonstPtr
    END
    ELSE
      1:
      SaveConstant(i)
  END;


  PROCEDURE LiesBezeichner (VAR k: INTEGER);

  LABEL 1;

  VAR i: INTEGER;

  BEGIN
    k := 0;
    REPEAT
      IF k < MaxId THEN BEGIN
        k := k+1;  Bez[k] := UpCase(Zeichen);
      END;
      GetChar
    UNTIL NOT (CharKind[UpCase(Zeichen)] IN [Buchst,Zahl]);
    IF k >= LBezLaenge THEN LBezLaenge := k
    ELSE BEGIN
      FOR i := k+1 TO LBezLaenge DO Bez[i] := ' ';
      LBezLaenge := k
    END;
    FOR i := RWindex[k] TO RWindex[k+1]-1 DO
      IF ResWord[i] = Bez THEN BEGIN
        Symb := ReSymb[i];  Oper := ROp[i];  GOTO 1
      END;
    Symb := Bezeich;  Oper := NoOp;
  1:
  END;


  PROCEDURE LiesString;

  VAR i: INTEGER;

  BEGIN
    Lgth := 0;  Symb := StringConst;  Oper := NoOp;
    REPEAT
      REPEAT
        GetChar;  Lgth := Lgth+1;
        IF Lgth <= StringLength THEN Strng[Lgth] := Zeichen
      UNTIL EoL OR (Zeichen = '''');
      IF EoL THEN Error(202)
      ELSE GetChar
    UNTIL Zeichen <> '''';
    Lgth := Lgth-1;
    IF Lgth = 0 THEN Error(205)
    ELSE IF Lgth = 1 THEN LastConstVal.GanzeZahl := Ord(Strng[1])
    ELSE BEGIN
      New(SavKonstPtr);  SavKonstPtr^.KonstArt := Strg;
      IF Lgth > StringLength THEN BEGIN
        Error(399);  Lgth := StringLength
      END;
      WITH SavKonstPtr^ DO BEGIN
        SLgth := Lgth;
        FOR i := 1 TO Lgth DO StringValue[i] := Strng[i]
      END;
      LastConstVal.ValuePointer := SavKonstPtr;
    END
  END;


BEGIN (* GetSymbol *)
  1:
  REPEAT
    WHILE (Zeichen = ' ') AND NOT EoL DO GetChar;
    Stop := EoL;
    IF Stop THEN GetChar
  UNTIL NOT Stop;
  SymbStart := IthChar;
  IF CharKind[UpCase(Zeichen)] = Illegal THEN BEGIN
    Symb := OtherSymb;  Oper := NoOp;
    Error(399);  GetChar
  END
  ELSE
    CASE CharKind[UpCase(Zeichen)] OF
      Buchst     : LiesBezeichner(k);
      Zahl       : LiesZahl(i,k);
      QuotMark   : LiesString;
      Colon      : BEGIN
                     Oper := NoOp;  GetChar;
                     IF Zeichen = '=' THEN BEGIN
                       Symb := AssignTo;  GetChar
                     END
                     ELSE Symb := ColonSymb
                   END;
      Period     : BEGIN
                     Oper := NoOp;  GetChar;
                     IF Zeichen = '.' THEN BEGIN
                       Symb := ColonSymb;  GetChar
                     END
                     ELSE Symb := UpTo
                   END;
      LessThan   : BEGIN
                     GetChar;  Symb := VergleichOp;
                     IF Zeichen = '=' THEN BEGIN
                       Oper := LessOp;  GetChar
                     END
                     ELSE IF Zeichen = '>' THEN BEGIN
                       Oper := NotEqualOp;  GetChar
                     END
                     ELSE Oper := LessThanOp
                   END;
      GreaterThan: BEGIN
                     GetChar;  Symb := VergleichOp;
                     IF Zeichen = '=' THEN BEGIN
                       Oper := GrEqualOp;  GetChar
                     END
                     ELSE Oper := GrThanOp
                   END;
      oBrace     : BEGIN
                     GetChar;
                     IF Zeichen = '*' THEN BEGIN
                       GetChar;
                       IF Zeichen = '$' THEN CompilerOptionen;
                       REPEAT
                         WHILE (Zeichen <> '*') AND NOT Eof(Source) DO GetChar;
                         GetChar
                       UNTIL (Zeichen = ')') OR Eof(Source);
                       GetChar;
                       GOTO 1
                     END;
                     Symb := lBraces;  Oper := NoOp
                   END;
      Special    : BEGIN
                     Symb := StdSymb[Zeichen];  Oper := OpS[Zeichen];
                     GetChar
                   END;
      Blank      : Symb := OtherSymb;
      lBrace     : BEGIN
                     GetChar;
                     IF Zeichen = '$' THEN CompilerOptionen;
                     WHILE (Zeichen <> '}') AND NOT Eof(Source) DO GetChar;
                     GetChar;
                     GOTO 1
                   END;
    END;
END; (* GetSymbol *)


PROCEDURE InsertId (BezPtr: KonstP);

VAR Nam: ALPHA;  locc, locc1: KonstP;  IsLeftSon: BOOLEAN;

BEGIN
  Nam := BezPtr^.Name;
  locc := DispVec[DispTop].FirstDeclID;
  IF locc = NIL THEN
    DispVec[DispTop].FirstDeclID := BezPtr
  ELSE BEGIN
    REPEAT
      locc1 := locc;
      IF locc^.Name = Nam THEN BEGIN
        Error(101);  locc := locc^.RightSon;  IsLeftSon := FALSE
      END
      ELSE IF locc^.Name<Nam THEN BEGIN
        locc := locc^.RightSon;  IsLeftSon := FALSE
      END
      ELSE BEGIN
        locc := locc^.LeftSon;  IsLeftSon := TRUE
      END
    UNTIL locc = NIL;
    IF IsLeftSon THEN locc1^.LeftSon := BezPtr
    ELSE locc1^.RightSon := BezPtr
  END;
  BezPtr^.LeftSon := NIL;  BezPtr^.RightSon := NIL;
END;


PROCEDURE FindRecFields (BezPtr: KonstP; VAR BezPtr1: KonstP);

LABEL 1;

BEGIN
  WHILE BezPtr <> NIL DO
    IF BezPtr^.Name = Bez THEN GOTO 1
    ELSE IF BezPtr^.Name<Bez THEN BezPtr := BezPtr^.RightSon
    ELSE BezPtr := BezPtr^.LeftSon;
  1:
  BezPtr1 := BezPtr;
END;


PROCEDURE FindeBez (IdKind: BezMenge; VAR BezPtr: KonstP);

LABEL 1;

VAR locc: KonstP;
    Ende: BOOLEAN;

BEGIN
  LastBst := DispTop;
  Ende := FALSE;
  WHILE NOT Ende DO BEGIN
    locc := DispVec[LastBst].FirstDeclID;
    WHILE locc <> NIL DO
      IF locc^.Name = Bez THEN
        IF locc^.Klass IN IdKind THEN GOTO 1
        ELSE BEGIN
          IF AllowsErrors THEN Error(103);
          locc := locc^.RightSon
        END
      ELSE IF locc^.Name < Bez THEN
        locc := locc^.RightSon
      ELSE locc := locc^.LeftSon;
    IF LastBst = 0 THEN Ende := TRUE
    ELSE LastBst := LastBst-1
  END;
  IF AllowsErrors THEN BEGIN
    Error(104);
    IF TypeClass IN IdKind THEN locc := UTypPtr
    ELSE IF VarClass IN IdKind THEN locc := UVarPtr
    ELSE IF FieldClass IN IdKind THEN locc := UFldPtr
    ELSE IF KonstKlasse IN IdKind THEN locc := UCstPtr
    ELSE IF ProcClass IN IdKind THEN locc := UPrcPtr
    ELSE locc := UFctPtr;
  END;
  1:
  BezPtr := locc;
END;


PROCEDURE GetBounds (St: StP; VAR Minimum, Maximum: INTEGER);

BEGIN
  Minimum := 0;  Maximum := 0;
  IF St <> NIL THEN
    WITH ST^ DO
      IF Form = SubRange THEN BEGIN
        Minimum := Min.GanzeZahl;  Maximum := Max.GanzeZahl
      END
      ELSE IF St = CharPtr THEN BEGIN
        Minimum := OrdMinChar;  Maximum := OrdMaxChar;
      END
      ELSE IF ScalConst <> NIL THEN
        Maximum := ScalConst^.Values.GanzeZahl;
END;


PROCEDURE GLab (VAR NxtLab: INTEGER);

BEGIN
  IntLabel := IntLabel+1;
  NxtLab := IntLabel;
END;


PROCEDURE Recover (ESets: Symbolmenge);

BEGIN
  IF NOT Eof(Source) THEN BEGIN
    WHILE NOT(Symb IN ESets) AND (NOT Eof(Source)) DO GetSymbol;
    IF NOT (Symb IN ESets) THEN GetSymbol
  END;
END;


PROCEDURE GConstant (ESets: Symbolmenge;
                     VAR St: StP;
                     VAR ParKonst: Value);

VAR
  SavSp: StP;
  locc: KonstP;
  Sign: (NoSign,Pos,UnMinus);
  SavKonstPtr: KonstPointer;
  i: 2..StringLength;

BEGIN
  SavSp := NIL;  ParKonst.GanzeZahl := 0;
  IF NOT(Symb IN KonstStartSy) THEN BEGIN
    Error(50);  Recover(ESets+KonstStartSy)
  END;
  IF Symb IN KonstStartSy THEN BEGIN
    IF Symb = StringConst THEN BEGIN
      IF Lgth = 1 THEN SavSp := CharPtr
      ELSE BEGIN
        New(SavSp);
        WITH SavSp^ DO BEGIN
          ElemType := CharPtr;  IndexType := NIL;
          Size := Lgth*CharSize;  Form := Arrays
        END
      END;
      ParKonst := LastConstVal;  GetSymbol
    END
    ELSE BEGIN
      Sign := NoSign;
      IF (Symb = AddOpr) AND (Oper IN [Plus,Minus]) THEN BEGIN
        IF Oper = Plus THEN Sign := Pos ELSE Sign := UnMinus;
        GetSymbol
      END;
      IF Symb = Bezeich THEN BEGIN
        FindeBez([KonstKlasse],locc);
        WITH locc^ DO BEGIN
          SavSp := BezType;  ParKonst := Values
        END;
        IF Sign <> NoSign THEN
          IF SavSp = IntPtr THEN BEGIN
            IF Sign = UnMinus THEN
              ParKonst.GanzeZahl := -ParKonst.GanzeZahl
          END
          ELSE IF SavSp = RealPtr THEN BEGIN
            IF Sign = UnMinus THEN BEGIN
              New(SavKonstPtr);
              IF ParKonst.ValuePointer^.RVal[1] = '-' THEN
                SavKonstPtr^.RVal[1] := '+'
              ELSE SavKonstPtr^.RVal[1] := '-';
              FOR i := 2 TO StringLength DO
                SavKonstPtr^.RVal[i] := ParKonst.ValuePointer^.RVal[i];
              ParKonst.ValuePointer := SavKonstPtr;
            END
          END
          ELSE Error(105);
        GetSymbol;
      END
      ELSE IF Symb = IntConst THEN BEGIN
        IF Sign = UnMinus THEN
          LastConstVal.GanzeZahl := -LastConstVal.GanzeZahl;
        SavSp := IntPtr;  ParKonst := LastConstVal;  GetSymbol
      END
      ELSE IF Symb = RealConst THEN BEGIN
        IF Sign=UnMinus THEN
          LastConstVal.ValuePointer^.RVal[1] := '-';
        SavSp := RealPtr;  ParKonst := LastConstVal;  GetSymbol
      END
      ELSE BEGIN
        Error(106);  Recover(ESets)
      END
    END;
    IF NOT (Symb IN ESets) THEN BEGIN
      Error(6);  Recover(ESets)
    END
  END;
  St := SavSp;
END;


FUNCTION HasEqualBounds (st1, st2: StP): BOOLEAN;

VAR lmin1, lmin2, lmax1, lmax2: INTEGER;

BEGIN
  IF (st1 = NIL) OR (st2 = NIL) THEN HasEqualBounds := TRUE
  ELSE BEGIN
    GetBounds(st1,lmin1,lmax1);
    GetBounds(st2,lmin2,lmax2);
    HasEqualBounds := (lmin1 = lmin2) AND (lmax1 = lmax2)
  END;
END;


FUNCTION IsCompatible (st1, st2: StP): BOOLEAN;

VAR
  nxt1, nxt2: KonstP;
  compatible: BOOLEAN;
  LTestP1, LTestP2: TestP;

BEGIN
  IF st1 = st2 THEN IsCompatible := TRUE
  ELSE IF (st1 <> NIL) AND (st2 <> NIL) THEN
   IF St1^.Form = St2^.Form THEN
     CASE St1^.Form OF
       Scalar  : IsCompatible := FALSE;
       SubRange: IsCompatible := IsCompatible(St1^.RangeType,St2^.RangeType);
       Pointers: BEGIN
                   compatible := FALSE;
                   LTestP1 := GlobTestP;
                   LTestP2 := GlobTestP;
                   WHILE LTestP1 <> NIL DO
                     WITH LTestP1^ DO BEGIN
                       IF (ElT1 = St1^.ElType) AND (ElT2 = St2^.ElType) THEN
                         compatible := TRUE;
                       LTestP1 := LastTestP
                     END;
                   IF NOT compatible THEN BEGIN
                     New(LTestP1);
                     WITH LTestP1^ DO BEGIN
                       ElT1 := St1^.ElType;
                       ElT2 := St2^.ElType;
                       LastTestP := GlobTestP
                     END;
                     GlobTestP := LTestP1;
                     compatible := IsCompatible(St1^.ElType,St2^.ElType)
                   END;
                   IsCompatible := compatible;  GlobTestP := LTestP2
                 END;
       Power   : IsCompatible := IsCompatible(St1^.ElemSet,St2^.ElemSet);
       Arrays  : BEGIN
                   compatible := IsCompatible(St1^.ElemType,St2^.ElemType)
                                 AND IsCompatible(St1^.IndexType,St2^.IndexType);
                   IsCompatible := compatible AND (St1^.Size=St2^.Size) AND
                                   HasEqualBounds(St1^.IndexType,St2^.IndexType)
                 END;
       Records : BEGIN
                   nxt1 := St1^.FirstField;  nxt2 := St2^.FirstField;
                   compatible := TRUE;
                   WHILE (nxt1 <> NIL) AND (nxt2 <> NIL) DO BEGIN
                     compatible := compatible
                                   AND IsCompatible(Nxt1^.BezType,Nxt2^.BezType);
                     nxt1 := Nxt1^.Next;  nxt2 := Nxt2^.Next
                   END;
                   IsCompatible := compatible AND (nxt1 = NIL) AND (nxt2 = NIL)
                                   AND (St1^.RecVar = NIL) AND (St2^.RecVar = NIL)
                 END;
       Files   : IsCompatible := IsCompatible(St1^.FileType,St2^.FileType)
     END
   ELSE IF St1^.Form = SubRange THEN
     IsCompatible := IsCompatible(St1^.RangeType,st2)
   ELSE
     IF St2^.Form = SubRange THEN
       IsCompatible := IsCompatible(st1,St2^.RangeType)
     ELSE IsCompatible := FALSE
   ELSE IsCompatible := TRUE;
END;


FUNCTION Strng (St: StP): BOOLEAN;

BEGIN
  Strng := FALSE;
  IF St <> NIL THEN
    IF ST^.Form = Arrays THEN
      IF IsCompatible(ST^.ElemType,CharPtr) THEN Strng := TRUE;
END;


FUNCTION IsFileOfFile (SavSp: StP): BOOLEAN;

LABEL 1;

VAR SavSP1: StP;  First: KonstP;  Erg: BOOLEAN;

BEGIN
  Erg := FALSE;
  IF SavSp <> NIL THEN
    IF SavSp^.Form = Files THEN Erg := TRUE
    ELSE IF SavSp^.Form >= Power THEN
      WITH SavSp^ DO BEGIN
        CASE Form OF
          Pointers: SavSP1 := ElType;
          Power   : SavSP1 := ElemSet;
          Arrays  : BEGIN
                      Erg := IsFileOfFile(ElemType);
                      IF NOT Erg THEN Erg := IsFileOfFile(IndexType);
                      GOTO 1
                    END;
          Records : BEGIN
                      Erg := IsFileOfFile(RecVar);
                      First := FirstField;
                      WHILE NOT Erg AND (First <> NIL) DO BEGIN
                        Erg := IsFileOfFile(First^.BezType);
                        IF NOT Erg THEN First := First^.Next
                      END;
                      GOTO 1;
                    END;
          TagFld  : BEGIN
                      Erg := IsFileOfFile(TagFieldP^.BezType);
                      IF NOT Erg THEN Erg := IsFileOfFile(FirstVar);
                      GOTO 1
                    END;
          Variant : BEGIN
                      Erg := IsFileOfFile(NxtVar);
                      IF NOT Erg THEN Erg := IsFileOfFile(VarTVar);
                      GOTO 1
                    END;
        END;
        Erg := IsFileOfFile(SavSP1);
      END;
  1:
  IsFileOfFile := Erg;
END;


PROCEDURE MovStk (i: INTEGER; VAR TopNew, StkMax: INTEGER);

BEGIN
  TopNew := TopNew + StkMov[i] * MaxStack;
  IF TopNew > StkMax THEN StkMax := TopNew;
END;


PROCEDURE PutIC;

BEGIN
  IF (ICount MOD 10) = 0 THEN WriteLn(Dat,'i',ICount:5);
END;


PROCEDURE GenDBG (VAR Name: ALPHA);

BEGIN
  IF IsPrtCode AND Debug THEN WriteLn(Dat,' dbg ''' ,Name,'''');
END;


PROCEDURE GenPopDBG;

BEGIN
  IF IsPrtCode AND Debug THEN WriteLn(Dat,' pop');
END;


PROCEDURE G0 (Operator: OpRange; VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;  WriteLn(Dat,PCo[Operator]:4)
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE G1 (Operator: OpRange;
              Param2: INTEGER;
              VAR TopNew, StkMax: INTEGER;
              VAR KonstPtr: CstPtrArray);

VAR k: INTEGER;

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;  Write(Dat,PCo[Operator]:4);
    IF Operator = 30 THEN BEGIN
      WriteLn(Dat,StdNames[Param2]:12);
      TopNew := TopNew + StdStkMov[Param2] * MaxStack;
      IF TopNew > StkMax THEN StkMax := TopNew
    END
    ELSE BEGIN
      IF Operator = 38 THEN BEGIN
        Write(Dat,' ''' );
        WITH KonstPtr[Param2]^ DO BEGIN
          FOR k := 1 TO SLgth DO Write(Dat,StringValue[k]:1);
        END;
        WriteLn(Dat,'''')
      END
      ELSE IF Operator = 42 THEN WriteLn(Dat,Chr(Param2))
      ELSE WriteLn(Dat,Param2:12);
      MovStk(Operator,TopNew,StkMax);
    END
  END;
  ICount := ICount+1;
END;


PROCEDURE G2 (Operator: OpRange;
              Param1, Param2: INTEGER;
              VAR TopNew, StkMax: INTEGER;
              VAR KonstPtr: CstPtrArray);

VAR k: INTEGER;

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;  Write(Dat,PCo[Operator]:4);
    CASE Operator OF
                    30 : WriteLn(Dat,StdNames[Param1]:12,' ',Param2);
           45,50,54,56 : WriteLn(Dat,' ',Param1:3,Param2:8);
      47,48,49,52,53,55: BEGIN
                           Write(Dat,Chr(Param1));
                           IF Chr(Param1) = 'm' THEN Write(Dat,Param2:11);
                           WriteLn(Dat)
                         END;
                     51: CASE Param1 OF
                           1: WriteLn(Dat,'i ',Param2);
                           2: BEGIN
                                Write(Dat,'r ');
                                WITH KonstPtr[Param2]^ DO
                                  FOR k := 1 TO StringLength DO
                                    Write(Dat,RVal[k]);
                                WriteLn(Dat)
                              END;
                           3: WriteLn(Dat,'b ',Param2);
                           4: WriteLn(Dat,'n');
                           5: BEGIN
                                Write(Dat,'(');
                                WITH KonstPtr[Param2]^ DO
                                  FOR k := SetMin TO SetMax DO
                                    IF k IN Menge THEN Write(Dat,k:4,' ');
                                WriteLn(Dat,')')
                              END;
                           6: WriteLn(Dat,'c ''':3,Chr(Param2),'''');
                           7: WriteLn(Dat,'l ',Param2);
                         END
    END
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE GenTypIndicator (St: StP);

BEGIN
  IF St <> NIL THEN
    WITH St^ DO
      CASE Form OF
          Scalar: IF St = IntPtr THEN Write(Dat,'i')
                  ELSE IF St = BooleanPtr THEN Write(Dat,'b')
                  ELSE IF St = CharPtr THEN Write(Dat,'c')
                  ELSE IF St = LongPtr THEN Write(Dat,'l')
                  ELSE IF ScalKind = Declared THEN Write(Dat,'i')
                  ELSE Write(Dat,'r');
        SubRange: GenTypIndicator(RangeType);
        Pointers: Write(Dat,'a');
        Power   : Write(Dat,'s');
        Records,
        Arrays  : Write(Dat,'m');
        Files,
        TagFld,
        Variant : Error(500)
    END;
END;


PROCEDURE G0T (Operator: OpRange;
               St: StP;
               VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;
    Write(Dat,PCo[Operator]:4);
    GenTypIndicator(St);
    WriteLn(Dat);
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE G1T (Operator: OpRange;
               Param2: INTEGER;
               St: StP;
               VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;
    Write(Dat,PCo[Operator]:4);
    GenTypIndicator(St);
    WriteLn(Dat,Param2:11)
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE G2T (Operator: OpRange;
               Param1, Param2: INTEGER;
               St: StP;
               VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;
    Write(Dat,PCo[Operator]:4);
    GenTypIndicator(St);
    WriteLn(Dat,Param1:3 (* +5 * Ord(Abs(FP1)>99) *),Param2:8)
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE PushContents (VAR TopNew, StkMax:INTEGER;
                        VAR KonstPtr: CstPtrArray;
                        VAR KonstPtrIndex: INTEGER);

BEGIN
  WITH Attr DO
    IF TyPtr <> NIL THEN BEGIN
      CASE Art OF
         IsKonst: IF (TyPtr^.Form = Scalar) AND (TyPtr <> RealPtr) THEN
                    IF TyPtr = BooleanPtr THEN
                      G2(51,3,KonstVal.GanzeZahl,TopNew,StkMax,KonstPtr)
                    ELSE IF TyPtr = CharPtr THEN
                      G2(51,6,KonstVal.GanzeZahl,TopNew,StkMax,KonstPtr)
                    ELSE IF TyPtr = LongPtr THEN
                      WriteLn(Dat,' ldcl ',KonstVal.ValuePointer^.SavVal)
                    ELSE G2(51,1,KonstVal.GanzeZahl,TopNew,StkMax,KonstPtr)
                  ELSE IF TyPtr = NilPtr THEN
                    G2(51,4,0,TopNew,StkMax,KonstPtr)
                  ELSE IF KonstPtrIndex >= MaxKonstants THEN Error(254)
                  ELSE BEGIN
                    KonstPtrIndex := KonstPtrIndex+1;
                    KonstPtr[KonstPtrIndex] := KonstVal.ValuePointer;
                    IF TyPtr = RealPtr THEN
                      G2(51,2,KonstPtrIndex,TopNew,StkMax,KonstPtr)
                    ELSE
                      G2(51,5,KonstPtrIndex,TopNew,StkMax,KonstPtr)
                  END;
           IsVar: CASE Zugriff OF
                      Direkt: IF VarBSt <= 1 THEN
                                G1T(39,OffSet,TyPtr,TopNew,StkMax)
                              ELSE
                                G2T(54,Bst-VarBSt,OffSet,TyPtr,TopNew,StkMax);
                    Indirekt: G1T(35,IOffSet,TyPtr,TopNew,StkMax);
                     Indexed: Error(400)
                  END;
          IsExpr:
      END;
      Art := IsExpr
    END;
END;


PROCEDURE Store (VAR StoreAttr: Attribut; VAR TopNew, StkMax: INTEGER);

BEGIN
  WITH StoreAttr DO
    IF TyPtr <> NIL THEN
      CASE Zugriff OF
          Direkt: IF VarBSt <= 1 THEN G1T(43,OffSet,TyPtr,TopNew,StkMax)
                  ELSE G2T(56,Bst-VarBSt,OffSet,TyPtr,TopNew,StkMax);
        Indirekt: IF IOffSet <> 0 THEN Error(400)
                  ELSE G0T(26,TyPtr,TopNew,StkMax);
         Indexed: Error(400)
      END;
END;


PROCEDURE PushAddress (VAR TopNew, StkMax: INTEGER;
                       VAR KonstPtr: CstPtrArray;
                       VAR KonstPtrIndex: INTEGER);

BEGIN
  WITH Attr DO
    IF TyPtr <> NIL THEN BEGIN
      CASE Art OF
        IsKonst: IF Strng(TyPtr) THEN
                   IF KonstPtrIndex >= MaxKonstants THEN Error(254)
                   ELSE BEGIN
                     KonstPtrIndex := KonstPtrIndex+1;
                     KonstPtr[KonstPtrIndex] := KonstVal.ValuePointer;
                     G1(38,KonstPtrIndex,TopNew,StkMax,KonstPtr)
                   END
                 ELSE Error(400);
          IsVar: CASE Zugriff OF
                     Direkt: IF VarBSt <= 1 THEN
                               G1(37,OffSet,TopNew,StkMax,KonstPtr)
                             ELSE
                               G2(50,Bst-VarBSt,OffSet,TopNew,StkMax,KonstPtr);
                   Indirekt: IF IOffSet <> 0 THEN
                               G1T(34,IOffSet,NilPtr,TopNew,StkMax);
                    Indexed: Error(400)
                 END;
        IsExpr : Error(400)
      END;
      Art := IsVar; Zugriff := Indirekt; IOffSet := 0
    END;
END;


PROCEDURE GJump (JumpTo: INTEGER;
                 VAR TopNew, StkMax: INTEGER;
                 VAR KonstPtr: CstPtrArray;
                 VAR KonstPtrIndex:INTEGER);

BEGIN
  PushContents(TopNew,StkMax,KonstPtr,KonstPtrIndex);
  IF Attr.TyPtr <> NIL THEN
    IF Attr.TyPtr <> BooleanPtr THEN Error(144);
  IF IsPrtCode THEN BEGIN
    PutIC;  WriteLn(Dat,PCo[33]:4,' l':8, JumpTo:4)
  END;
  ICount := ICount+1;  MovStk(33,TopNew,StkMax);
END;


PROCEDURE GCase (Operator: OpRange;
                 Param2: INTEGER;
                 VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    PutIC;  WriteLn(Dat,PCo[Operator]:4,' l':8, Param2:4)
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE GProcCall (Operator: OpRange;
                     Param1, Param2: INTEGER;
                     VAR TopNew, StkMax: INTEGER);

BEGIN
  IF IsPrtCode THEN BEGIN
    (* PutIC;  ABGEAENDERT AM 27.02.87 *)
    WriteLn(Dat,PCo[Operator]:4,Param1:4,'l':4, Param2:4)
  END;
  ICount := ICount+1;  MovStk(Operator,TopNew,StkMax);
END;


PROCEDURE CheckBounds (St: StP; VAR TopNew, StkMax: INTEGER);

VAR lmin, lmax: INTEGER;

BEGIN
  IF St <> NIL THEN
    IF St <> IntPtr THEN
      IF St <> RealPtr THEN
       IF St <> LongPtr THEN
         IF St^.Form <=  SubRange THEN BEGIN
           GetBounds(St,lmin,lmax);
           G2T(45,lmin,lmax,St,TopNew,StkMax)
         END;
END;


PROCEDURE PushLabel (LabName:INTEGER);

BEGIN
  IF IsPrtCode THEN WriteLn(Dat,'l',LabName:4);
END;

BEGIN
END.