(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     MVCP4:                            *
*                                       *
*     Pass 4                            *
*     Code generation                   *
*                                       *
*     Version 3.1 of  1-FEB-1983        *
*     Update    5 of 21-SEP-1983        *
*                                       *
****************************************)

(****************************************
* Updates:                              *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  1 of 29-APR-1983 by J. Koch      *
*  Error in codegeneration for real     *
*  comparisons.                         *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  2 of 24-MAY-1983 by M. Mall      *
*  Error in codegeneration in parameter *
*  passing for real constants.          *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  3 of 13-JUN-1983 by J. Koch      *
*  Error in codegeneration in parameter *
*  passing for real expressions         *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  4 of 28-JUN-1983 by M. Mall      *
*  Error in codegeneration for "*"      *
*  operator on sets.                    *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  5 of 21-SEP-1983 by J. Koch      *
*  Error in codegeneration for          *
*  array access with index check        *
****************************************)

IMPLEMENTATION MODULE MVCP4; (* VAX: J. Koch, M. Mall, EK *)

  IMPORT MVCompiler,MVCMnemonicsAndTraps,MVCIO4,
         MVCAttributHandling,MVCR4,MVCLi4,Storage;


  FROM MVCompiler IMPORT levmax,maxcard,maxint,minint,maxchar,wordsize,basemax,
                         Idptr,Stptr,Stringptr,Structform,
                         Idclass,Varkind,Kindvar,Parkind,Stpures,Stfuncs,
                         Constval,
                         boolptr,charptr,intptr,cardptr,realptr,
                         addrptr,wordptr,byteptr,shortwordptr,
                         Symbol;
  FROM MVCMnemonicsAndTraps IMPORT Mnemos, Traps;
  FROM MVCIO4 IMPORT sy, val, nptr, csptr, testIndex,
                     GetSy, StartIO, Assert, CompError, Error;
  FROM MVCAttributHandling IMPORT ArrayType,SetType,BooleanType,SignedType,
                                  SimpleType,DynArrayType,WordType,RealType,
                                  AttrMode,Condition,ModeSet,RegSet,Attribut,
                                  lc,StackTop,loglevel,
                                  PutB,PutW,PutL,Put2B,
                                  UpdateCondJump,UpdateFwrdJump,MarkJump,
                                  MarkCondJump,GenJump,BranchTooLong,MoveCode,
                                  GenEntry,GenExit,PutBlock,ResetTop,
                                  CallProc,CallModSys,
                                  NewReg,IsRegMode,AbsRegMode,ReturnAtReg,
                                  RegAt,ConstAt,AdMode,SelectOpcode,
                                  Op1,Op2,Op3,Op4,Op1toReg,
                                  Op2or3,Op2C,TypeSize,
                                  MoveValue,MoveAddr,PushConst,
                                  PushValue,PushAddr,LoadAddr,LoadValue,
                                  PreLoad,PreMoveBools,ConvToCond,PosConstMul,
                                  NewWith,ReleaseWith,UseWith,
                                  MarkCondcode,ReleaseCondcode,UpdCondJump,
                                  LinkCondJump,CondJump,InvertJump,
                                  qptr,outloop,Mark,Update;
  FROM MVCR4 IMPORT OperationType,Push,Execute,PushExecute,PushPop, (*!U1!*)
                    PushPopParameter,FloatPush,PushPopTrunc,Save;
  FROM MVCLi4 IMPORT EnterLabel,CorrectLine,StartProcedure,
                     TerminateObjectFile,StartObjectFile;
  FROM Storage IMPORT ALLOCATE, DEALLOCATE;

  CONST
    oneword = 4;

  VAR
    level: INTEGER;
    blocknptr: Idptr; (*name of current block*)

  PROCEDURE GetDynBound(VAR fat: Attribut);
    (*change fat to high bound of dynamic array*)

  BEGIN
    WITH fat DO
      Assert(DynArrayType(typtr));
      Assert((mode = regmode) AND indirect AND indexed);
      indirect := FALSE;
      DEC(offset,oneword);
      typtr := cardptr;
    END
  END GetDynBound;

  PROCEDURE TypFunction(functyp: Stptr; VAR fat: Attribut);

  BEGIN
    WITH fat DO
      IF functyp^.size <> TypeSize(fat) THEN
        Assert ((functyp^.size <= oneword) AND (TypeSize(fat) <= oneword));
        LoadValue(fat)
      END;
      typtr := functyp;
    END
  END TypFunction;


  PROCEDURE CheckHighBound(VAR fatHigh,fatIndex: Attribut);
    (*If lower bound = 0, a 'CARDINAL-test'
      on high bound is sufficient!*)

    VAR
      llc: CARDINAL;

  BEGIN
    Assert(fatIndex.mode <> stackmode);
    Op2(SelectOpcode(CMPL,fatIndex),fatIndex,fatHigh);
    MarkCondJump(BLEQU,llc);
    CallModSys(IndexError);
    UpdateFwrdJump(llc);
  END CheckHighBound;


  PROCEDURE Designator(VAR fat: Attribut);

    PROCEDURE PreDesignator(VAR fat: Attribut);

      VAR
        loglevSave: INTEGER;
        lmpjSave: CARDINAL;

      PROCEDURE LoadDisplay(VAR freg: CARDINAL; flev: INTEGER);

      VAR
        lat: Attribut;

      BEGIN
        IF flev = level THEN
          freg := 13
        ELSE 
          RegAt(11(*R11*),addrptr,lat);
          lat.indexed := TRUE;
          lat.offset := -oneword*flev;
          LoadValue(lat);
          freg := lat.regnr;
        END;
      END LoadDisplay;

    BEGIN (*PreDesignator*)
      IF sy = field THEN
        UseWith(val.value,fat);
      ELSE 
        Assert(sy=namesy);
        WITH nptr^ DO
          IF (klass=funcs) OR (klass=pures) THEN
            WITH fat DO
              mode := cstpfmode;
              typtr := idtyp;
              anptr := nptr;
            END;
          ELSIF klass = types THEN
            GetSy;
            GetSy;
            MarkCondcode(loglevSave,lmpjSave);
            ExpressionB(fat);
            ReleaseCondcode(loglevSave,lmpjSave);
            TypFunction(idtyp,fat);
          ELSE (*klass = vars*)
            WITH fat DO
              typtr := idtyp;
              CASE state OF
                absolute: 
                  mode := absmode;
                  addr := vaddr |
                global: 
                  mode := globmode;
                  addr := vaddr;
                  anptr := nptr |
                separate: 
                  mode := extmode;
                  addr := vaddr;
                  anptr := nptr; |
                local: 
                  mode := regmode;
                  offset := vaddr;
                  indexed := TRUE;
                  indirect := vkind = varparam;
                  IF DynArrayType(idtyp) THEN
                    indirect := TRUE;
                    INC(offset,oneword);
                  END;
                  LoadDisplay(regnr,vlevel);
              END
            END (*WITH*)
          END
        END (*WITH*)
      END;
      GetSy
    END PreDesignator;

    PROCEDURE ConstOffset(VAR fat: Attribut; fconst: INTEGER);

    BEGIN
      WITH fat DO
        Assert(mode IN ModeSet{absmode,globmode,extmode,regmode});
        CASE mode OF
          absmode,globmode,extmode: (*$T-*) INC(addr,fconst) (*$T=*) |
          regmode: IF indirect AND ((offset<>0) OR (fconst<>0)) THEN
                     LoadAddr(fat)
                   END;
                   (*$T-*) INC(offset,fconst) (*$T=*)
        END
      END
    END ConstOffset;

    PROCEDURE VarOffset(VAR fat,fat1: Attribut);

      VAR
        loffset: INTEGER;

    BEGIN
      WITH fat DO
        Assert(mode IN ModeSet{absmode,globmode,extmode,regmode});
        IF mode = regmode THEN
          IF indirect THEN
            LoadAddr(fat)
          END;
          Assert(indexed AND NOT indirect);
          loffset := offset;
          indexed := FALSE;
          Op2or3(ADDL2,fat1,fat);
          ReturnAtReg(fat1)
        ELSE 
          IF NOT AbsRegMode(fat1) THEN
            LoadValue(fat1)
          END;
          IF mode = absmode THEN
            loffset := addr
          ELSE (*globmode,extmode*)
            Put2B(MOVAB,40H+fat1.regnr);
            AdMode(fat);
            AdMode(fat1);                 (* MOVAB reladdr[fat1],fat1 *)
            loffset := 0
          END;
          RegAt(fat1.regnr,typtr,fat);
        END;
        indexed := TRUE;
        offset := loffset;
      END
    END VarOffset;

    VAR
      lmpjSave: CARDINAL;
      loglevSave: INTEGER;
      lower,lsize: CARDINAL;
      atHigh,atLow,atSize,atOffset,atIndex: Attribut;

  BEGIN (*Designator*)
    PreDesignator(fat);
    WHILE (sy = lbrack) OR (sy = arrow) OR (sy = period) DO
      IF sy = lbrack THEN (*array element*)
        MarkCondcode(loglevSave,lmpjSave);
        GetSy;
        ExpressionB(atIndex);
        WITH fat DO
          Assert(ArrayType(typtr));
          WITH typtr^ DO
            lsize := elp^.size;
            IF dyn THEN
              lower := 0;
              atHigh := fat;
              GetDynBound(atHigh);
            ELSE 
              WITH ixp^ DO
                Assert(form = subranges);
                lower := min;
                ConstAt(max,scalp,atHigh);
              END;
            END;
            IF atIndex.mode = cstmode THEN
              IF dyn THEN
                IF SignedType(atIndex.typtr) AND
                   (atIndex.valu < 0) THEN
                  Error(300); (*index out of range*)
                END;
                IF testIndex THEN
                  CheckHighBound(atHigh,atIndex)
                END
              ELSE (*NOT dyn*)
                (*$T-*) DEC(atIndex.valu,lower);
                IF CARDINAL(atIndex.valu) >
                   CARDINAL(atHigh.valu) - lower THEN
                  Error(300); (*index out of range*)
                END; (*$T=*)
              END;
              ConstOffset(fat,atIndex.valu*INTEGER(lsize));
            ELSE 
              IF TypeSize(atIndex) <> oneword THEN
                LoadValue(atIndex);
              END;
              atIndex.typtr := cardptr;
              IF testIndex THEN
                ConstAt(lower,cardptr,atLow);
                ConstAt(-INTEGER(lower),cardptr,atOffset);
                ConstAt(lsize,cardptr,atSize);
                atHigh.typtr := cardptr;                           (*!U5!*)
                Op4(INDEX,atIndex,atLow,atHigh,atSize);
                AdMode(atOffset);
                IF NOT IsRegMode(atIndex) THEN
                  atIndex.regnr := NewReg();
                END;
                RegAt(atIndex.regnr,atIndex.typtr,atIndex);
                AdMode(atIndex)
              ELSE 
                IF (mode IN ModeSet{absmode,globmode,extmode})
                   OR ((mode = regmode) AND NOT indirect) THEN
                  ConstOffset(fat,-INTEGER(lower*lsize))
                ELSE 
                  IF lower <> 0 THEN
                    IF (lower = 1) AND AbsRegMode(atIndex) THEN
                      Op1(SelectOpcode(DECL,atIndex),atIndex)
                    ELSE Op2C(SelectOpcode(SUBL2,atIndex),lower,atIndex)
                    END;
                  END;
                END;
                PosConstMul(atIndex,lsize);
              END;
              VarOffset(fat,atIndex)
            END;
            typtr := elp
          END (*WITH typtr^*);
        END (*WITH fat*);
        ReleaseCondcode(loglevSave,lmpjSave);
        Assert( sy = rbrack);
        GetSy; (*rbrack*)
      ELSIF sy = arrow THEN (*variable accessed via pointer*)
        GetSy;
        WITH fat DO
          IF (mode<>regmode) OR indirect THEN
            LoadValue(fat);
            (*no pointer test*)
            indexed := FALSE;
          END;
          IF typtr = addrptr THEN
            typtr := wordptr
          ELSE Assert((typtr <> NIL) AND (typtr^.form = pointers));
            typtr := typtr^.elemp;
          END;
          indirect := TRUE;
        END
      ELSE (*sy = period: record field*)
        GetSy;
        Assert(nptr<>NIL);
        WITH nptr^ DO
          ConstOffset(fat,fldaddr);
          fat.typtr := idtyp
        END;
        GetSy;
      END;
    END;
  END Designator;

  PROCEDURE Factor(VAR fat: Attribut);

  BEGIN
    INC(loglevel);
    IF sy = lparent THEN
      GetSy;
      Expression(fat);
      GetSy; (* rparent *)
    ELSIF sy = notsy THEN
      GetSy;
      Factor(fat);
      IF SetType(fat.typtr) THEN
        Op1toReg(SelectOpcode(MCOML,fat),fat);
      ELSE 
        ConvToCond(fat);
        InvertJump(fat);
      END;
    ELSIF (sy = namesy) OR (sy = field) THEN
      Designator(fat);
      IF sy = lparent THEN (*function call*)
        GetSy;
        ProcFuncCall(fat)
      END;
    ELSE Assert(sy = anycon); (*constant*)
      WITH fat DO
        typtr := csptr;
        WITH val DO
          IF ArrayType(typtr) THEN
            mode := cststringmode;
            addr := svalue^.loadoffset;
          ELSIF typtr = realptr THEN
            mode := cstrealmode;
            rvalu := rvalue^;
          ELSE mode := cstmode;
            valu := value;
          END;
        END;
      END;
      GetSy
    END;
    DEC(loglevel)
  END Factor;

  PROCEDURE Term(VAR fat: Attribut);

    VAR
      lat: Attribut;
      opsy: Symbol;

    PROCEDURE DivMod(VAR fat: Attribut; opsy: Symbol);

      VAR
        lat,atR1,atR0: Attribut;
        signedArith: BOOLEAN; (* = use signed arithmetic*)
        llc: CARDINAL;

    BEGIN (*assume that R1 is never locked*)
      Factor(lat); (*fat DivMod lat*)
      WITH fat DO
        signedArith := SignedType(typtr) OR SignedType(lat.typtr);
        IF signedArith THEN
          typtr := intptr
        ELSE typtr := cardptr
        END
      END;
      IF lat.mode = cstmode THEN
        IF lat.valu = 0 THEN
          Error(301)
        END;
        IF lat.valu = 1 THEN
          IF opsy = modsy THEN
            ReturnAtReg(fat);
            ConstAt(0,fat.typtr,fat)
          END;
          RETURN
        END;
      END;
      IF (opsy = divsy) AND signedArith THEN
        Op2or3(DIVL2,lat,fat);
      ELSE 
        RegAt(0,fat.typtr,atR0);
        RegAt(1,fat.typtr,atR1);
        Op2(MOVL,fat,atR0);
        Op1(CLRL,atR1);
        IF signedArith THEN
          Op1(TSTL,atR0);
          MarkCondJump(BGEQ,llc);
          Op2(MCOML,atR1,atR1);
          UpdateFwrdJump(llc);
        END;
        ReturnAtReg(fat);
        RegAt(NewReg(),atR0.typtr,fat);
        IF opsy = divsy THEN
          Op4(EDIV,lat,atR0,fat,atR0)
        ELSE Op4(EDIV,lat,atR0,atR0,fat)
        END
      END;
      ReturnAtReg(lat);
    END DivMod;

  BEGIN (*Term*)
    INC(loglevel);
    Factor(fat);
    WHILE (sy >= andsy) AND (sy <= modsy) DO
      opsy := sy;
      GetSy;
      IF opsy = andsy THEN
        ConvToCond(fat);
        CondJump(fat,FALSE);
        UpdCondJump(TRUE);
        Factor(fat);
        ConvToCond(fat);
      ELSIF RealType(fat.typtr) THEN
        Push(fat);
        Factor(lat);
        IF opsy = times THEN
          PushExecute(lat,MulR);
        ELSE PushExecute(lat,DivR);
        END;
      ELSIF opsy = times THEN
        Factor(lat);
        IF SetType(fat.typtr) THEN
          IF lat.mode=cstmode THEN
            (*$T-*)
            lat.valu := -lat.valu-1 (*$T=*)
          ELSE 
            Op1toReg(SelectOpcode(MCOML,fat),lat);
          END;
          (*PreLoad(fat,lat);*) (*!U4!*)
          Op2or3(SelectOpcode(BICL2,fat),lat,fat);
        ELSE 
          PreLoad(fat,lat);
          IF (lat.mode=cstmode) AND
             ((lat.valu > 0) OR NOT SignedType(fat.typtr)) THEN
            PosConstMul(fat,lat.valu);
          ELSE 
            Op2or3(MULL2,lat,fat)
          END;
          IF SignedType(lat.typtr) THEN
            fat.typtr := intptr
          END;
        END;
        ReturnAtReg(lat);
      ELSIF SetType(fat.typtr) THEN
        Factor(lat);
        Op2or3(SelectOpcode(XORL2,fat),lat,fat);
        ReturnAtReg(lat);
      ELSE DivMod(fat,opsy)
      END;
    END;
    DEC(loglevel);
  END Term;

  PROCEDURE SimpleExpr(VAR fat : Attribut);

    VAR
      opsy : Symbol;
      lat : Attribut;
      negb : BOOLEAN;

  BEGIN
    INC(loglevel);
    negb := sy = minus;
    IF negb THEN
      GetSy
    END;
    Term(fat);
    IF negb THEN
      WITH fat DO
        IF RealType(typtr) THEN
          PushExecute(fat,NegR);
        ELSE 
          Op1toReg(MNEGL,fat);
          typtr := intptr;
        END
      END
    END;
    WHILE (sy >= plus) AND (sy <= orsy) DO
      opsy := sy;
      GetSy;
      IF opsy = orsy THEN
        ConvToCond(fat);
        CondJump(fat,TRUE);
        UpdCondJump(FALSE);
        Term(fat);
        ConvToCond(fat);
      ELSIF RealType(fat.typtr) THEN
        Push(fat);
        Term(lat);
        IF opsy = plus THEN
          PushExecute(lat,AddR);
        ELSE PushExecute(lat,SubR);
        END;
      ELSE 
        Term(lat);
        IF SetType(fat.typtr) THEN
          IF opsy = plus THEN
            PreLoad(fat,lat);
            Op2or3(SelectOpcode(BISL2,fat),lat,fat);
          ELSE (*opsy = minus*)
            Op2or3(SelectOpcode(BICL2,fat),lat,fat);
          END
        ELSIF opsy = plus THEN
          PreLoad(fat,lat);
          IF (lat.mode = cstmode) AND (lat.valu = 1) AND AbsRegMode(fat) THEN
            Op1(INcL,fat)
          ELSE 
            Op2or3(ADDL2,lat,fat)
          END;
        ELSE (*opsy = minus*)
          IF (lat.mode = cstmode) AND (lat.valu = 1) AND AbsRegMode(fat) THEN
            Op1(DECL,fat)
          ELSE 
            Op2or3(SUBL2,lat,fat);
          END;
        END;
        IF SignedType(lat.typtr) THEN
          fat.typtr := intptr
        END;
        ReturnAtReg(lat);
      END;
    END;
    DEC(loglevel);
  END SimpleExpr;

  PROCEDURE Expression(VAR fat: Attribut);

    VAR
      cnd:  Condition; (*jump on true*)
      cndX: Condition; (* = cnd with operands exchanged*)
      opsy: Symbol;
      lat,lat1: Attribut;
      llc: CARDINAL;

  BEGIN
    INC(loglevel);
    SimpleExpr(fat);
    IF sy = insy THEN
      GetSy;
      PreMoveBools(fat);
      SimpleExpr(lat);
      IF (lat.mode = cstmode) OR (TypeSize(lat) < oneword) THEN
        (* suppress literal mode in following compare field *)
        LoadValue(lat);
      END;
      WITH fat DO
        IF TypeSize(fat) < oneword THEN
          LoadValue(fat);
          fat.typtr := cardptr;
        END;
        llc := 0;
        (* improvement: substitute basemax by real max of set type *)
        IF (mode <> cstmode) OR (CARDINAL(valu) >= basemax) THEN
          ConstAt(basemax-1,cardptr,lat1);
          Op2(CMPL,lat1,fat);
          MarkCondJump(BLSSU,llc);
        END;
        ConstAt(1,cardptr,lat1);
        Op4(CMPZV,fat,lat1,lat,lat1);
        IF llc <> 0 THEN
          UpdateFwrdJump(llc)
        END;
        (*carry bit set <--> IN yields FALSE*)
        ReturnAtReg(fat);
        ReturnAtReg(lat);
        typtr := boolptr;
        mode := condmode;
        cond := JGE;
        brtrue := TRUE; (*branch if carry is not set*)
        signed := FALSE;
      END;
    ELSIF (sy >= eql) AND (sy <= leq) THEN
      opsy := sy;
      GetSy;
      (*now set cnd according to a CMP instruction:*)
      CASE opsy OF
        eql: cnd := JEQ;
          cndX := JEQ; (* = cnd!*) |
        neq: cnd := JNE;
          cndX := JNE; (* = cnd!*) |
        grt: cnd := JGT;
          cndX := JLT; |
        geq: cnd := JGE;
          cndX := JLE; |
        lss: cnd := JLT;
          cndX := JGT; |
        leq: cnd := JLE;
          cndX := JGE;
      END;
      IF RealType(fat.typtr) THEN
        Push(fat);                  (*!U1!*)
        SimpleExpr(lat);
        IF (lat.mode = cstrealmode) AND (CARDINAL(lat.rvalu) = 0) THEN
          Execute(TstR,fat);        (*!U1!*)
        ELSE 
          cnd := cndX;
          (*Push(fat);*)            (*!U1!*)
          PushExecute(lat,CmpR)
        END;
      ELSE 
        PreMoveBools(fat);
        SimpleExpr(lat);
        PreMoveBools(lat);
        IF SetType(fat.typtr) AND
           ((opsy = geq) OR (opsy = leq)) THEN
          (* set operation >=, <= *)
          IF opsy = geq THEN
            Op2or3(SelectOpcode(BICL2,fat),fat,lat)
          ELSE 
            Op2or3(SelectOpcode(BICL2,fat),lat,fat)
          END;
          cnd := JEQ;
        ELSE 
          IF (fat.mode = cstmode) AND (fat.valu = 0) THEN
            cnd := cndX;
            lat1 := lat;
            lat := fat;
            fat := lat1;
          END;
          IF (lat.mode = cstmode) AND
             (lat.valu = 0) THEN
            Op1(SelectOpcode(TSTL,fat),fat)
          ELSE 
            Op2(SelectOpcode(CMPL,fat),fat,lat)
          END;
        END;
        ReturnAtReg(fat);
        ReturnAtReg(lat);
      END;
      WITH fat DO
        mode := condmode;
        cond := cnd;
        brtrue := TRUE;
        signed := SignedType(typtr) OR
                  SignedType(lat.typtr) OR RealType(typtr);
        typtr := boolptr;
      END;
    END;
    DEC(loglevel);
  END Expression;

  PROCEDURE ExpressionB(VAR fat: Attribut);

  BEGIN
    Expression(fat);
    PreMoveBools(fat)
  END ExpressionB;

  PROCEDURE ProcFuncCall(VAR fat: Attribut);

    PROCEDURE GetComma;

    BEGIN
      Assert(sy = comma);
      GetSy
    END GetComma;

    PROCEDURE StFuncCall(VAR fat : Attribut; calling: Stfuncs);

      VAR
        lnptr: Idptr;
        lat: Attribut;
        llc,ElementSize: CARDINAL;

    BEGIN
      CASE calling OF
        higf: (*HIGH*)
          Designator(fat);
          Assert(DynArrayType(fat.typtr));
          (*all other cases treated completely by previous passes*)
          GetDynBound(fat); |
        lenf: (*LEN*)
          Designator(fat);
          Assert(ArrayType(fat.typtr));
          lat := fat;
          IF DynArrayType(lat.typtr) THEN
            IF IsRegMode(fat) THEN (* save address of dyn array *)
              RegAt(NewReg(),addrptr,lat);
              MoveAddr(fat,lat);
              lat.typtr := fat.typtr;
              lat.indexed := TRUE;
            END;
            GetDynBound(fat);
            Op2C(ADDL2,1,fat);
          ELSE ConstAt(lat.typtr^.ixp^.max+1,shortwordptr,fat);
          END;
          Put2B(LOCC,0); AdMode(fat); AdMode(lat);
          ReturnAtReg(lat);
          fat.typtr := cardptr;
          RegAt(0,fat.typtr,lat);
          Op2or3(SUBL2,lat,fat); |
        sizf: (*SIZE*)
          Designator(fat);
          Assert(DynArrayType(fat.typtr));
          (*all other cases treated completely by previous passes*)
          ElementSize := fat.typtr^.elp^.size;
          GetDynBound(fat);
          Op2C(ADDL2,1,fat);
          PosConstMul(fat,ElementSize); |
        tszf: (*TSIZE*)
          CompError; (*treated completely by previous passes*) |
        adrf: (*ADR*)
          Designator(lat);
          RegAt(NewReg(),cardptr,fat);
          MoveAddr(lat,fat);
          ReturnAtReg(lat); |
        oddf: (*ODD*)
          Expression(fat);
          ConstAt(1,cardptr,lat);
          Op2(BITL,lat,fat);
          ReturnAtReg(fat);
          WITH fat DO
            mode := condmode;
            typtr := boolptr;
            cond := JNE;
            brtrue := TRUE;
            signed := TRUE; (*or FALSE*)
          END; |
        ashf: (*ASH*)
          Expression(fat);
          GetComma;
          Expression(lat);
          lat.typtr := byteptr;
          LoadValue(fat);
          Op3(ASHL,lat,fat,fat);
          ReturnAtReg(lat) |
        absf: (*ABS*)
          Expression(fat);
          IF SignedType(fat.typtr) THEN
            LoadValue(fat);
            Op1(TSTL,fat);
            MarkCondJump(BGEQ,llc);
            Op2(MNEGL,fat,fat);
            UpdateFwrdJump(llc);
          ELSIF RealType(fat.typtr) THEN
            PushExecute(fat,AbsR);
          END |
        capf: (*CAP*)
          Expression(fat);
          LoadValue(fat);
          Op2C(BICB2,240B,fat); |
        chrf: (*CHR*)
          Expression(fat);
          fat.typtr := charptr;
          (*range test not implemented*) |
        ordf: (*ORD*)
          ExpressionB(fat);
          Assert(TypeSize(fat) <= oneword);
          WITH fat DO
            IF TypeSize(fat) < oneword THEN
              (*"extend" size *)
              LoadValue(fat);
            END;
            typtr := cardptr;
          END; |
        valf: (*VAL*)
          Assert(sy = namesy);
          lnptr := nptr; (*type of result*)
          GetSy;
          GetComma;
          Expression(fat);
          fat.typtr := lnptr^.idtyp;
          (*range test not implemented*) |
        regf: (*REG*)
          Expression(fat);
          WITH fat DO
            Assert(mode = cstmode);
            RegAt(valu,wordptr,fat)
          END; |
        fltf: (*FLOAT*)
          Expression(fat);
          FloatPush(fat); |
        trcf: (*TRUNC*)
          Expression(fat);
          PushPopTrunc(fat);
      END (*CASE*)
    END StFuncCall;

    PROCEDURE StProcCall(calling: Stpures);

      VAR
        lat1,lat2,atHigh,atR0: Attribut;

      PROCEDURE TransferPr;
        (* TRANSFER(Old,New) *)

        VAR
          atOld,atNew: Attribut;

      BEGIN (*assume R0 never busy*)
        Designator(atOld);
        GetComma;
        Designator(atNew);
        PushAddr(atOld);
        PushAddr(atNew);
        ReturnAtReg(atOld);
        ReturnAtReg(atNew);
        CallModSys(TransferCode);
      END TransferPr;

      PROCEDURE NewprocPr;
        (* NEWPROCESS(...) *)

        VAR
          k: CARDINAL;
          lat: Attribut;

      BEGIN
        Expression(lat);
        IF lat.mode = cstpfmode THEN
          PushAddr(lat)
        ELSE PushValue(lat)
        END;
        ReturnAtReg(lat);
        GetComma;
        FOR k := 1 TO 2 DO
          Expression(lat);
          PushValue(lat);
          ReturnAtReg(lat);
          GetComma;
        END;
        Designator(lat);
        PushAddr(lat);
        ReturnAtReg(lat);
        CallModSys(NewProcessCode);
        ResetTop(4*oneword);
      END NewprocPr;

    BEGIN (*StProcCall*)
      CASE calling OF
        incp,decp: (*INC,DEC*)
          Designator(lat1);
          IF sy = comma THEN
            GetSy;
            ExpressionB(lat2);
            IF calling = incp THEN (*INC*)
              Op2(SelectOpcode(ADDL2,lat1),lat2,lat1)
            ELSE (*DEC*)
              Op2(SelectOpcode(SUBL2,lat1),lat2,lat1)
            END;
            ReturnAtReg(lat2)
          ELSIF calling = incp THEN (*INC*)
            Op1(SelectOpcode(INcL,lat1),lat1)
          ELSE (*DEC*)
            Op1(SelectOpcode(DECL,lat1),lat1)
          END;
          ReturnAtReg(lat1) |
        halp: (*HALT*)
          CallModSys(HaltCode); |
        inlp,exlp: (*INCL,EXCL*)
          Designator(lat1);
          GetComma;
          ExpressionB(lat2);
          TypFunction(cardptr,lat2);
          IF lat2.mode = cstmode THEN
            WITH lat2 DO
              IF CARDINAL(valu) >= basemax THEN
                Error(300); (*index out of range*)
              END;
              typtr := lat1.typtr;
            END;
          ELSE 
            IF testIndex THEN
              ConstAt(basemax-1,lat2.typtr,atHigh);
              CheckHighBound(atHigh,lat2);
            END;
          END;
          ConstAt(0,cardptr,atHigh);
          IF calling = exlp THEN
            Op3(BBCC,lat2,lat1,atHigh);
          ELSE 
            Op3(BBSS,lat2,lat1,atHigh);
          END;
          ReturnAtReg(lat1);
          ReturnAtReg(lat2); |
        trsp: (*TRANSFER*)
          TransferPr; |
        nprp: (*NEWPROCESS*)
          NewprocPr;
      ELSE CompError;
      END;
    END StProcCall;

    PROCEDURE LoadParam(fnp: Idptr);

      VAR
        lat: Attribut;
        loglevSave: INTEGER;
        lmpjSave: CARDINAL;
        loffset: INTEGER;

      PROCEDURE DescrParameter(VAR fat: Attribut; fnp: Idptr);

      BEGIN
        Error(997);
      END DescrParameter;

      PROCEDURE StdescrParameter(VAR fat: Attribut; fnp: Idptr);

      VAR
        ElementSize: CARDINAL;

      BEGIN
        PushAddr(fat);
        WITH fat.typtr^ DO
          IF DynArrayType(fat.typtr) THEN
            GetDynBound(fat);
            Op2C(ADDL2,1,fat);
            IF fnp^.vkind = valparam THEN
              Put2B(LOCC,0);
              AdMode(fat);
              Put2B(0BEH,0); (* LOCC #0,fat,@(SP) *)
              Put2B(SUBL3,50H);
              AdMode(fat);
              PutB(7EH); (* SUBL3 R0,fat,-(SP) *)
            ELSE PushValue(fat);
            END;
          ELSE 
            IF form = arrays THEN
              ElementSize := ixp^.max - ixp^.min + 1;
              IF (fat.mode = cststringmode) AND (ElementSize = 1) THEN
                 (* empty string *)
                PushConst(0);
              ELSIF (fat.mode<>cststringmode) AND (fnp^.vkind = valparam) THEN
                Put2B(LOCC,0);
                IF ElementSize <= 63 THEN
                  PutB(ElementSize)
                ELSE PutB(8FH);
                  PutW(ElementSize)
                END;
                Put2B(0BEH,0); (* LOCC #0,#ElementSize,@(SP) *)
                Put2B(SUBL3,50H);
                IF ElementSize <= 63 THEN
                  PutB(ElementSize)
                ELSE PutB(8FH);
                  PutL(ElementSize)
                END;
                PutB(7EH);    (* SUBL3 R0,#ElementSize,-(SP) *)
              ELSE PushConst(ElementSize)
              END;
            ELSE PushConst(1)
            END;
          END;
          DEC(StackTop,2*oneword);
          ReturnAtReg(fat);
          fat.mode := stackmode;
        END
      END StdescrParameter;

      PROCEDURE DynParameter(VAR fat: Attribut; fnp: Idptr);

        VAR
          fpelsize: CARDINAL; (* formal parameter element size *)
          apelsize: CARDINAL; (* actual parameter element size *)
          IsArrayOfWord: BOOLEAN;

      BEGIN
        IsArrayOfWord := WordType(fnp^.idtyp^.elp);
        fpelsize := fnp^.idtyp^.elp^.size;
        PushAddr(fat);
        WITH fat.typtr^ DO
          IF DynArrayType(fat.typtr) THEN
            apelsize := elp^.size;
            GetDynBound(fat);
            IF IsArrayOfWord AND (apelsize <> fpelsize) THEN
              IF apelsize > 1 THEN
                Op2C(ADDL2,1,fat);
                PosConstMul(fat,apelsize);
                Op1(DECL,fat);
              END;
              IF fpelsize > 1 THEN
                Op2C(DIVL2,fpelsize,fat);
              END;
            END;
            PushValue(fat);
          ELSE 
            IF IsArrayOfWord THEN
              (*high := word size of parameter*)
              PushConst((size-1) DIV fpelsize);
            ELSIF form = arrays THEN
              (*high := number of array elements - 1*)
              PushConst(ixp^.max - ixp^.min);
              (*number of array elements = high - low + 1*)
            ELSE PushConst(0)
            END;
          END;
        END;
        DEC(StackTop,2*oneword);
      END DynParameter;

    BEGIN
      IF fnp <> NIL THEN
        WITH fnp^ DO
          MarkCondcode(loglevSave,lmpjSave);
          ExpressionB(lat);
          ReleaseCondcode(loglevSave,lmpjSave);
          IF pkind <> immed THEN
            IF (lat.mode = cstrealmode) OR (lat.mode = cstmode) OR
               AbsRegMode(lat) OR (lat.mode <> cststringmode) AND
               NOT DynArrayType(idtyp) AND (TypeSize(lat) < idtyp^.size) THEN
              IF lat.mode = cstrealmode THEN        (*!U2!*)
                Push(lat)                           (*!U2!*)
              ELSE PushValue(lat);                  (*!U2!*)
              END;                                  (*!U2!*)
              IF TypeSize(lat) <= oneword THEN
                DEC(StackTop,oneword);
              ELSE DEC(StackTop,TypeSize(lat));
              END;
            ELSIF (lat.mode = cstpfmode) AND (vkind = valparam) THEN
              (*procedure passed by value => entry address passed by ref*)
              PushAddr(lat);
              lat.mode := stackmode;
              DEC(StackTop,oneword);
            ELSIF lat.mode = stackmode THEN           (*!U3!*)
              DEC(StackTop,TypeSize(lat))             (*!U3!*)
            END;
            IF pkind = descr THEN
              DescrParameter (lat,fnp);
            ELSIF pkind = stdescr THEN
              StdescrParameter(lat,fnp);
            END;
          END;
          loffset := StackTop;
          IF nxtparam <> NIL THEN
            GetComma
          END;
          LoadParam(nxtparam);
          IF lat.mode = stackmode THEN
            RegAt(14(*SP*),lat.typtr,lat);
            lat.indexed := TRUE;
            lat.offset := loffset - StackTop;
          END;
          IF (pkind = default) AND DynArrayType(idtyp) THEN
            DynParameter(lat,fnp);
          ELSIF pkind = immed THEN
            PushValue(lat);
            IF TypeSize(lat) <= oneword THEN
              DEC(StackTop,oneword);
            ELSE DEC(StackTop,TypeSize(lat));
            END;
          ELSE
            PushAddr(lat);
            DEC(StackTop,oneword);
          END;
          ReturnAtReg(lat);
        END (* WITH *);
      ELSE maxoffset := StackTop;
      END;
    END LoadParam;

    VAR
      functype: Stptr;
      funccall,extendedcall: BOOLEAN;
      sizeAt,lat: Attribut;
      maxoffset, stackoffset: INTEGER;

  BEGIN (*ProcFuncCall*)
    IF (fat.mode = cstpfmode) AND fat.anptr^.isstandard THEN
      WITH fat DO
        IF anptr^.klass = funcs THEN
          StFuncCall(fat,anptr^.fname)
        ELSE (*klass = pures*) StProcCall(anptr^.pname)
        END;
      END;
      GetSy; (*rparent*)
    ELSE 
      WITH fat.typtr^ DO
        Assert(form=proctypes);
        funccall := FALSE;
        extendedcall := FALSE;
        IF rkind = funcs THEN (* function result is returned in R0 or R0,R1 *)
          Save;
          funccall := TRUE;
          functype := funcp;
          IF funcp^.size > 2*oneword THEN
            Assert(RealType(funcp) OR WordType(funcp));
            (* call of function with octaword size result *)
            (* reserve space on stack for function result *)
            extendedcall := TRUE;
            RegAt(14(*SP*),funcp,lat);
            ConstAt(funcp^.size,funcp,sizeAt);
            Op2(SUBL2,sizeAt,lat);
          END
        END;
        stackoffset := StackTop;
        LoadParam(fstparam);
        IF extendedcall THEN
          lat.indexed := TRUE;
          lat.offset := stackoffset - StackTop;
          Op1(PUSHAL,lat); (* push address of function result *)
        END;
        CallProc(fat);
        StackTop := maxoffset;
        ResetTop(stackoffset-StackTop);
      END;
      IF extendedcall THEN
        fat := lat;
        fat.mode := stackmode;
      ELSIF funccall THEN
        (* save function result *)
        RegAt(0,functype,fat);
        IF RealType(functype) THEN
          Push(fat)
        ELSIF functype^.size > oneword THEN
          Assert(WordType(functype));
          PushValue(fat);
        ELSE 
          LoadValue(fat);
        END
      END;
      Assert(sy = rparent);
      GetSy; (*rparent*)
    END
  END ProcFuncCall;


  PROCEDURE BoolExpr(jmpt: BOOLEAN; VAR baseexprlc, tlist, flist: CARDINAL);

    VAR
      lat: Attribut;

  BEGIN
    baseexprlc := lc;
    Expression(lat);
    ConvToCond(lat);
    CondJump(lat,jmpt);
    DEC(loglevel);
    LinkCondJump(baseexprlc,tlist,TRUE);
    LinkCondJump(baseexprlc,flist,FALSE);
    INC(loglevel);
  END BoolExpr;

  PROCEDURE Assignment;

    VAR
      lat1,lat2: Attribut;

  BEGIN
    ExpressionB(lat2);
    Designator(lat1);
    IF lat2.mode = cstpfmode THEN
      MoveAddr(lat2,lat1);
    ELSIF RealType(lat1.typtr) THEN
      PushPop(lat2,lat1);
    ELSE MoveValue(lat2,lat1);
    END;
    ReturnAtReg(lat1);
    ReturnAtReg(lat2);
    CorrectLine;
    GetSy; (*endsy*)
  END Assignment;

  PROCEDURE IfStatement;

    VAR
      l1,l2,bexprlc,tlist,flist,jmplc,llc: CARDINAL;
      toolong : BOOLEAN;
      endif: qptr;

  BEGIN
    endif := NIL;
    LOOP l1 := lc;
      BoolExpr(FALSE,bexprlc,tlist,flist);
      UpdateCondJump(bexprlc,tlist);
      l2 := lc;
      CorrectLine;
      GetSy; (*thensy*)
      StatSeq3(endsy,elsifsy,elsesy);
      toolong := BranchTooLong(l1);
      IF toolong THEN
        MoveCode(l2,jmplc);
        llc := lc;
        lc := l2 + 2;
        UpdateCondJump(bexprlc,flist);
        lc := llc;
      END;
      IF sy <> endsy THEN
        Mark(endif)
      END;
      IF toolong THEN
        UpdateFwrdJump(jmplc)
      ELSE UpdateCondJump(bexprlc,flist)
      END;
      CorrectLine;
      IF sy <> elsifsy THEN
        EXIT
      END;
      GetSy;
    END;
    IF sy = elsesy THEN
      GetSy;
      StatSeq1(endsy)
    END;
    Update(endif);
    GetSy
  END IfStatement;

  PROCEDURE WhileStatement;

    VAR
      l1,l2,jmplc,bexprlc,tlist,flist,llc: CARDINAL;
      toolong : BOOLEAN;

  BEGIN
    l1 := lc;
    BoolExpr(FALSE,bexprlc,tlist,flist);
    UpdateCondJump(bexprlc,tlist);
    l2 := lc;
    CorrectLine;
    GetSy; (*dosy*)
    StatSeq1(endsy);
    toolong := BranchTooLong(l1);
    IF toolong THEN
      MoveCode(l2,jmplc);
      llc := lc;
      lc := l2+2;
      UpdateCondJump(bexprlc,flist);
      lc := llc;
    END;
    GenJump(l1);
    IF toolong THEN
      UpdateFwrdJump(jmplc)
    ELSE UpdateCondJump(bexprlc,flist)
    END;
    GetSy;
  END WhileStatement;

  PROCEDURE RepeatStatement;

    VAR
      l: CARDINAL;
      bexprlc,tlist,flist: CARDINAL;

  BEGIN
    l := lc;
    StatSeq1(untilsy);
    GetSy; (* UNTIL *)
    BoolExpr(TRUE,bexprlc,tlist,flist);
    UpdateCondJump(bexprlc,flist);
    GenJump(l);
    UpdateCondJump(bexprlc,tlist);
    CorrectLine;
    GetSy; (*endsy*)
  END RepeatStatement;

  MODULE LoopSystem;
    IMPORT Symbol,GetSy,StackTop,ResetTop,StatSeq1,qptr,outloop,
           lc,GenJump,Update,Mark,CorrectLine;

    EXPORT LoopStatement,ExitStatement;

    VAR
      LoopTop: INTEGER; (*StackTop at entry of inner most loop;
      used to optimise EXIT statement*)

    PROCEDURE LoopStatement;

      VAR
        LoopTopOld: INTEGER; (*used to save StackTop of outer loop*)
        l: CARDINAL;
        lsptr: qptr;

    BEGIN
      LoopTopOld := LoopTop;
      LoopTop := StackTop;
      lsptr := outloop;
      outloop := NIL;
      l := lc;
      StatSeq1(endsy);
      GenJump(l);
      Update(outloop);
      outloop := lsptr;
      LoopTop := LoopTopOld;
      GetSy;
    END LoopStatement;

    PROCEDURE ExitStatement;

    BEGIN
      ResetTop(LoopTop - StackTop);
      Mark(outloop);
      CorrectLine;
    END ExitStatement;

  END LoopSystem;

  PROCEDURE ForStatement;

    VAR
      lat1,lat2,lat3: Attribut;
      step,oldLimit: INTEGER;
      signedArith: BOOLEAN;
      lcEndOfFor,lcEntry,lcBranch: CARDINAL;

    PROCEDURE Compare;

    BEGIN
      IF step > 0 THEN
        Op2(SelectOpcode(CMPL,lat1),lat1,lat2)
      ELSE 
        Op2(SelectOpcode(CMPL,lat1),lat2,lat1)
      END
    END Compare;

  BEGIN (*ForStatement*)
    Designator(lat1);
    ExpressionB(lat2); (*initial value*)
    MoveValue(lat2,lat1);
    ReturnAtReg(lat2);
    signedArith := SignedType(lat1.typtr);
    GetSy; (*sy = tosy*)
    ExpressionB(lat2);
    IF sy = bysy THEN
      GetSy; (*sy = anycon*)
      IF (NOT SignedType(csptr)) AND (val.value > CARDINAL(maxint)) THEN
        Error(995); (*step must be in INTEGER range*)
      END;
      step := val.value;
      GetSy;
    ELSE step := 1
    END;
    Assert(step <> 0 );
    IF lat2.mode <> cstmode THEN (*push limit onto stack*)
      PushValue(lat2);
      DEC(StackTop,oneword);
      RegAt(14(*SP*),lat2.typtr,lat2);
      lat2.indexed := TRUE;
    END;
    Compare;
    IF signedArith THEN
      MarkCondJump(BLEQ,lcBranch)
    ELSE 
      MarkCondJump(BLEQU,lcBranch)
    END;
    MarkJump(lcEndOfFor);
    UpdateFwrdJump(lcBranch);
    IF ABS(step) > 1 THEN (*correct limit*)
      IF lat2.mode = cstmode THEN
        WITH lat2 DO (*correct value of constant limit*)
          oldLimit := valu;
          (*$T-*)
          DEC(valu,step); (*$T=*)
          IF step > 0 THEN
            (*$T-*)
            INC(valu); (*$T=*)
            IF signedArith THEN
              IF valu > oldLimit THEN (*overflow*)
                valu := minint;
              END
            ELSE (*CARDINAL or CHAR arithmetik*)
              IF CARDINAL(valu) > CARDINAL(oldLimit) THEN (*overflow*)
                valu := 0 (*minCard = minChar = 0*)
              END
            END
          ELSE (*step < 0*)
            (*$T-*) DEC(valu); (*$T=*)
            IF signedArith THEN
              IF valu < oldLimit THEN (*overflow*)
                valu := CARDINAL(maxint)
              END
            ELSIF TypeSize(lat1) = 1 THEN (*CHAR arithmetik*)
              IF CARDINAL(valu) > maxchar THEN (*overflow*)
                valu := maxchar
              END
            ELSE (*CARDINAL arithmetik*)
              IF CARDINAL(valu) < CARDINAL(oldLimit) THEN (*overflow*)
                valu := INTEGER(maxcard)
              END
            END
          END
        END (*WITH*)
      ELSE (*lat2.mode <> cstmode*)
        (*now correct limit (on top of stack)*)
        IF step > 0 THEN
          ConstAt(step-1,lat2.typtr,lat3);
          Op2(SelectOpcode(SUBL2,lat2),lat3,lat2)
        ELSE 
          ConstAt(ABS(step)-1,lat2.typtr,lat3);
          Op2(SelectOpcode(ADDL2,lat2),lat3,lat2)
        END;
        (*now provide code to set limit (on top of stack) to range
          boundary, if the correction resulted in an overflow*)
        IF signedArith THEN
          MarkCondJump(BVC,lcBranch);
          IF step > 0 THEN
            oldLimit := minint;
          ELSE oldLimit := maxint;
          END;
        ELSE (*CARDINAL or CHAR arithmetik*)
          MarkCondJump(BGEQU,lcBranch);
          IF step > 0 THEN
            oldLimit := 0;
          ELSE 
            oldLimit := INTEGER(maxcard);
          END;
        END;
        ConstAt(oldLimit,lat2.typtr,lat3);
        Op2(MOVL,lat3,lat2);
        UpdateFwrdJump(lcBranch);
      END;
    END; (*IF ABS(step) > 1*)
    lcEntry := lc;
    CorrectLine;
    GetSy; (*dosy*)
    StatSeq1(endsy);
    Compare;
    IF signedArith THEN
      MarkCondJump(BGEQ,lcBranch)
    ELSE 
      MarkCondJump(BGEQU,lcBranch)
    END;
    IF step = 1 THEN
      Op1(SelectOpcode(INcL,lat1),lat1)
    ELSIF step = -1 THEN
      Op1(SelectOpcode(DECL,lat1),lat1)
    ELSE
      ConstAt(step,lat1.typtr,lat3);
      Op2(SelectOpcode(ADDL2,lat1),lat3,lat1)
    END;
    GenJump(lcEntry);
    UpdateFwrdJump(lcBranch);
    UpdateFwrdJump(lcEndOfFor);
    IF lat2.mode <> cstmode THEN (*pop limit from stack*)
      ResetTop(oneword);
    END;
    ReturnAtReg(lat1);
    GetSy;
  END ForStatement;

  PROCEDURE WithStatement;

    VAR
      lat : Attribut;

  BEGIN
    Designator(lat);
    NewWith(lat);
    CorrectLine;
    GetSy; (*dosy*)
    StatSeq1(endsy);
    ReleaseWith;
    GetSy;
  END WithStatement;

  PROCEDURE CaseStatement;

    TYPE
      Caseptr = POINTER TO Caserec;
      Caserec = RECORD
                  cval: INTEGER;
                  caselc,exitlc: CARDINAL;
                  next: Caseptr;
                END;

    VAR
      lat: Attribut;
      testCaseExpr : BOOLEAN;
      lower,upper,lval: INTEGER;
      jmplc: CARDINAL;
      labelList: Caseptr; (*ordered cicular list of labels*)
      cp,lnext: Caseptr;

    PROCEDURE EnterCaseLabel(VAR fcp: Caseptr;
                             labelList: Caseptr; fval: INTEGER);
      (*create a new element for fval, insert it into the ordered
      (circular) labelList and return its pointer in fcp.*)

      VAR
        lastLabelp,nextLabelp: Caseptr;

    BEGIN
      lastLabelp := labelList;
      WITH labelList^ DO (*first element is always empty*)
        nextLabelp := next;
        cval := fval; (*garantees termination of WHILE-loop*)
      END;
      WHILE nextLabelp^.cval < fval DO
        lastLabelp := nextLabelp;
        nextLabelp := nextLabelp^.next
      END;
      IF (nextLabelp <> labelList) AND
         (nextLabelp^.cval = fval) THEN
        Error(303); (*case label defined twice*)
      END;
      NEW(fcp);
      lastLabelp^.next := fcp;
      WITH fcp^ DO
        cval := fval;
        next := nextLabelp;
        caselc := lc;
        exitlc := 0;
      END
    END EnterCaseLabel;

    PROCEDURE GenCaseJumps(labelList: Caseptr);
      (*generate the jump addresses for the labels in the
      ordered (circular) labelList.*)

      VAR
        cp: Caseptr;
        lcElse: CARDINAL;
        j: INTEGER;
        lowAt, highAt: Attribut;
        tablc: CARDINAL;

    BEGIN
      EnterLabel(lc);
      MarkJump(lcElse);
      UpdateFwrdJump(jmplc);
      cp := labelList^.next; (*first element is always empty*)
      lower := cp^.cval;
      upper := lower - 1;
      WHILE cp <> labelList DO
        WITH cp^ DO
          upper := cval;
          cp := next
        END
      END;
      ConstAt(lower,lat.typtr,lowAt);
      ConstAt(upper-lower,lat.typtr,highAt);
      Op3(SelectOpcode(CASEL,lat),lat,lowAt,highAt);
      tablc := lc;
      cp := labelList^.next; (*first element is always empty*)
      lower := cp^.cval;
      upper := lower - 1;
      WHILE cp <> labelList DO
        WITH cp^ DO
          FOR j := upper+1 TO cval-1 DO
            PutW(lcElse-tablc-1);
          END;
          upper := cval;
          PutW(caselc-tablc);
          cp := next
        END
      END;
      UpdateFwrdJump(lcElse);
    END GenCaseJumps;

  BEGIN
    NEW(labelList);
    WITH labelList^ DO
      next := labelList; (*empty circular list*)
      cval := 0; (*first element is always empty*)
    END;
    testCaseExpr := testIndex;
    (*first evalute case expresion:*)
    ExpressionB(lat);
    ReturnAtReg(lat);
    MarkJump(jmplc);
    (*now treat the label lists:*)
    WHILE sy = ofsy DO
      GetSy;
      REPEAT
        IF (sy = anycon) AND (NOT SignedType(csptr)) AND
           (val.value > CARDINAL(maxint)) THEN
          Error(996); (*case label must be in INTEGER range*)
        END;
        EnterCaseLabel(cp,labelList,val.value);
        lval := val.value;
        GetSy;
        IF sy = range THEN
          GetSy;
          IF (sy = anycon) AND (NOT SignedType(csptr)) AND
             (val.value > CARDINAL(maxint)) THEN
            Error(996); (*case label must be in INTEGER range*)
          END;
          WHILE lval < INTEGER(val.value) DO
            INC(lval);
            EnterCaseLabel(cp,labelList,lval);
          END;
          GetSy;
        END;
      UNTIL sy = colon;
      EnterLabel(lc);
      GetSy;
      StatSeq3(ofsy,elsesy,endsy);
      MarkJump(cp^.exitlc); (*fixup the exit jumps only once*)
      CorrectLine;
    END;
    GenCaseJumps(labelList);
    IF sy = elsesy THEN
      GetSy;
      StatSeq1(endsy);
    ELSIF testCaseExpr THEN
      CallModSys(IndexError);
      (*case expression out of range*)
    END;
    cp := labelList^.next;
    WHILE cp <> labelList DO
      WITH cp^ DO
        IF exitlc <> 0 THEN
          UpdateFwrdJump(exitlc)
        END;
        lnext := next;
        DISPOSE(cp);
        cp := lnext;
      END;
    END;
    DISPOSE(labelList);
    GetSy;
  END CaseStatement;

  PROCEDURE ReturnStatement;

    VAR
      lat1,lat2: Attribut;

  BEGIN
    IF (blocknptr <> NIL) AND (blocknptr^.klass = funcs) THEN
      GetSy;
      Assert (sy = lparent);
      GetSy;
      ExpressionB(lat1);
      WITH blocknptr^.idtyp^ DO
        Assert((form = proctypes) AND (rkind = funcs));
        IF funcp^.size > 2*oneword THEN
          RegAt(13(*FP*),funcp,lat2);
          lat2.indexed := TRUE;
          lat2.indirect := TRUE;
          lat2.offset := -oneword;
        ELSE
          RegAt(0,funcp,lat2);
        END;
      END;
      IF RealType(lat2.typtr) THEN
        PushPop(lat1,lat2);
      ELSE MoveValue(lat1,lat2);
      END;
      ReturnAtReg(lat1);
      ReturnAtReg(lat2);
    END;
    GenExit(blocknptr);
    CorrectLine;
  END ReturnStatement;

  PROCEDURE Statement;

    VAR
      loglevSave: INTEGER;
      lmpjSave: CARDINAL;
      lat: Attribut;
      lsy: Symbol;

  BEGIN
    MarkCondcode(loglevSave,lmpjSave);
    IF sy = call THEN
      GetSy;
      IF (sy = namesy) AND (nptr^.klass = mods) THEN
        (*call initialisation code of module*)
        WITH lat DO
          mode := cstpfmode;
          typtr := nptr^.idtyp;
          anptr := nptr;
        END;
        CallProc(lat);
        GetSy;(*lparent*)
        GetSy;(*rparent*)
        GetSy;
      ELSE (*klass = pures*)
        Designator(lat);
        Assert(sy = lparent);
        GetSy;
        ProcFuncCall(lat)
      END;
    ELSE 
      lsy := sy;
      IF (lsy <> exitsy) AND (lsy <> returnsy) THEN
        GetSy;
      END;
      CASE lsy OF
        becomes: Assignment; |
        ifsy: IfStatement; |
        repeatsy: RepeatStatement; |
        whilesy: WhileStatement; |
        loopsy: LoopStatement; |
        exitsy: ExitStatement;
          GetSy; |
        forsy: ForStatement; |
        withsy: WithStatement; |
        casesy: CaseStatement; |
        returnsy: ReturnStatement;
          GetSy;
      END;
    END;
    ReleaseCondcode(loglevSave,lmpjSave);
  END Statement;

  PROCEDURE StatSeq1(s: Symbol);

  BEGIN
    WHILE sy <> s DO
      Statement
    END;
  END StatSeq1;

  PROCEDURE StatSeq3(s1,s2,s3: Symbol);

  BEGIN
    WHILE (sy <> s1) AND (sy <> s2) AND (sy <> s3) DO
      Statement
    END;
  END StatSeq3;

  PROCEDURE Block(fnptr: Idptr);

    VAR
      lnptr: Idptr;
      llc: CARDINAL;

  BEGIN
    IF fnptr <> NIL THEN
      StartProcedure(fnptr)
    END;
    WHILE sy = proceduresy DO
      lnptr := nptr;
      GetSy;
      INC(level);
      Block(lnptr);
      DEC(level);
    END;
    Assert((sy = beginsy) OR (sy = endblock));
    IF fnptr <> NIL THEN
      WITH fnptr^ DO
        IF (sy = beginsy) OR (klass <> mods) THEN
          GenEntry(fnptr);
          blocknptr := fnptr;
          IF sy = beginsy THEN
            GetSy
          END;
          StatSeq1(endblock);
          Assert(sy = endblock);
          GetSy;
          IF klass = funcs THEN
            CallModSys(FunctionReturnError);
            (*for the debugger to keep the current scope*)
            (*one more instruction is need              *)
            PutB(NOP);
          ELSE 
            GenExit(fnptr)
          END;
          PutBlock(fnptr);
        ELSE 
          Assert(sy = endblock);
          GetSy;
        END;
      END;
    ELSE 
      Assert(sy = endblock);
      GetSy;
    END;
  END Block;

  PROCEDURE Pass4;

  BEGIN
    StartIO;
    StartObjectFile;
    level := 0;
    GetSy;
    outloop := NIL;
    Block(NIL);
    TerminateObjectFile;
  END Pass4;


END MVCP4.