(****************************************
*                                       *
*     MODULA-2 Multi-Pass Compiler      *
*     ****************************      *
*                                       *
*       VAX/VMS Implementation          *
*                                       *
*                                       *
*     MVCAttributeHandling:             *
*                                       *
*     Attribute handling in Pass 4      *
*                                       *
*     Version 3.1 of  1-FEB-1983        *
*     Update    1 of 13-JUN-1983        *
*                                       *
****************************************)

(****************************************
* Updates:                              *
* - - - - - - - - - - - - - - - - - - - *
* Nr.  1 of 13-JUN-1983 by M. Mall      *
*  error in code generation for calls   *
*  of variable procedures               *
****************************************)

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

  IMPORT SYSTEM, MODDefinitions, MVCompiler, MVCIO4, MVCMnemonicsAndTraps,
         MVCLi4, Storage;
  FROM SYSTEM IMPORT BYTE, SHORTWORD, LONGWORD;
  FROM MVCompiler IMPORT Stptr, Structform, boolptr, intptr;
  FROM MVCIO4 IMPORT Assert;

  PROCEDURE ArrayType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN s^.form = arrays
  END ArrayType;

  PROCEDURE SetType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN s^.form = sets
  END SetType;

  PROCEDURE BooleanType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN (s = boolptr) OR
    ((s^.form = subranges) AND (s^.scalp = boolptr))
  END BooleanType;

  PROCEDURE SignedType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN (s = intptr) OR
    ((s^.form = subranges) AND (s^.scalp = intptr))
  END SignedType;

  PROCEDURE SimpleType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    WITH s^ DO
      RETURN
      (size <= 4) AND (form <> arrays) AND (form <> records)
    END
  END SimpleType;

  PROCEDURE DynArrayType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN (s^.form = arrays) AND s^.dyn
  END DynArrayType;

  PROCEDURE WordType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN s^.form = words
  END WordType;

  PROCEDURE RealType(s: Stptr): BOOLEAN;

  BEGIN
    Assert(s <> NIL);
    RETURN s^.form = reals
  END RealType;

  MODULE CodeSystem;

    FROM SYSTEM IMPORT BYTE, SHORTWORD, LONGWORD;
    FROM MVCompiler IMPORT Idptr;
    FROM MVCIO4 IMPORT printlc,Assert,Error;
    FROM MVCMnemonicsAndTraps IMPORT Mnemos;
    FROM MVCLi4 IMPORT EnterLabel, PutObjectCode, UpdateLinkerTable;
    FROM LoopSystem IMPORT UpdateOutloop;
    IMPORT lc;

    EXPORT lcNil,
           PutCodeTable,PutB,PutW,PutL,Put2B,Put3B,Put4B,Put5B,PutBBLB,
           PutLocByte,PutLocWord,PutLocLongWord,
           UpdateCondJump,UpdateFwrdJump,MarkJump,MarkCondJump,GenJump,
           MoveCode,BranchTooLong;

    CONST
      maxcode = 4000;
      lcNil   = maxcode + 1;

    TYPE
      Template = RECORD
                   CASE BOOLEAN OF
                     TRUE:  word: LONGWORD |
                     FALSE: byte1,byte2,byte3,byte4: BYTE
                   END
                 END;

    VAR
      ctab : ARRAY [0..maxcode] OF BYTE;
      ctaboverflow: BOOLEAN;

    PROCEDURE PutCodeTable(fnptr: Idptr);

    BEGIN
      PutObjectCode(ctab,lc,fnptr);
      lc := 0;
      printlc := 0;
      ctaboverflow := FALSE
    END PutCodeTable;

    PROCEDURE PutB(b: BYTE);

    BEGIN
      ctab[lc] := b;
      IF lc < maxcode THEN
        INC(lc);
        printlc := lc;
      ELSIF NOT ctaboverflow THEN
        ctaboverflow := TRUE;
        Error(405)
      END;
    END PutB;

    PROCEDURE PutW(w: SHORTWORD);

      VAR
        template: Template;

    BEGIN
      WITH template DO
        word := LONGWORD(w);
        PutB(byte1);
        PutB(byte2)
      END
    END PutW;

    PROCEDURE PutL(l: LONGWORD);

      VAR
        template: Template;

    BEGIN
      WITH template DO
        word := l;
        PutB(byte1);
        PutB(byte2);
        PutB(byte3);
        PutB(byte4);
      END;
    END PutL;

    PROCEDURE Put2B(byte1, byte2: BYTE);

    BEGIN
      PutB(byte1);
      PutB(byte2);
    END Put2B;

    PROCEDURE Put3B(byte1, byte2, byte3: BYTE);

    BEGIN
      PutB(byte1);
      PutB(byte2);
      PutB(byte3)
    END Put3B;

    PROCEDURE Put4B(byte1, byte2, byte3, byte4: BYTE);

    BEGIN
      PutB(byte1);
      PutB(byte2);
      PutB(byte3);
      PutB(byte4)
    END Put4B;

    PROCEDURE Put5B(byte1, byte2, byte3, byte4, byte5: BYTE);

    BEGIN
      PutB(byte1);
      PutB(byte2);
      PutB(byte3);
      PutB(byte4);
      PutB(byte5)
    END Put5B;

    PROCEDURE PutBBLB(opcode,oper1spec: BYTE; oper1: LONGWORD; oper2: BYTE);

    BEGIN
      PutB(opcode);
      PutB(oper1spec);
      PutL(oper1);
      PutB(oper2)
    END PutBBLB;

    PROCEDURE PutLocByte(flc: CARDINAL; b: BYTE);

    BEGIN
      ctab[flc] := b
    END PutLocByte;

    PROCEDURE PutLocWord(flc: CARDINAL; w: SHORTWORD);

      VAR
        template: Template;

    BEGIN
      WITH template DO
        word := LONGWORD(w);
        ctab[flc] := byte1;
        ctab[flc+1] := byte2;
      END
    END PutLocWord;

    PROCEDURE PutLocLongWord(flc: CARDINAL; l: LONGWORD);

      VAR
        template: Template;

    BEGIN
      WITH template DO
        word := l;
        ctab[flc] := byte1;
        ctab[flc+1] := byte2;
        ctab[flc+2] := byte3;
        ctab[flc+3] := byte4;
      END
    END PutLocLongWord;

    PROCEDURE UpdateFwrdJump(flc: CARDINAL); (* JMP flc TO lc *)

    BEGIN
      IF NOT ctaboverflow THEN
        Assert(lc > flc); (*forward jump*)
        IF Mnemos(ctab[flc-1]) = BRW THEN
          PutLocWord (flc, lc-flc-2);
        ELSE PutLocByte (flc, lc-flc-1);
        END;
        EnterLabel(lc);
      END
    END UpdateFwrdJump;

    PROCEDURE MarkJump(VAR flc: CARDINAL);

    BEGIN
      PutB(BRW);
      flc := lc;
      PutW(0);
    END MarkJump;

    PROCEDURE MarkCondJump(opcode: Mnemos; VAR flc: CARDINAL);

    BEGIN
      PutB(opcode);
      flc := lc;
      PutB(0);
    END MarkCondJump;

    PROCEDURE GenJump(flc: CARDINAL); (* JMP or BR lc TO flc *)

      VAR
        d: INTEGER;

    BEGIN
      Assert(lc >= flc); (*backward jump*)
      d := lc+2 - flc;
      IF d < 200B THEN
        Put2B(BRB,-d);
      ELSE PutB(BRW);
        PutW(-(d+1));
      END;
      EnterLabel(flc);
    END GenJump;

    PROCEDURE UpdateCondJump(baseexprlc,xlst: CARDINAL);
      (*for all (conditional) branches in xlst: branch to lc*)

      VAR
        list,reladdr: CARDINAL;

    BEGIN
      IF NOT ctaboverflow THEN
        WHILE xlst <> baseexprlc DO
          list := xlst;
          reladdr := lc - (list+1);
          IF reladdr > 177B THEN
            Error(402)
          END;
          xlst := CARDINAL(ctab[list]) + baseexprlc;
          ctab[list] := BYTE(reladdr);
        END;
        EnterLabel(lc);
      END
    END UpdateCondJump;

    PROCEDURE BranchTooLong(flc: CARDINAL) : BOOLEAN;

    BEGIN
      Assert(lc >= flc);
      RETURN (lc - flc) > 175B
    END BranchTooLong;

    PROCEDURE MoveCode(initlc: CARDINAL; VAR flc: CARDINAL);

      CONST
        codeshift = 5;

      VAR
        j,k: CARDINAL;

    BEGIN
      IF lc < maxcode - codeshift THEN
        UpdateLinkerTable(initlc,codeshift);
        UpdateOutloop(initlc,codeshift);
        k := lc;
        INC(lc,codeshift);
        j := lc;
        REPEAT DEC(k);
          DEC(j);
          ctab[j] := ctab[k];
        UNTIL k = initlc;
        ctab[initlc]   := BYTE(BRB);
        ctab[initlc+1] := BYTE(3);
        ctab[initlc+2] := BYTE(BRW);
      ELSIF NOT ctaboverflow THEN
        ctaboverflow := TRUE;
        Error(405)
      END;
      flc := initlc + 3;
      EnterLabel(initlc + 5);
    END MoveCode;

  BEGIN
    lc := 0;
    ctaboverflow := FALSE;
  END CodeSystem;

  MODULE AttributSystem;

    FROM SYSTEM IMPORT BYTE,SHORTWORD,LONGWORD;
    IMPORT MODDefinitions;
    FROM MVCompiler IMPORT levmax,Idptr,Stptr,Idclass,Structform,
                           Varkind,intptr,cardptr,addrptr,byteptr,
                           mainmodp,sysmodp;
    FROM MVCIO4 IMPORT Assert,CompError,Error;
    FROM MVCLi4 IMPORT EnterVariable,EnterConstant,EnterExternal,EnterModule,
                       EnterProcedure,EnterRuntimeSupport,EnterSystemData,
                       EnterLabel;
    FROM MVCMnemonicsAndTraps IMPORT Mnemos,Traps;
    FROM CodeSystem IMPORT PutCodeTable,
                           PutB,PutW,PutL,Put2B,Put3B,Put4B,PutBBLB,PutLocWord,
                           MarkCondJump,UpdateFwrdJump;
    FROM BooleanSystem IMPORT CondJump,UpdCondJump;
    IMPORT BooleanType,SimpleType,WordType,AttrMode,DynArrayType,
           Condition,ModeSet,RegSet,Attribut,loglevel,StackTop,WithBase,lc;

    EXPORT NewReg,ReleaseReg,LockReg,UnlockReg,
           IsRegMode,AbsRegMode,ReturnAtReg,
           CallProc,CallModSys,ResetTop,
           GenEntry,GenExit,PutBlock,
           RegAt,ConstAt,SelectOpcode,AdMode,
           Op1,Op2,Op3,Op4,Op1toReg,Op2or3,Op2C,TypeSize,
           PreMoveBools,MoveValue,MoveAddr,PushConst,PushValue,
           PushAddr,LoadValue,LoadAddr,PreLoad,ConvToCond,PosConstMul;

    CONST
      oneword = 4;

    VAR
      regtab: ARRAY [0..15] OF
                RECORD
                  busy,lock: BOOLEAN;
                END;
      (* R0,R1 are used in connection with DIV and MOD, and function returns *)
      SaveRegSet: RegSet;
      EntryLc: CARDINAL;

    PROCEDURE NewReg(): CARDINAL;

      VAR
        lreg: CARDINAL;

    BEGIN
      lreg := 10;
      LOOP
        WITH regtab[lreg] DO
          IF NOT busy THEN
            Assert(NOT lock);
            busy := TRUE;
            INCL(SaveRegSet,lreg);
            EXIT;
          END;
        END;
        IF lreg = 1 THEN
          Error(400);
          ReleaseReg(1);
          Assert(NOT regtab[1].busy);
          (*so register 1 will be returned*)
        ELSE 
          DEC(lreg)
        END;
      END;
      RETURN lreg;
    END NewReg;

    PROCEDURE ReleaseReg(freg: CARDINAL);

    BEGIN
      WITH regtab[freg] DO
        busy := lock
      END;
      (*i.e. if not lock then busy := false*)
    END ReleaseReg;

    PROCEDURE LockReg(Ri: CARDINAL);

    BEGIN
      WITH regtab[Ri] DO
        Assert(busy);
        lock := TRUE
      END
    END LockReg;

    PROCEDURE UnlockReg(Ri: CARDINAL);

    BEGIN
      WITH regtab[Ri] DO
        Assert(busy);
        lock := FALSE
      END;
    END UnlockReg;

    PROCEDURE IsLockedReg(Ri: CARDINAL): BOOLEAN;

    BEGIN
      RETURN regtab[Ri].lock;
    END IsLockedReg;

    PROCEDURE InitRegs;

      VAR
        Ri: CARDINAL;

    BEGIN
      WITH regtab[0] DO
        busy := TRUE;
        lock := TRUE
      END;
      FOR Ri := 1 TO 10 DO
        WITH regtab[Ri] DO
          busy := FALSE;
          lock := FALSE
        END;
      END;
      FOR Ri := 11 TO 15 DO
        WITH regtab[Ri] DO
          busy := TRUE;
          lock := TRUE
        END
      END
    END InitRegs;

    PROCEDURE SaveSomeRegs(VAR rs: RegSet; from, to: CARDINAL);

      VAR
        lreg: CARDINAL;

    BEGIN
      rs := RegSet{};
      FOR lreg := from TO to DO
        IF regtab[lreg].busy THEN
          INCL(rs,lreg);
        END;
      END;
      IF rs <> RegSet{} THEN
        PutB(PUSHR);
        PutWordConst(CARDINAL(rs));
      END
    END SaveSomeRegs;

    PROCEDURE SaveRegs(rs: RegSet);

    BEGIN
      SaveRegSet := SaveRegSet + rs;
    END SaveRegs;

    PROCEDURE RestoreRegs(rs: RegSet);

    BEGIN
      IF rs<>RegSet{} THEN
        PutB(POPR);
        PutWordConst(CARDINAL(rs));
      END
    END RestoreRegs;

    PROCEDURE IsRegMode(VAR fat: Attribut): BOOLEAN;

    BEGIN
      WITH fat DO
        RETURN (mode = regmode) AND (regnr IN RegSet{1..10})
        AND NOT IsLockedReg(regnr)
      END
    END IsRegMode;

    PROCEDURE AbsRegMode(VAR fat: Attribut): BOOLEAN;

    BEGIN
      WITH fat DO
        RETURN (mode = regmode) AND (regnr IN RegSet{1..10})
        AND NOT(indexed OR indirect)
      END
    END AbsRegMode;

    PROCEDURE ReturnAtReg(VAR fat: Attribut);

    BEGIN
      WITH fat DO
        IF IsRegMode(fat) THEN
          ReleaseReg(regnr)
        END
      END
    END ReturnAtReg;

    PROCEDURE AdMode(VAR fat:Attribut);

    BEGIN
      WITH fat DO
        CASE mode OF
          cstmode: 
            IF CARDINAL(valu) <= 63 THEN
              PutB(valu)
            ELSE 
              PutB(8FH);
              IF TypeSize(fat) = 1 THEN
                PutB(valu)
              ELSIF TypeSize(fat) = 2 THEN
                PutW(valu)
              ELSE PutL(valu)
              END
            END |
          cstpfmode: 
            PutB(0EFH);
            EnterProcedure(lc,anptr);
            PutL(0) |
          absmode: 
            PutB(9FH);
            PutL(addr) |
          globmode: 
            PutB(0EFH);
            EnterVariable(lc,anptr);
            PutL(addr) |
          cststringmode: 
            PutB(0EFH);
            EnterConstant(lc);
            PutL(addr) |
          extmode: 
            PutB(0EFH);
            EnterExternal(lc,anptr);
            PutL(addr) |
          regmode: 
            IF indexed THEN
              IF indirect OR (offset <> 0) THEN
                IF (offset >= -128) AND (offset <= 127) THEN
                  PutB(regnr + 0A0H + CARDINAL(indirect) * 10H);
                  PutB(offset)
                ELSIF (offset+1 >= -32767) AND (offset <= 32767) THEN
                  PutB(regnr + 0C0H + CARDINAL(indirect) * 10H);
                  PutW(offset)
                ELSE 
                  PutB(regnr + 0E0H + CARDINAL(indirect) * 10H);
                  PutL(offset)
                END
              ELSE 
                PutB(regnr + 60H);
              END
            ELSE 
              PutB(regnr + 50H + CARDINAL(indirect) * 10H);
            END; |
          stackmode: 
            PutB(8EH);
        ELSE CompError
        END
      END
    END AdMode;

    PROCEDURE CallModSys(Trap: Traps);

    BEGIN
      CASE Trap OF
        HaltCode : 
          Put2B(PUSHL,8FH);
          PutL(MODDefinitions.MOD$_HLTSTMT);
          Put3B(CALLS,1,0EFH); |
        IndexError : 
          Put2B(PUSHL,8FH);
          PutL(MODDefinitions.MOD$_INDERR);
          Put3B(CALLS,1,0EFH); |
        IllegalPointerError : 
          Put2B(PUSHL,8FH);
          PutL(MODDefinitions.MOD$_ILLPTR);
          Put3B(CALLS,1,0EFH); |
        FunctionReturnError : 
          Put2B(PUSHL,8FH);
          PutL(MODDefinitions.MOD$_NOFUNCRES);
          Put3B(CALLS,1,0EFH); |
        NewProcessCode, TransferCode : 
          Put2B(JSB,0EFH);
      END;
      EnterRuntimeSupport(lc,Trap);
      PutL(0);
    END CallModSys;

    PROCEDURE CallProc(VAR fat: Attribut);

      VAR
        lat: Attribut;

    BEGIN
      WITH fat DO
        IF typtr <> NIL THEN
          WITH typtr^ DO
            Assert(parlgth MOD 4 = 0);
            ConstAt(parlgth DIV 4,cardptr,lat);
            IF mode <> cstpfmode THEN
              LoadValue(fat);
              indexed := TRUE;
              offset := 0; (*!U1!*)
            END;
          END
        ELSE Assert((anptr^.klass = mods) AND (mode = cstpfmode));
          ConstAt(0,cardptr,lat)
        END;
        Op2(CALLS,lat,fat);
        ReturnAtReg(fat);
      END
    END CallProc;

    PROCEDURE ResetTop(i: INTEGER);

    BEGIN
      IF i<>0 THEN
        IF CARDINAL(i) <= 63 THEN
          Put3B(ADDL2,i,5EH)
        ELSE PutBBLB(ADDL2,8FH,i,5EH)
        END;
        INC(StackTop,i);
      END
    END ResetTop;

    PROCEDURE ParamCopy(fnptr: Idptr);

      VAR
        lnptr: Idptr;
        ElementSize: CARDINAL;
        atSrc,atDst,atHigh,atR0,atR10,lat: Attribut;
        llc: CARDINAL;

    BEGIN
      Assert(fnptr <> NIL);
      WITH fnptr^ DO
        IF klass = mods THEN
          lnptr := NIL (*no parameters*)
        ELSE 
          Assert((idtyp <> NIL) AND (idtyp^.form = proctypes));
          IF (idtyp^.rkind = funcs) AND (idtyp^.funcp^.size > 2*oneword) THEN
            RegAt(12(*AP*),idtyp^.funcp,atSrc);
            atSrc.indexed := TRUE;
            atSrc.indirect := TRUE;
            atSrc.offset := oneword;
            RegAt(13(*FP*),addrptr,atDst);
            atDst.indexed := TRUE;
            atDst.offset := -oneword;
            MoveAddr(atSrc,atDst);
          END;
          lnptr := idtyp^.fstparam;
        END;
      END;
      WHILE lnptr <> NIL DO
        WITH lnptr^ DO
          RegAt(12(*AP*),idtyp,atSrc);
          atSrc.indexed := TRUE;
          atSrc.offset := caddr;
          RegAt(13(*FP*),idtyp,atDst);
          atDst.indexed := TRUE;
          atDst.offset := vaddr;
          IF DynArrayType(idtyp) THEN
          (*formal parameter is dynamic array*)
            Op2(MOVQ,atSrc,atDst);
            atSrc := atDst;
            IF vkind = valparam THEN
              WITH idtyp^ DO
                ElementSize := elp^.size;
                atHigh := atSrc;
                Op2C(ADDL2,1,atHigh);
                PosConstMul(atHigh,ElementSize);
                RegAt(14(*SP*),cardptr,atDst);
                Op2(SUBL2,atHigh,atDst);
                atDst.indexed := TRUE;
                SaveRegs(RegSet{2,3,4,5});
                atSrc.indirect := TRUE;
                INC(atSrc.offset,4);
                Op3(MOVC3,atHigh,atSrc,atDst);
                ReturnAtReg(atHigh);
                atSrc.indirect := FALSE;
                atSrc.typtr := addrptr;
                MoveAddr(atDst,atSrc);
              END (* WITH *)
            END
          ELSE (*formal parameter is not dynamic array*)
            atSrc.indirect := TRUE;
            IF vkind = valparam THEN
              MoveValue(atSrc,atDst);
            ELSE 
              atDst.typtr := addrptr;
              MoveAddr(atSrc,atDst);
            END;
          END;
          lnptr := nxtparam;
        END;
      END;
    END ParamCopy;

    PROCEDURE GenEntry(fnptr: Idptr);

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

    BEGIN
      EntryLc := lc;
      SaveRegSet := RegSet{};
      PutW(0);
      WITH fnptr^ DO
        IF varlength<>0 THEN
          RegAt(14(*SP*),cardptr,lat);
          ConstAt(varlength,cardptr,sizeAt);
          Op2(SUBL2,sizeAt,lat)
        END;
        InitRegs;
        ParamCopy(fnptr);
        IF (klass <> mods) AND usedisp THEN
          (*save current value in display and set new one*)
          IF plev > levmax THEN
            Error(994)
          END; (*display too small*)
          Put3B(PUSHL,0ABH,-INTEGER(4*plev));     (* PUSHL -4*plev(R11) *)
          Put4B(MOVL,05DH,0ABH,-INTEGER(4*plev)); (* MOVL FP,-4*plev(R11) *)
        END;
        IF (klass = mods) AND (plev = 1) AND (procnum = 0) THEN
          Put3B(BBCS,0,0EFH);
          EnterSystemData(lc);
          PutL(0);
          PutB(1)                   (* BBCS #0,initflag,1$   *);
          PutB(RET)                 (* RET                   *);
          EnterLabel(lc)            (* 1$:                   *);
          (* if call from VMS image startup procedures, i.e. *)
          (* with non zero argument list, then reserve space *)
          (* on stack for Dijkstra display                   *)
          Put2B(TSTB,06CH)          (* TSTB (AP)             *);
          MarkCondJump(BEQL,llc)    (* BEQL 2$               *);
          (* save FP on stack for coroutine control          *)
          Put2B(PUSHL,5DH)          (* PUSHL FP              *);
          Put3B(MOVL,5EH,5BH)       (* MOVL SP,R11           *);
          (* reserve space on stack for display vector       *)
          (* R11 contains start address of vector            *)
          (* see PROCEDURE LoadDisplay, GenEntry, GenExit    *)
          Put2B(SUBL2,8FH);
          PutL(levmax*oneword);
          PutB(5EH)                 (* SUBL2 #levmax*4,SP    *);
          UpdateFwrdJump(llc)       (* 2$:                   *);
          lnptr := sysmodp^.link;
          WHILE lnptr <> NIL DO
            WITH lnptr^ DO
              IF NOT foreign AND (lnptr <> mainmodp) THEN
                Put3B(CALLS,0,0EFH);
                EnterModule(lc,lnptr);
                PutL(0);            (* CALLS #0,imported module body    *);
              END;
              lnptr := link;
            END;
          END;
        END;
        WithBase := -INTEGER(varlength);
        StackTop := 0;
      END;
    END GenEntry;

    PROCEDURE GenExit(fnptr: Idptr);

    BEGIN
      WITH fnptr^ DO
        IF (klass <> mods) AND usedisp THEN
          (*restore old value in display*)
          ResetTop(-StackTop);
          Put4B(MOVL,08EH,0ABH,-INTEGER(4*plev)); (* MOVL (SP)+,-4*plev(R11) *)
        ELSIF (klass = mods) AND (plev = 1) AND (procnum = 0) THEN
          Put3B(MOVL,1,50H);                      (* MOVL #SS$_NORMAL,R0 *)
        END;
      END;
      PutB(RET);
    END GenExit;

    PROCEDURE PutBlock(fnptr: Idptr);

    BEGIN
      PutLocWord(EntryLc,SaveRegSet);
      PutCodeTable(fnptr);
    END PutBlock;

    PROCEDURE RegAt(freg: CARDINAL; ftyptr: Stptr; VAR fat: Attribut);

    BEGIN
      WITH fat DO
        typtr := ftyptr;
        mode := regmode;
        regnr := freg;
        offset := 0;
        indexed := FALSE;
        indirect := FALSE;
      END;
    END RegAt;

    PROCEDURE ConstAt(fconst: CARDINAL; ftyptr: Stptr; VAR fat: Attribut);

    BEGIN
      WITH fat DO
        typtr := ftyptr;
        mode := cstmode;
        valu := fconst;
      END;
    END ConstAt;

    PROCEDURE SelectOpcode(opcode: Mnemos; VAR fat: Attribut): Mnemos;

    BEGIN
      IF TypeSize(fat) = 1 THEN
        RETURN VAL(Mnemos,ORD(opcode)-40H)
      ELSIF TypeSize(fat) = 2 THEN
        RETURN VAL(Mnemos,ORD(opcode)-20H)
      ELSE RETURN opcode
      END
    END SelectOpcode;

    PROCEDURE Op1(opcode: Mnemos; VAR fat: Attribut);

    BEGIN
      PutB(opcode);
      AdMode(fat)
    END Op1;

    PROCEDURE Op2(opcode: Mnemos; VAR fat1,fat2: Attribut);

    BEGIN
      PutB(opcode);
      AdMode(fat1);
      AdMode(fat2)
    END Op2;

    PROCEDURE Op3(opcode: Mnemos; VAR fat1,fat2,fat3: Attribut);

    BEGIN
      PutB(opcode);
      AdMode(fat1);
      AdMode(fat2);
      AdMode(fat3);
    END Op3;

    PROCEDURE Op4(opcode: Mnemos; VAR fat1,fat2,fat3,fat4: Attribut);

    BEGIN
      PutB(opcode);
      AdMode(fat1);
      AdMode(fat2);
      AdMode(fat3);
      AdMode(fat4);
    END Op4;

    PROCEDURE Op1toReg(opcode: Mnemos; VAR fat: Attribut);

      VAR
        lat: Attribut;

    BEGIN
      IF IsRegMode(fat) AND AbsRegMode(fat) THEN
        Op2(opcode,fat,fat);
      ELSE 
        IF IsRegMode(fat) THEN
          lat.regnr := fat.regnr;
        ELSE lat.regnr := NewReg();
        END;
        RegAt(lat.regnr,fat.typtr,lat);
        Op2(opcode,fat,lat);
        fat := lat;
      END;
    END Op1toReg;

    PROCEDURE Op2or3(opcode: Mnemos; VAR fat1, fat2: Attribut);

      VAR
        lat: Attribut;
        changeAt: BOOLEAN;

    BEGIN
      IF IsRegMode(fat2) AND AbsRegMode(fat2) THEN
        Op2(opcode,fat1,fat2)
      ELSE 
        changeAt := FALSE;
        IF IsRegMode(fat2) THEN
          lat.regnr := fat2.regnr
        ELSIF IsRegMode(fat1) THEN
          lat.regnr := fat1.regnr;
          changeAt := TRUE;
        ELSE lat.regnr := NewReg();
        END;
        RegAt(lat.regnr,fat2.typtr,lat);
        INC(opcode); (* 2 operand to 3 operand *)
        Op3(opcode,fat1,fat2,lat);
        IF changeAt THEN
          fat1 := fat2
        END;
        fat2 := lat
      END
    END Op2or3;

    PROCEDURE Op2C(opcode: Mnemos; fconst: INTEGER;
                   VAR fat: Attribut);

      VAR
        lat: Attribut;

    BEGIN
      ConstAt(fconst,fat.typtr,lat);
      Op2or3(opcode,lat,fat);
    END Op2C;

    PROCEDURE TypeSize(VAR fat: Attribut): CARDINAL;

    BEGIN
      WITH fat DO
        Assert(typtr<>NIL);
        RETURN typtr^.size
      END;
    END TypeSize;

    PROCEDURE PutWordConst(fConst: CARDINAL);

    BEGIN
      IF fConst<=63 THEN
        PutB(fConst)
      ELSE PutB(8FH);
        PutW(fConst)
      END
    END PutWordConst;

    PROCEDURE MoveValue(VAR fat,fat1: Attribut);
      (*constant size only*)

      VAR
        size, size1: CARDINAL;
        rs: RegSet;
        ltyp: Stptr;

    BEGIN
      WITH fat DO
        Assert((mode <> condmode) AND (mode <> cstpfmode));
        size1 := TypeSize(fat1);
        size  := TypeSize(fat);
        IF (size = size1) AND NOT AbsRegMode(fat1) THEN
          IF (mode = cstmode) AND (valu = 0) AND (size <= oneword) THEN
            Op1(SelectOpcode(CLRL,fat),fat1)
          ELSIF size = 3 THEN
            PutB(INSV);
            AdMode(fat);
            Put2B(0,24);
            AdMode(fat1);
          ELSIF size <= oneword THEN
            Op2(SelectOpcode(MOVL,fat),fat,fat1)
          ELSIF size=8 THEN
            Op2(MOVQ,fat,fat1)
          ELSE 
            SaveRegs(RegSet{2,3,4,5});
            SaveSomeRegs(rs,2,5);
            PutB(MOVC3);
            PutWordConst(size);
            AdMode(fat);
            AdMode(fat1);
            RestoreRegs(rs);
          END
        ELSIF AbsRegMode(fat1) THEN
          (* load into register, clear high order bits on load *)
          CASE size OF
            1: PutB(MOVZBL); |
            2: PutB(MOVZWL); |
            3: Put3B(EXTZV,0,24); |
            4: PutB(MOVL);
          ELSE IF size = 8 THEN
                 PutB(MOVQ)
               ELSIF size = 16 THEN
                 Put2B(0FDH,MOVQ)
               ELSE CompError
               END
          END;
          AdMode(fat);
          AdMode(fat1);
        ELSIF AbsRegMode(fat) OR (mode = cstmode) THEN
          CASE size1 OF
            1: IF size = 2 THEN
                 PutB(CVTWB)
               ELSE PutB(CVTLB)
               END;
              AdMode(fat); |
            2: IF size = 1 THEN
                 PutB(MOVZBW)
               ELSE PutB(CVTLW)
               END;
              AdMode(fat); |
            3: ltyp := typtr;
              typtr := intptr;
              PutB(INSV);
              AdMode(fat);
              Put2B(0,24);
              typtr := ltyp;
          ELSE IF size = 1 THEN
                 PutB(MOVZBL)
               ELSIF size = 2 THEN
                 PutB(MOVZWL)
               ELSIF size = 3 THEN
                 Put3B(EXTZV,0,24)
               ELSE PutB(MOVL)
               END;
            AdMode(fat);
          END;
          AdMode(fat1);
        ELSE 
          SaveRegs(RegSet{2,3,4,5});
          SaveSomeRegs(rs,2,5);
          PutB(MOVC5);
          PutWordConst(size);
          AdMode(fat);
          PutB(0); (* fill character *)
          PutWordConst(size1);
          AdMode(fat1);
          RestoreRegs(rs);
        END
      END
    END MoveValue;

    PROCEDURE MoveAddr(fat: Attribut; VAR fat1: Attribut);

    BEGIN
      Assert(TypeSize(fat1) = 4);
      WITH fat DO
        IF mode IN ModeSet{absmode,globmode,extmode,cstpfmode,regmode} THEN
          Op2(MOVAL,fat,fat1)
        ELSE CompError
        END;
      END;
    END MoveAddr;

    PROCEDURE PushConst(fconst: INTEGER);

      VAR
        lat: Attribut;

    BEGIN
      ConstAt(fconst, intptr, lat);
      PushValue(lat);
    END PushConst;

    PROCEDURE PushValue(VAR fat: Attribut);

      VAR
        ltyp: Stptr;
        size: CARDINAL;

    BEGIN
      WITH fat DO
        Assert(mode <> condmode);
        IF mode <> stackmode THEN
          size := TypeSize(fat);
          IF mode = cstmode THEN
            ltyp := typtr;
            typtr := intptr;
            Op1(PUSHL,fat);
            typtr := ltyp;
          ELSIF mode = cstpfmode THEN
            Op1(PUSHAL,fat);
          ELSIF AbsRegMode(fat) AND (size <= 4) OR (size = 4) THEN
            Op1(PUSHL,fat);
          ELSE 
            IF size = 1 THEN
              PutB(MOVZBL);
            ELSIF size = 2 THEN
              PutB(MOVZWL);
            ELSIF size = 3 THEN
              Put3B(EXTZV,0,24);
            ELSIF size = 8 THEN
              PutB(MOVQ);
            ELSIF size = 16 THEN
              Put2B(0FDH,MOVQ);
            ELSE CompError
            END;
            AdMode(fat);
            PutB(7EH(*-SP*))
          END;
          ReturnAtReg(fat);
          mode := stackmode;
        END; (* mode <> stackmode *)
      END (* WITH fat *)
    END PushValue;

    PROCEDURE PushAddr(VAR fat: Attribut);

    BEGIN
      WITH fat DO
        IF mode IN ModeSet{absmode,globmode,extmode,cstpfmode,cststringmode,
                           regmode} THEN
          Op1(PUSHAL,fat);
        ELSIF mode = stackmode THEN
          Put2B(PUSHL,5EH); (* PUSHL SP *)
        ELSE CompError
        END;
      END;
    END PushAddr;

    PROCEDURE LoadValue(VAR fat: Attribut);

      VAR
        lat : Attribut;

      PROCEDURE NewLoadReg(VAR atOld,atNew: Attribut);

      BEGIN
        RegAt(NewReg(),atOld.typtr,atNew);
        IF atOld.mode = cstpfmode THEN
          Op2(MOVAL,atOld,atNew)
        ELSE 
          MoveValue(atOld,atNew)
        END
      END NewLoadReg;

    BEGIN
      WITH fat DO
        CASE mode OF
          cstmode,absmode,globmode,extmode,
          (*used for type conversion only:*)
          cstpfmode,cstrealmode,cststringmode,stackmode: 
            NewLoadReg(fat,lat);
            fat := lat; |
          regmode: 
            IF NOT AbsRegMode(fat) THEN
              IF NOT IsLockedReg(regnr) THEN
                lat := fat;
                WITH lat DO
                  indexed := FALSE;
                  indirect := FALSE
                END;
                MoveValue(fat,lat);
              ELSE NewLoadReg(fat,lat)
              END;
              fat := lat;
            END;
        ELSE (*nomode,condmode*)
          CompError
        END (*CASE*)
      END
    END LoadValue;

    PROCEDURE LoadAddr(VAR fat: Attribut);

      VAR
        ltyp: Stptr;

    BEGIN
      WITH fat DO
        Assert(mode = regmode);
        Assert(indirect);
        indirect := FALSE;
        ltyp := typtr;
        typtr := cardptr;
        LoadValue(fat);
        indexed := TRUE;
        typtr := ltyp;
        offset := 0;
      END;
    END LoadAddr;

    PROCEDURE PreLoad(VAR fat1,fat2: Attribut);

      VAR
        lat: Attribut;

    BEGIN
      IF NOT AbsRegMode(fat1) THEN
        IF AbsRegMode(fat2) THEN
          lat := fat1;
          fat1 := fat2;
          fat2 := lat
        END
      END;
    END PreLoad;

    PROCEDURE PreMoveBools(VAR fat: Attribut);
      (* converts Attribut from condmode to regmode *)

      VAR
        llc: CARDINAL;

    BEGIN
      WITH fat DO
        IF BooleanType(typtr) AND (mode = condmode) THEN
          CondJump(fat,FALSE);
          DEC(loglevel);
          UpdCondJump(TRUE);
          RegAt(NewReg(),typtr,fat);
          Op2C(MOVL,1,fat);
          MarkCondJump(BRB,llc);
          UpdCondJump(FALSE);
          INC(loglevel);
          Op1(CLRL,fat);
          UpdateFwrdJump(llc);
        END;
      END;
    END PreMoveBools;

    PROCEDURE ConvToCond(VAR fat: Attribut);

    BEGIN
      WITH fat DO
        Assert(BooleanType(typtr));
        IF mode <> condmode THEN
          Op1(TSTB,fat);
          ReturnAtReg(fat);
          mode := condmode;
          cond := JNE;
          brtrue := TRUE;
        END;
      END;
    END ConvToCond;

    PROCEDURE Power2(x: CARDINAL; VAR exp2: CARDINAL; VAR pw2: BOOLEAN);

    BEGIN
      exp2 := 0;
      pw2 := x > 0;
      WHILE (x > 1) AND pw2 DO
        pw2 := (x MOD 2) = 0;
        x := x DIV 2;
        INC(exp2)
      END;
    END Power2;

    PROCEDURE PosConstMul(VAR fat: Attribut; fconst: CARDINAL);
    (*multiply fat by the positive constant fconst*)

      VAR
        exp2: CARDINAL;
        pw2: BOOLEAN;
        shiftAt, oldAt: Attribut;

    BEGIN
      IF fconst <> 1 THEN
        Power2(fconst,exp2,pw2);
        IF pw2 THEN (*exp2 > 0*)
          ConstAt(exp2,byteptr,shiftAt);
          oldAt := fat;
          IF NOT IsRegMode(fat) THEN
            fat.regnr := NewReg();
          END;
          RegAt(fat.regnr,fat.typtr,fat);
          Op3(ASHL,shiftAt,oldAt,fat);
        ELSE (*not pw2*)
          Op2C(MULL2,fconst,fat);
        END
      END
    END PosConstMul;

  END AttributSystem;

  MODULE WithSystem;

    FROM MVCompiler IMPORT wordptr;
    FROM MVCIO4 IMPORT Assert;
    FROM MVCMnemonicsAndTraps IMPORT Mnemos;
    FROM Storage IMPORT ALLOCATE,DEALLOCATE;
    FROM CodeSystem IMPORT PutB;
    FROM AttributSystem IMPORT ReturnAtReg,LoadAddr,ReleaseReg,
                               LockReg,UnlockReg,MoveAddr;
    IMPORT AttrMode,RegSet,Attribut,WithBase;

    EXPORT NewWith,ReleaseWith,UseWith;

    TYPE
      WithPtr = POINTER TO WithRecord;
      WithRecord = RECORD
                     WithAt: Attribut;
                     Previous: WithPtr;
                   END;

    VAR
      WithLevel: CARDINAL;
      LastWith,WithInRegister: WithPtr;

    PROCEDURE NewWith(VAR fat: Attribut);

      VAR
        lWith: WithPtr;

    BEGIN
      INC(WithLevel);
      NEW(lWith);
      WITH lWith^ DO
        WithAt := fat;
        Previous := LastWith;
        LastWith := lWith;
        WITH WithAt DO
          IF (mode = regmode) AND
             (indirect OR (regnr IN RegSet{2..10})) THEN
            (*optimise access: compute address of WITH argument*)
            IF WithInRegister = NIL THEN (*store address in register*)
              WithInRegister := lWith;
              IF indirect THEN
                LoadAddr(WithAt)
              END;
              LockReg(regnr);
            ELSE (*Already one register is occupied by a WITH
              argument: store address at the reserved location*)
              regnr := 13;
              indexed := TRUE;
              offset := WithBase + 4*INTEGER(WithLevel - 1);
              indirect := FALSE;
              typtr := wordptr;
              MoveAddr(fat,WithAt);
              indirect := TRUE;
              typtr := fat.typtr;
              ReturnAtReg(fat);
            END;
            (*ELSE: access not optimised*)
          END;
        END;
      END;
    END NewWith;

    PROCEDURE ReleaseWith;

      VAR
        lWith: WithPtr;

    BEGIN
      Assert((WithLevel > 0) AND (LastWith <> NIL));
      WITH LastWith^ DO
        IF LastWith = WithInRegister THEN (*release register*)
          UnlockReg(WithAt.regnr);
          ReleaseReg(WithAt.regnr);
          WithInRegister := NIL;
        END;
        lWith := LastWith;
        LastWith := Previous;
      END;
      DISPOSE(lWith);
      DEC(WithLevel);
    END ReleaseWith;

    PROCEDURE UseWith(flev: CARDINAL; VAR fat: Attribut);

      VAR
        lWith: WithPtr;
        k: CARDINAL;

    BEGIN
      Assert(WithLevel >= flev);
      lWith := LastWith;
      k := WithLevel - flev;
      WHILE k > 0 DO
        lWith := lWith^.Previous;
        DEC(k);
      END;
      fat := lWith^.WithAt;
    END UseWith;

  BEGIN
    WithLevel := 0;
    LastWith := NIL;
    WithInRegister := NIL;
  END WithSystem;

  MODULE BooleanSystem;

    FROM SYSTEM IMPORT BYTE;
    FROM MVCIO4 IMPORT Assert,CompError,Error;
    FROM MVCMnemonicsAndTraps IMPORT Mnemos;
    FROM CodeSystem IMPORT PutLocByte,PutB;
    IMPORT AttrMode,Condition,Attribut,ModeSet,loglevel,lc;

    EXPORT MarkCondcode,ReleaseCondcode,
           UpdCondJump,CondJump,InvertJump,LinkCondJump;

    CONST
      jmptabmax = 50;

    VAR
      jmptab: ARRAY [0..jmptabmax] OF
                RECORD
                  loglev: INTEGER;
                  jmpaddr: CARDINAL;(*address relative to a block*)
                  jmpbr: BOOLEAN
                END;
      lastmpj,mpj: CARDINAL;(*mark pointer to jump table*)

    PROCEDURE MarkCondcode(VAR floglev: INTEGER; VAR flastmpj: CARDINAL);

    BEGIN
      flastmpj := lastmpj;
      floglev := loglevel;
      lastmpj := mpj;
      loglevel := 0;
    END MarkCondcode;

    PROCEDURE ReleaseCondcode(floglev: INTEGER; flastmpj: CARDINAL);

    BEGIN
      loglevel := floglev;
      mpj := lastmpj;
      lastmpj := flastmpj;
    END ReleaseCondcode;

    PROCEDURE UpdCondJump(b: BOOLEAN);

      VAR
        i,j: CARDINAL;

    BEGIN
      i := mpj;
      WHILE i > lastmpj DO
        WITH jmptab[i] DO
          IF (jmpbr = b) AND (loglev > loglevel) THEN
            j := lc - (jmpaddr + 1);
            IF j > 177B THEN
              Error(402)
            END;
            PutLocByte(jmpaddr,j);
            loglev := -1; (*already satisfied*)
          END
        END;
        DEC(i);
      END
    END UpdCondJump;

    PROCEDURE LinkCondJump(baseexprlc: CARDINAL; VAR list : CARDINAL;
                           blist : BOOLEAN);

      VAR
        i,j: CARDINAL;

    BEGIN
      i := mpj;
      list := baseexprlc;
      WHILE i > lastmpj DO
        WITH jmptab[i] DO
          IF (jmpbr = blist) AND (loglev > loglevel) THEN
            j := list - baseexprlc;
            IF j > 177B THEN
              Error(402)
            END;
            PutLocByte(jmpaddr,j);
            list := jmpaddr;
            loglev := -1;
          END;
        END;
        DEC(i);
      END;
    END LinkCondJump;

    PROCEDURE CondJump(VAR fat: Attribut; b: BOOLEAN);

      VAR
        opcode: Mnemos;

    BEGIN
      WITH fat DO
        IF mode <> condmode THEN
          CompError;
        ELSE 
          IF b <> brtrue THEN
            CASE cond OF
              JEQ: cond := JNE ; |
              JNE: cond := JEQ ; |
              JGE: cond := JLT ; |
              JLE: cond := JGT ; |
              JLT: cond := JGE ; |
              JGT: cond := JLE ;
            END;
            brtrue := NOT brtrue
          END;
          CASE cond OF
            JEQ: opcode := BEQL; |
            JNE: opcode := BNEQ; |
            JGE: IF signed THEN
                   opcode := BGEQ
                 ELSE opcode := BGEQU
                 END |
            JLE: IF signed THEN
                   opcode := BLEQ
                 ELSE opcode := BLEQU
                 END |
            JLT: IF signed THEN
                   opcode := BLSS
                 ELSE opcode := BLSSU
                 END |
            JGT: IF signed THEN
                   opcode := BGTR
                 ELSE opcode := BGTRU
                 END
          END;
          INC(mpj);
          IF mpj > jmptabmax THEN
            Error(403);
            DEC(mpj)
          END;
          WITH jmptab[mpj] DO
            jmpaddr := lc + 1;
            loglev := loglevel;
            jmpbr := b
          END;
          PutB(opcode);
          PutB(0)
        END
      END
    END CondJump;

    PROCEDURE InvertJump(VAR fat: Attribut);

      VAR
        i: CARDINAL;

    BEGIN
      WITH fat DO
        Assert(mode = condmode);
        brtrue := NOT brtrue;
      END;
      i := lastmpj + 1;
      WHILE i <= mpj DO
        WITH jmptab[i] DO
          IF (loglev > loglevel) THEN
            jmpbr := NOT jmpbr
          END
        END;
        INC(i);
      END;
    END InvertJump;

  BEGIN
    mpj := 0;
    loglevel := 0;
  END BooleanSystem;

  MODULE LoopSystem;

    FROM MVCIO4 IMPORT Assert;
    FROM Storage IMPORT ALLOCATE, DEALLOCATE;
    IMPORT lc, outloop, qptr, MarkJump, UpdateFwrdJump;

    EXPORT UpdateOutloop, Mark, Update;

    PROCEDURE UpdateOutloop(initlc,delta: CARDINAL);

      VAR
        lp: qptr;

    BEGIN
      lp := outloop;
      WHILE lp <> NIL DO
        WITH lp^ DO
          Assert(x <= lc);
          IF x >= initlc THEN
            INC(x,delta)
          END;
          lp := next
        END
      END
    END UpdateOutloop;

    PROCEDURE Mark(VAR top: qptr);
      (*insert a new reference into the linear list*)

      VAR
        lp: qptr;

    BEGIN
      NEW(lp);
      WITH lp^ DO
        MarkJump(x);
        next := top
      END;
      top := lp
    END Mark;

    PROCEDURE Update(VAR top: qptr);
      (*update the jumps in the linear list and return it*)

      VAR
        lp: qptr;

    BEGIN;
      WHILE top<>NIL DO
        WITH top^ DO
          UpdateFwrdJump(x);
          lp := next;
          DISPOSE(top);
        END;
        top := lp
      END
    END Update;

  END LoopSystem;

END MVCAttributHandling.