M2compiler-V1/MGen.mod

IMPLEMENTATION MODULE MGen;

IMPORT FileIO, SymTab;

CONST
  MaxCode = 8191;
  MaxImg  = 16383;
  MaxGlb  = 255;
  MaxInit = 255;
  MaxLab  = 255;
  MaxFix  = 2047;
  MaxLoop = 15;
  MaxActDepth = 7;
  MaxActN = 63;

  (* opcodes, see mc64-spec.md §11 *)
  OPdup = 20H;  OPswap = 21H;
  OPloadGlb = 2DH;  OPstoreGlb = 3DH;
  OPloadLocal = 2CH;  OPstoreLocal = 3CH;
  OPloadStk = 2EH;
  OPloadIndir0 = 60H;  OPstoreIndir0 = 70H;
  OPloadOuterN = 11H;
  OPloadIndir = 41H;  OPstoreIndir = 51H;
  OPlocalAddr = 80H;  OPglobalAddr = 81H;  OPstkAddr = 82H;
  OPext = 40H;  SUBdrop = 00H;
  OPenter = 0D4H;  OPprocLeave = 84H;  OPfctLeave = 85H;
  OPprocCall = 0EDH;  OPnestedCall = 0ECH;  OPcallFrame = 0EEH;
  OPimmB = 8DH;  OPimmW = 8EH;  OPimm0 = 90H;
  OPadd = 0A6H;  OPsub = 0A7H;  OPumul = 0A8H;
  OPudiv = 0A9H;  OPumod = 0AAH;
  OPaeq0 = 0ABH;  OPinc = 0ACH;  OPdec = 0ADH;
  OPeq = 0A0H;  OPne = 0A1H;
  OPult = 0A2H;  OPugt = 0A3H;  OPule = 0A4H;  OPuge = 0A5H;
  OPilt = 0B2H;  OPigt = 0B3H;  OPile = 0B4H;  OPige = 0B5H;
  OPnot = 0B6H;
  OPimul = 0B8H;  OPidiv = 0B9H;
  OPintToLong = 0BDH;  OPlongToReal = 0BEH;
  OPrCmp = 0D5H;  OPrAdd = 0D6H;  OPrSub = 0D7H;
  OPrMul = 0D8H;  OPrDiv = 0D9H;
  OPor = 0E6H;  OPand = 0E8H;
  OPpower2 = 0EAH;  OPbitIn = 0E7H;
  OPjp = 0E0H;  OPjz = 0E1H;
  OPsys = 0C3H;  OPend = 50H;

  (* image layout *)
  HeadSize = 64;
  DName = 264;  DChecksum = 288;  DFlags = 292;
  DVarCount = 293;  DDepCount = 294;  DProcs = 296;
  DVarSizes = 304;

TYPE
  FixRec = RECORD
    pos : CARDINAL;
    lab : INTEGER;
  END;
  InitRec = RECORD
    idx  : CARDINAL;
    kind : INTEGER;  (* 0 = INTEGER value, 1 = raw 64-bit pattern *)
    ival : INTEGER;
    bits : LONGCARD;
  END;
  RealView = RECORD CASE : BOOLEAN OF
               | TRUE : r : REAL;
               | FALSE : w : LONGCARD;
             END;
           END;
  ActFrame = RECORD
    n : CARDINAL;
    tmps : ARRAY [0 .. MaxActN] OF INTEGER;
    lens : ARRAY [0 .. MaxActN] OF INTEGER;
    sfxs : ARRAY [0 .. MaxActN] OF BOOLEAN;
    idxs : ARRAY [0 .. MaxActN] OF BOOLEAN;
    known : BOOLEAN;
    nf : CARDINAL;
    pn : ARRAY [0 .. 63] OF CHAR;
  END;

VAR
  code : ARRAY [0 .. MaxCode] OF CHAR;
  nCode : CARDINAL;
  img : ARRAY [0 .. MaxImg] OF CHAR;
  modName : ARRAY [0 .. 63] OF CHAR;
  gNames : ARRAY [0 .. MaxGlb] OF ARRAY [0 .. 63] OF CHAR;
  vBase : ARRAY [0 .. MaxGlb] OF CARDINAL;
  vSize : ARRAY [0 .. MaxGlb] OF CARDINAL;
  nVars : CARDINAL;
  nGlb : CARDINAL;
  inits : ARRAY [0 .. MaxInit] OF InitRec;
  nInit : CARDINAL;
  inBody : BOOLEAN;
  labs : ARRAY [0 .. MaxLab] OF INTEGER;
  nLab : CARDINAL;
  fixs : ARRAY [0 .. MaxFix] OF FixRec;
  nFix : CARDINAL;
  loopSt : ARRAY [0 .. MaxLoop] OF INTEGER;
  loopTop : CARDINAL;
  noSup : CARDINAL;
  noEmit : CARDINAL;
  actSt : ARRAY [0 .. MaxActDepth] OF ActFrame;
  actTop : CARDINAL;
  withTmps : ARRAY [0 .. 7] OF INTEGER;
  withTyps : ARRAY [0 .. 7] OF INTEGER;
  withTop : CARDINAL;
  procAddr : ARRAY [0 .. 64] OF INTEGER;
  maxNum : CARDINAL;
  mainAddr : CARDINAL;

(* ---------------- byte helpers ---------------- *)

PROCEDURE StrLen (s: ARRAY OF CHAR): CARDINAL;
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(s)) & (s[i] # 0C) DO INC(i) END;
    RETURN i
  END StrLen;

PROCEDURE StrCpy (VAR d: ARRAY OF CHAR; s: ARRAY OF CHAR);
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(d)) & (i < HIGH(s)) & (s[i] # 0C) DO
      d[i] := s[i]; INC(i)
    END;
    IF i <= HIGH(d) THEN d[i] := 0C END
  END StrCpy;

PROCEDURE EmitByte (b: CARDINAL);
  BEGIN
    IF noEmit > 0 THEN RETURN END;
    IF nCode <= MaxCode THEN
      code[nCode] := CHR(b MOD 256); INC(nCode)
    END
  END EmitByte;

PROCEDURE EmitOp (o: CARDINAL);
  BEGIN
    EmitByte(o)
  END EmitOp;

PROCEDURE EmitOpB (o, b: CARDINAL);
  BEGIN
    EmitByte(o); EmitByte(b)
  END EmitOpB;

PROCEDURE EmitW64 (v: LONGCARD);
  VAR j : CARDINAL;
  BEGIN
    FOR j := 0 TO 7 DO
      EmitByte(VAL(CARDINAL, v MOD 256)); v := v DIV 256
    END
  END EmitW64;

PROCEDURE EmitS64 (rel: INTEGER);
(* Appends a signed 64-bit little-endian offset. *)
  VAR mag : CARDINAL;
  BEGIN
    IF rel >= 0 THEN EmitW64(VAL(LONGCARD, VAL(CARDINAL, rel)))
    ELSE
      IF rel = -2147483647 - 1 THEN mag := 80000000H
      ELSE mag := VAL(CARDINAL, -rel)
      END;
      EmitW64(0FFFFFFFFFFFFFFFFH - VAL(LONGCARD, mag) + 1H)
    END
  END EmitS64;

PROCEDURE WriteS64At (off: CARDINAL; rel: INTEGER);
(* Backpatches a signed offset into already-emitted code. *)
  VAR mag : CARDINAL;
    bits : LONGCARD;
    j : CARDINAL;
  BEGIN
    IF rel >= 0 THEN bits := VAL(LONGCARD, VAL(CARDINAL, rel))
    ELSE
      IF rel = -2147483647 - 1 THEN mag := 80000000H
      ELSE mag := VAL(CARDINAL, -rel)
      END;
      bits := 0FFFFFFFFFFFFFFFFH - VAL(LONGCARD, mag) + 1H
    END;
    FOR j := 0 TO 7 DO
      code[off + j] := CHR(VAL(CARDINAL, bits MOD 256));
      bits := bits DIV 256
    END
  END WriteS64At;

PROCEDURE FindVar (name: ARRAY OF CHAR): INTEGER;
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE i < nVars DO
      IF SymTab.Equal(gNames[i], name) THEN
        RETURN VAL(INTEGER, vBase[i])
      END;
      INC(i)
    END;
    RETURN -1
  END FindVar;

PROCEDURE QualGlob (name: ARRAY OF CHAR; VAR q: ARRAY OF CHAR);
  VAR m: SymTab.Name;
    i, k: CARDINAL;
  BEGIN
    IF SymTab.InModule() & (SymTab.SymLev(name) > 0) THEN
      SymTab.CurModName(m);
      i := 0; k := 0;
      WHILE (k < HIGH(q)) & (m[i] # 0C) DO
        q[k] := m[i]; INC(k); INC(i)
      END;
      IF k <= HIGH(q) THEN q[k] := "."; INC(k) END;
      i := 0;
      WHILE (k < HIGH(q)) & (name[i] # 0C) DO
        q[k] := name[i]; INC(k); INC(i)
      END;
      IF k <= HIGH(q) THEN q[k] := 0C END
    ELSE
      StrCpy(q, name)
    END
  END QualGlob;

PROCEDURE AssignSlots (name: ARRAY OF CHAR; n: CARDINAL): INTEGER;
  VAR base : CARDINAL;
  BEGIN
    IF nVars > MaxGlb THEN RETURN -1 END;
    IF n = 0 THEN
      StrCpy(gNames[nVars], name);
      vBase[nVars] := nGlb;
      vSize[nVars] := 0;
      INC(nVars);
      RETURN VAL(INTEGER, nGlb)
    END;
    IF nGlb + n - 1 > MaxGlb THEN RETURN -1 END;
    StrCpy(gNames[nVars], name);
    base := nGlb;
    vBase[nVars] := base;
    vSize[nVars] := n;
    INC(nVars);
    nGlb := nGlb + n;
    RETURN VAL(INTEGER, base)
  END AssignSlots;

PROCEDURE AssignSlot (name: ARRAY OF CHAR): INTEGER;
  BEGIN
    RETURN AssignSlots(name, 1)
  END AssignSlot;

(* ---------------- module / data section ---------------- *)

PROCEDURE OpenModule (name: ARRAY OF CHAR);
  VAR i : CARDINAL;
    dummy : INTEGER;
  BEGIN
    StrCpy(modName, name);
    nCode := 0; nGlb := 0; nVars := 0; nInit := 0;
    nLab := 0; nFix := 0; loopTop := 0; noSup := 0; noEmit := 0;
  actTop := 0; withTop := 0;
    maxNum := 0; mainAddr := 0;
    i := 0;
    WHILE i <= 64 DO procAddr[i] := -1; INC(i) END;
    inBody := FALSE;
    i := 0;
    WHILE i <= MaxGlb DO gNames[i][0] := 0C; INC(i) END;
    (* slots 0..3 belong to the print helper *)
    dummy := AssignSlot(""); dummy := AssignSlot("");
    dummy := AssignSlot(""); dummy := AssignSlot("")
  END OpenModule;

PROCEDURE DeclVar (name: ARRAY OF CHAR);
  VAR idx : INTEGER;
  BEGIN
    idx := AssignSlot(name);
    IF idx < 0 THEN RETURN END
  END DeclVar;

PROCEDURE DeclVarSized (name: ARRAY OF CHAR; slots: CARDINAL);
  VAR idx : INTEGER;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := AssignSlots(q, slots);
    IF idx < 0 THEN RETURN END
  END DeclVarSized;

PROCEDURE BufInit (idx: INTEGER; kind: INTEGER; ival: INTEGER;
                   bits: LONGCARD);
  BEGIN
    IF nInit > MaxInit THEN RETURN END;
    inits[nInit].idx := VAL(CARDINAL, idx);
    inits[nInit].kind := kind;
    inits[nInit].ival := ival;
    inits[nInit].bits := bits;
    INC(nInit)
  END BufInit;

PROCEDURE DeclConst (name: ARRAY OF CHAR; lit: LitStr; t: INTEGER);
  VAR idx : INTEGER;
    cls : INTEGER;
    v : INTEGER;
    c : CARDINAL;
    b : LONGCARD;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := AssignSlot(q);
    IF idx < 0 THEN RETURN END;
    cls := SymTab.ClassOf(t);
    IF ~IsLit(lit) OR (cls = SymTab.ClStr) THEN
      BufInit(idx, 0, 0, 0H); RETURN
    END;
    IF cls = SymTab.ClReal THEN
      IF ParseReal(lit, b) THEN BufInit(idx, 1, 0, b)
      ELSE BufInit(idx, 1, 0, 0H)
      END
    ELSIF SymTab.Equal(lit, "TRUE") THEN BufInit(idx, 0, 1, 0H)
    ELSIF SymTab.Equal(lit, "FALSE") THEN BufInit(idx, 0, 0, 0H)
    ELSIF ParseInt(lit, v) THEN BufInit(idx, 0, v, 0H)
    ELSIF ParseCard(lit, c) THEN
      BufInit(idx, 1, 0, VAL(LONGCARD, c))
    ELSE BufInit(idx, 0, 0, 0H)
    END
  END DeclConst;

PROCEDURE DeclConstInt (name: ARRAY OF CHAR; v: INTEGER);
  VAR idx : INTEGER;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := AssignSlot(q);
    IF idx < 0 THEN RETURN END;
    BufInit(idx, 0, v, 0H)
  END DeclConstInt;

PROCEDURE PushValue (kind: INTEGER; ival: INTEGER; bits: LONGCARD);
  BEGIN
    IF kind = 0 THEN PushInt(ival) ELSE PushBits(bits) END
  END PushValue;

PROCEDURE BeginBody;
  VAR i : CARDINAL;
  BEGIN
    IF inBody THEN RETURN END;
    inBody := TRUE;
    mainAddr := nCode;
    i := 0;
    WHILE i < nInit DO
      PushValue(inits[i].kind, inits[i].ival, inits[i].bits);
      EmitOpB(OPstoreGlb, inits[i].idx);
      INC(i)
    END
  END BeginBody;

(* ---------------- loads, stores, pushes ---------------- *)

PROCEDURE LoadVar (name: ARRAY OF CHAR);
  VAR idx : INTEGER;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := FindVar(q);
    IF idx < 0 THEN EmitOp(OPimm0)
    ELSE EmitOpB(OPloadGlb, VAL(CARDINAL, idx))
    END
  END LoadVar;

PROCEDURE StoreVar (name: ARRAY OF CHAR);
  VAR idx : INTEGER;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := FindVar(q);
    IF idx < 0 THEN EmitOp(OPext); EmitOp(SUBdrop)
    ELSE EmitOpB(OPstoreGlb, VAL(CARDINAL, idx))
    END
  END StoreVar;

PROCEDURE LoadTemp (t: INTEGER);
  BEGIN
    EmitOpB(OPloadGlb, VAL(CARDINAL, t))
  END LoadTemp;

PROCEDURE StoreTemp (t: INTEGER);
  BEGIN
    EmitOpB(OPstoreGlb, VAL(CARDINAL, t))
  END StoreTemp;

PROCEDURE TempGlobal (): INTEGER;
  VAR idx : INTEGER;
  BEGIN
    idx := AssignSlot("");
    IF idx < 0 THEN RETURN 4 END;
    RETURN idx
  END TempGlobal;

(* ---------------- frames and procedures ---------------- *)

PROCEDURE EmitSlotB (op: CARDINAL; sl: INTEGER);
(* Byte operand for a (possibly negative) frame slot. *)
  BEGIN
    IF sl >= 0 THEN EmitOpB(op, VAL(CARDINAL, sl))
    ELSE EmitOpB(op, 256 - VAL(CARDINAL, -sl))
    END
  END EmitSlotB;

PROCEDURE LoadLocal (sl: INTEGER);
  BEGIN
    EmitSlotB(OPloadLocal, sl)
  END LoadLocal;

PROCEDURE StoreLocal (sl: INTEGER);
  BEGIN
    EmitSlotB(OPstoreLocal, sl)
  END StoreLocal;

PROCEDURE LoadIndir0;
  BEGIN
    EmitOp(OPloadIndir0)
  END LoadIndir0;

PROCEDURE StoreIndir0;
  BEGIN
    EmitOp(OPstoreIndir0)
  END StoreIndir0;

PROCEDURE FrameAddr (sl: INTEGER; np: CARDINAL);
(* Pushes (display-frame(np) + slot*8): 11H np, then the offset. *)
  BEGIN
    EmitOpB(OPloadOuterN, np);
    IF sl >= 0 THEN EmitOpB(OPstkAddr, VAL(CARDINAL, sl))
    ELSE
      PushInt(sl * 8);
      EmitOp(OPadd)
    END
  END FrameAddr;

PROCEDURE LoadIndir;
  BEGIN
    EmitOp(OPloadIndir)
  END LoadIndir;

PROCEDURE StoreIndir;
  BEGIN
    EmitOp(OPstoreIndir)
  END StoreIndir;

PROCEDURE LocalAddr (sl: INTEGER);
  BEGIN
    EmitSlotB(OPlocalAddr, sl)
  END LocalAddr;

PROCEDURE GlobalAddr (name: ARRAY OF CHAR);
  VAR idx : INTEGER;
    q: ARRAY [0 .. 63] OF CHAR;
  BEGIN
    QualGlob(name, q);
    idx := FindVar(q);
    IF idx < 0 THEN EmitOp(OPimm0)
    ELSE EmitOpB(OPglobalAddr, VAL(CARDINAL, idx))
    END
  END GlobalAddr;

PROCEDURE PushAddr (name: ARRAY OF CHAR);
(* VAR-actual address: slot contents for VAR params, slot address
   for plain variables; display-aware. *)
  VAR k, d, D, sl : INTEGER;
    np : CARDINAL;
  BEGIN
    k := SymTab.SymKind(name);
    d := SymTab.SymDepth(name);
    D := SymTab.CurDepth();
    sl := SymTab.SymSlot(name);
    IF (k # SymTab.KindVar) & (k # SymTab.KindParam)
       & (k # SymTab.KindVarPar) THEN
      EmitOp(OPimm0); RETURN
    END;
    IF (k = SymTab.KindVarPar)
       OR ((k = SymTab.KindParam)
           & SymTab.IsOpen(SymTab.SymType(name))) THEN
      IF D = d THEN LoadLocal(sl)
      ELSE
        np := VAL(CARDINAL, D - 1 - d);
        FrameAddr(sl, np);
        LoadIndir
      END
    ELSE
      IF d = 0 THEN GlobalAddr(name)
      ELSIF D = d THEN LocalAddr(sl)
      ELSE
        np := VAL(CARDINAL, D - 1 - d);
        FrameAddr(sl, np)
      END
    END
  END PushAddr;

PROCEDURE StoreSetup (name: ARRAY OF CHAR);
(* Early address for indirect stores; call before the value code. *)
  VAR k, d, D, sl : INTEGER;
    np : CARDINAL;
  BEGIN
    k := SymTab.SymKind(name);
    IF (k # SymTab.KindVar) & (k # SymTab.KindParam)
       & (k # SymTab.KindVarPar) THEN
      RETURN
    END;
    d := SymTab.SymDepth(name);
    D := SymTab.CurDepth();
    sl := SymTab.SymSlot(name);
    IF k = SymTab.KindVarPar THEN
      IF D = d THEN LoadLocal(sl)
      ELSE
        np := VAL(CARDINAL, D - 1 - d);
        FrameAddr(sl, np);
        LoadIndir
      END
    ELSIF (d # 0) & (D # d) THEN
      np := VAL(CARDINAL, D - 1 - d);
      FrameAddr(sl, np)
    END
  END StoreSetup;

PROCEDURE StoreFinish (name: ARRAY OF CHAR);
(* Completes the store; call after the value code. *)
  VAR k, d, D, sl : INTEGER;
  BEGIN
    k := SymTab.SymKind(name);
    IF (k # SymTab.KindVar) & (k # SymTab.KindParam)
       & (k # SymTab.KindVarPar) THEN
      RETURN
    END;
    d := SymTab.SymDepth(name);
    D := SymTab.CurDepth();
    sl := SymTab.SymSlot(name);
    IF d = 0 THEN StoreVar(name)
    ELSIF D = d THEN
      IF k = SymTab.KindVarPar THEN StoreIndir0
      ELSE StoreLocal(sl)
      END
    ELSE
      IF k = SymTab.KindVarPar THEN StoreIndir0
      ELSE StoreIndir
      END
    END
  END StoreFinish;

PROCEDURE PushVar (name: ARRAY OF CHAR);
(* Frame-aware value load (see PushAddr for the address twin). *)
  VAR k, d, D, sl : INTEGER;
    np : CARDINAL;
  BEGIN
    k := SymTab.SymKind(name);
    d := SymTab.SymDepth(name);
    D := SymTab.CurDepth();
    sl := SymTab.SymSlot(name);
    IF (k # SymTab.KindVar) & (k # SymTab.KindParam)
       & (k # SymTab.KindVarPar) THEN
      EmitOp(OPimm0); RETURN
    END;
    IF d = 0 THEN LoadVar(name)
    ELSIF D = d THEN
      IF k = SymTab.KindVarPar THEN
        LoadLocal(sl); LoadIndir0
      ELSE LoadLocal(sl)
      END
    ELSE
      np := VAL(CARDINAL, D - 1 - d);
      FrameAddr(sl, np);
      LoadIndir;
      IF k = SymTab.KindVarPar THEN LoadIndir0 END
    END
  END PushVar;

PROCEDURE ProcEntry (num: INTEGER; nLoc: CARDINAL);
  VAR k : CARDINAL;
  BEGIN
    IF (num >= 0) & (num <= 64) THEN
      procAddr[num] := VAL(INTEGER, nCode);
      IF VAL(CARDINAL, num) > maxNum THEN
        maxNum := VAL(CARDINAL, num)
      END
    END;
    IF nLoc > 255 THEN k := 255 ELSE k := nLoc END;
    EmitOpB(OPenter, 255 - k)
  END ProcEntry;

PROCEDURE CallProc (num: INTEGER);
  BEGIN
    EmitOpB(OPprocCall, VAL(CARDINAL, num))
  END CallProc;

PROCEDURE CallNested (num: INTEGER);
  BEGIN
    EmitOpB(OPnestedCall, VAL(CARDINAL, num))
  END CallNested;

PROCEDURE CallDisplay (num: INTEGER; np: CARDINAL);
  BEGIN
    EmitOpB(OPloadOuterN, np);
    EmitOpB(OPcallFrame, VAL(CARDINAL, num))
  END CallDisplay;

PROCEDURE Leave (nPar: CARDINAL; func: BOOLEAN);
  BEGIN
    IF nPar > 255 THEN nPar := 255 END;
    IF func THEN EmitOpB(OPfctLeave, nPar)
    ELSE EmitOpB(OPprocLeave, nPar)
    END
  END Leave;

(* ---------------- actual parameters ---------------- *)

PROCEDURE ActFrameIdx (): CARDINAL;
(* Active frame, capped (nesting past the cap reuses the top). *)
  BEGIN
    IF actTop = 0 THEN RETURN 0 END;
    IF actTop - 1 > MaxActDepth THEN RETURN MaxActDepth END;
    RETURN actTop - 1
  END ActFrameIdx;

PROCEDURE ActIsVarNext (): BOOLEAN;
  VAR fr, i: CARDINAL;
  BEGIN
    IF actTop = 0 THEN RETURN FALSE END;
    fr := ActFrameIdx();
    IF ~actSt[fr].known THEN RETURN FALSE END;
    i := actSt[fr].n;
    IF i >= actSt[fr].nf THEN RETURN FALSE END;
    RETURN SymTab.ParamIsVar(actSt[fr].pn, i)
  END ActIsVarNext;

PROCEDURE NoteSfx (b: BOOLEAN);
  VAR fr, i: CARDINAL;
  BEGIN
    IF actTop = 0 THEN RETURN END;
    fr := ActFrameIdx();
    i := actSt[fr].n;
    IF i <= MaxActN THEN actSt[fr].sfxs[i] := b END
  END NoteSfx;

PROCEDURE NoteIdx (b: BOOLEAN);
  VAR fr, i: CARDINAL;
  BEGIN
    IF actTop = 0 THEN RETURN END;
    fr := ActFrameIdx();
    i := actSt[fr].n;
    IF i <= MaxActN THEN actSt[fr].idxs[i] := b END
  END NoteIdx;

PROCEDURE ActBegin (pn: ARRAY OF CHAR);
  VAR fr : CARDINAL;
    k : CARDINAL;
  BEGIN
    fr := actTop;
    IF fr > MaxActDepth THEN fr := MaxActDepth
    ELSE INC(actTop)
    END;
    StrCpy(actSt[fr].pn, pn);
    actSt[fr].n := 0;
    k := 0;
    WHILE k <= MaxActN DO
      actSt[fr].lens[k] := -1;
      actSt[fr].sfxs[k] := FALSE;
      actSt[fr].idxs[k] := TRUE;
      INC(k)
    END;
    actSt[fr].known := SymTab.Lookup(pn)
      & (SymTab.SymKind(pn) = SymTab.KindProc);
    IF actSt[fr].known THEN actSt[fr].nf := SymTab.ProcNPar(pn)
    ELSE actSt[fr].nf := 0
    END
  END ActBegin;

PROCEDURE ActValue (t: INTEGER; v: BOOLEAN;
                    vn: ARRAY OF CHAR): INTEGER;
  VAR fr : CARDINAL;
    i : CARDINAL;
    ftyp : INTEGER;
    fv : BOOLEAN;
    err : INTEGER;
  BEGIN
    err := 0;
    fr := ActFrameIdx();
    i := actSt[fr].n;
    IF i > MaxActN THEN
      EmitOp(OPext); EmitOp(SUBdrop);
      actSt[fr].n := i + 1;
      RETURN 1
    END;
    IF actSt[fr].known & (i < actSt[fr].nf) THEN
      ftyp := SymTab.ParamType(actSt[fr].pn, i);
      fv := SymTab.ParamIsVar(actSt[fr].pn, i);
      IF SymTab.IsOpen(ftyp) THEN
        IF (t = SymTab.InvalidType)
           OR SymTab.IsOpen(t)
           OR (SymTab.ClassOf(t) # SymTab.ClArray) THEN
          err := 1
        ELSIF ~SymTab.SameType(SymTab.ArrayElem(t),
                               SymTab.ArrayElem(ftyp)) THEN
          err := 1
        ELSIF fv & ~v THEN
          err := 1
        END;
        IF (t # SymTab.InvalidType)
           & (SymTab.ClassOf(t) = SymTab.ClArray)
           & ~SymTab.IsOpen(t) THEN
          PushInt(VAL(INTEGER, SymTab.ArrayLen(t)))
        ELSE
          PushInt(0)
        END;
        actSt[fr].lens[i] := TempGlobal();
        StoreTemp(actSt[fr].lens[i]);
        IF fv THEN
          EmitOp(OPext); EmitOp(SUBdrop);
          PushAddr(vn)
        END
      ELSIF fv THEN
        IF ~v THEN err := 1
        ELSIF ~SymTab.SameType(t, ftyp) THEN err := 1
        END;
        EmitOp(OPext); EmitOp(SUBdrop);
        PushAddr(vn)
      ELSE
        IF ~SymTab.Assignable(t, ftyp) THEN err := 1
        ELSIF SymTab.IsIntFamily(t)
              & (SymTab.ClassOf(ftyp) = SymTab.ClReal) THEN
          IntToReal
        END
      END
    END;
    actSt[fr].tmps[i] := TempGlobal();
    StoreTemp(actSt[fr].tmps[i]);
    actSt[fr].n := i + 1;
    RETURN err
  END ActValue;

PROCEDURE ActEnd (pn: ARRAY OF CHAR; sfx, inExpr: BOOLEAN): INTEGER;
  VAR fr : CARDINAL;
    i : CARDINAL;
    n, num, F, d : INTEGER;
  BEGIN
    fr := ActFrameIdx();
    IF actTop > 0 THEN DEC(actTop) END;
    n := VAL(INTEGER, actSt[fr].n);
    IF ~SymTab.Lookup(pn) THEN
      IF inExpr THEN EmitOp(OPimm0) END;
      RETURN 0
    END;
    IF (SymTab.SymKind(pn) # SymTab.KindProc)
       OR sfx
       OR (n # VAL(INTEGER, SymTab.ProcNPar(pn))) THEN
      IF inExpr THEN EmitOp(OPimm0) END;
      RETURN 1
    END;
    IF inExpr & (SymTab.ProcRet(pn) = SymTab.InvalidType) THEN
      EmitOp(OPimm0);
      RETURN 1
    END;
    i := actSt[fr].n;
    WHILE i > 0 DO
      DEC(i);
      IF i <= MaxActN THEN
        IF (actSt[fr].lens[i] >= 0)
           & SymTab.IsOpen(SymTab.ParamType(pn, i)) THEN
          LoadTemp(actSt[fr].lens[i]);
          LoadTemp(actSt[fr].tmps[i])
        ELSE
          LoadTemp(actSt[fr].tmps[i])
        END
      END
    END;
    num := SymTab.ProcNum(pn);
    F := SymTab.CurDepth();
    d := SymTab.SymDepth(pn);
    IF d = 0 THEN CallProc(num)
    ELSIF F = d THEN CallNested(num)
    ELSE CallDisplay(num, VAL(CARDINAL, F - 1 - d))
    END;
    IF ~inExpr & (SymTab.ProcRet(pn) # SymTab.InvalidType) THEN
      EmitOp(OPext); EmitOp(SUBdrop)
    END;
    RETURN 0
  END ActEnd;

PROCEDURE EmitMag (c: CARDINAL);
  BEGIN
    IF c <= 255 THEN EmitOpB(OPimmB, c)
    ELSE EmitOp(OPimmW); EmitW64(VAL(LONGCARD, c))
    END
  END EmitMag;

PROCEDURE PushInt (v: INTEGER);
  VAR mag : CARDINAL;
  BEGIN
    IF (v >= 0) & (v <= 15) THEN EmitOp(OPimm0 + VAL(CARDINAL, v))
    ELSIF v < 0 THEN
      IF v = -2147483647 - 1 THEN mag := 80000000H
      ELSE mag := VAL(CARDINAL, -v)
      END;
      EmitOp(OPimm0); EmitMag(mag); EmitOp(OPsub)
    ELSE EmitMag(VAL(CARDINAL, v))
    END
  END PushInt;

PROCEDURE PushBits (b: LONGCARD);
  BEGIN
    EmitOp(OPimmW); EmitW64(b)
  END PushBits;

(* ---------------- literal parsing ---------------- *)

PROCEDURE DigVal (ch: CHAR): INTEGER;
  BEGIN
    IF (ch >= "0") & (ch <= "9") THEN RETURN ORD(ch) - ORD("0") END;
    IF (ch >= "A") & (ch <= "F") THEN RETURN ORD(ch) - ORD("A") + 10 END;
    IF (ch >= "a") & (ch <= "f") THEN RETURN ORD(ch) - ORD("a") + 10 END;
    RETURN -1
  END DigVal;

PROCEDURE ParseCard (s: ARRAY OF CHAR; VAR v: CARDINAL): BOOLEAN;
  VAR i, n : CARDINAL;
    hex : BOOLEAN;
    d : INTEGER;
    acc : LONGCARD;
  BEGIN
    v := 0;
    n := StrLen(s);
    IF n = 0 THEN RETURN FALSE END;
    hex := (s[n - 1] = "H") OR (s[n - 1] = "h");
    IF hex THEN DEC(n) END;
    IF n = 0 THEN RETURN FALSE END;
    acc := 0H; i := 0;
    WHILE i < n DO
      d := DigVal(s[i]);
      IF hex THEN
        IF d < 0 THEN RETURN FALSE END;
        acc := acc * 16 + VAL(LONGCARD, VAL(CARDINAL, d))
      ELSE
        IF (d < 0) OR (d > 9) THEN RETURN FALSE END;
        acc := acc * 10 + VAL(LONGCARD, VAL(CARDINAL, d))
      END;
      IF acc > 0FFFFFFFFH THEN RETURN FALSE END;
      INC(i)
    END;
    v := VAL(CARDINAL, acc);
    RETURN TRUE
  END ParseCard;

PROCEDURE ParseInt (s: ARRAY OF CHAR; VAR v: INTEGER): BOOLEAN;
  VAR i : CARDINAL;
    neg : BOOLEAN;
    t : ARRAY [0 .. 63] OF CHAR;
    c : CARDINAL;
    lim : LONGCARD;
  BEGIN
    v := 0;
    IF (StrLen(s) = 0) THEN RETURN FALSE END;
    neg := s[0] = "-";
    IF neg THEN
      i := 1;
      WHILE s[i] # 0C DO
        IF i - 1 > HIGH(t) THEN RETURN FALSE END;
        t[i - 1] := s[i]; INC(i)
      END;
      IF i - 1 > HIGH(t) THEN RETURN FALSE END;
      t[i - 1] := 0C
    ELSE StrCpy(t, s)
    END;
    IF ~ParseCard(t, c) THEN RETURN FALSE END;
    IF neg THEN lim := 80000000H ELSE lim := 7FFFFFFFH END;
    IF VAL(LONGCARD, c) > lim THEN RETURN FALSE END;
    IF neg THEN
      IF VAL(LONGCARD, c) = 80000000H THEN v := -2147483647 - 1
      ELSE v := -VAL(INTEGER, c)
      END
    ELSE v := VAL(INTEGER, c)
    END;
    RETURN TRUE
  END ParseInt;

PROCEDURE ParseReal (s: ARRAY OF CHAR; VAR b: LONGCARD): BOOLEAN;
  VAR i : CARDINAL;
    neg, esign : BOOLEAN;
    m, scale : REAL;
    e, d : CARDINAL;
    rv : RealView;
  BEGIN
    b := 0H;
    i := 0; neg := FALSE;
    IF s[0] = "-" THEN neg := TRUE; INC(i) END;
    IF (s[i] < "0") OR (s[i] > "9") THEN RETURN FALSE END;
    m := 0.0;
    WHILE (s[i] >= "0") & (s[i] <= "9") DO
      m := m * 10.0 + VAL(REAL, VAL(CARDINAL, ORD(s[i]) - ORD("0")));
      INC(i)
    END;
    IF s[i] = "." THEN
      INC(i);
      IF (s[i] < "0") OR (s[i] > "9") THEN RETURN FALSE END;
      scale := 10.0;
      WHILE (s[i] >= "0") & (s[i] <= "9") DO
        m := m + VAL(REAL, VAL(CARDINAL, ORD(s[i]) - ORD("0"))) / scale;
        scale := scale * 10.0;
        INC(i)
      END
    END;
    IF (s[i] = "E") OR (s[i] = "e") THEN
      INC(i); esign := FALSE;
      IF s[i] = "+" THEN INC(i)
      ELSIF s[i] = "-" THEN esign := TRUE; INC(i)
      END;
      IF (s[i] < "0") OR (s[i] > "9") THEN RETURN FALSE END;
      e := 0;
      WHILE (s[i] >= "0") & (s[i] <= "9") DO
        d := VAL(CARDINAL, ORD(s[i]) - ORD("0"));
        IF e <= 9999 THEN e := e * 10 + d END;
        INC(i)
      END;
      WHILE e > 0 DO
        IF esign THEN m := m / 10.0 ELSE m := m * 10.0 END;
        DEC(e)
      END
    END;
    IF s[i] # 0C THEN RETURN FALSE END;
    IF neg THEN m := -m END;
    rv.r := m;
    b := rv.w;
    RETURN TRUE
  END ParseReal;

PROCEDURE CharOrd (s: ARRAY OF CHAR): INTEGER;
  BEGIN
    IF StrLen(s) >= 2 THEN RETURN ORD(s[1]) END;
    RETURN 0
  END CharOrd;

PROCEDURE NegFold (a: ARRAY OF CHAR; VAR q: LitStr);
(* Safe for a and q being the same variable. *)
  VAR tmp : LitStr;
    i, j : CARDINAL;
  BEGIN
    StrCpy(tmp, a);
    IF StrLen(tmp) = 0 THEN StrCpy(q, ""); RETURN END;
    IF tmp[0] = "-" THEN
      i := 1; j := 0;
      WHILE (tmp[i] # 0C) & (j < HIGH(q)) DO
        q[j] := tmp[i]; INC(i); INC(j)
      END;
      IF j <= HIGH(q) THEN q[j] := 0C END
    ELSE
      StrCpy(q, "-");
      i := 0; j := StrLen(q);
      WHILE (tmp[i] # 0C) & (j < HIGH(q)) DO
        q[j] := tmp[i]; INC(i); INC(j)
      END;
      IF j <= HIGH(q) THEN q[j] := 0C END
    END
  END NegFold;

PROCEDURE IsLit (s: ARRAY OF CHAR): BOOLEAN;
  BEGIN
    RETURN StrLen(s) > 0
  END IsLit;

(* ---------------- operators ---------------- *)

PROCEDURE Add;
  BEGIN EmitOp(OPadd) END Add;
PROCEDURE Sub;
  BEGIN EmitOp(OPsub) END Sub;
PROCEDURE MulU;
  BEGIN EmitOp(OPumul) END MulU;
PROCEDURE DivU;
  BEGIN EmitOp(OPudiv) END DivU;
PROCEDURE ModU;
  BEGIN EmitOp(OPumod) END ModU;
PROCEDURE MulI;
  BEGIN EmitOp(OPimul) END MulI;
PROCEDURE DivI;
  BEGIN EmitOp(OPidiv) END DivI;
PROCEDURE ModI (t: INTEGER);
(* [a b] -> a MOD b (truncation) via temp t. *)
  BEGIN
    StoreTemp(t);
    EmitOp(OPdup);
    LoadTemp(t);
    EmitOp(OPidiv);
    LoadTemp(t);
    EmitOp(OPimul);
    EmitOp(OPsub)
  END ModI;

PROCEDURE RealAdd;
  BEGIN EmitOp(OPrAdd) END RealAdd;
PROCEDURE RealSub;
  BEGIN EmitOp(OPrSub) END RealSub;
PROCEDURE RealMul;
  BEGIN EmitOp(OPrMul) END RealMul;
PROCEDURE RealDiv;
  BEGIN EmitOp(OPrDiv) END RealDiv;

PROCEDURE And;
  BEGIN EmitOp(OPand) END And;
PROCEDURE Or;
  BEGIN EmitOp(OPor) END Or;
PROCEDURE Not;
  BEGIN EmitOp(OPnot) END Not;

PROCEDURE Power2;
  BEGIN EmitOp(OPpower2) END Power2;

PROCEDURE FieldMask;
  BEGIN EmitOp(OPext); EmitOp(04H) END FieldMask;

PROCEDURE BitIn;
  BEGIN EmitOp(OPbitIn) END BitIn;

PROCEDURE Eq;
  BEGIN EmitOp(OPeq) END Eq;
PROCEDURE Neq;
  BEGIN EmitOp(OPne) END Neq;
PROCEDURE ULt;
  BEGIN EmitOp(OPult) END ULt;
PROCEDURE ULe;
  BEGIN EmitOp(OPule) END ULe;
PROCEDURE UGt;
  BEGIN EmitOp(OPugt) END UGt;
PROCEDURE UGe;
  BEGIN EmitOp(OPuge) END UGe;
PROCEDURE ILt;
  BEGIN EmitOp(OPilt) END ILt;
PROCEDURE ILe;
  BEGIN EmitOp(OPile) END ILe;
PROCEDURE IGt;
  BEGIN EmitOp(OPigt) END IGt;
PROCEDURE IGe;
  BEGIN EmitOp(OPige) END IGe;

PROCEDURE RealEq;
(* [r1 r2] -> (r1 = r2): cmp, or, not. *)
  BEGIN EmitOp(OPrCmp); EmitOp(OPor); EmitOp(OPnot) END RealEq;
PROCEDURE RealNe;
(* [r1 r2] -> (r1 # r2): cmp, or. *)
  BEGIN EmitOp(OPrCmp); EmitOp(OPor) END RealNe;
PROCEDURE RealLt;
(* [gt lt] -> lt: swap, drop. *)
  BEGIN EmitOp(OPswap); EmitOp(OPext); EmitOp(SUBdrop) END RealLt;
PROCEDURE RealLe;
(* [gt lt] -> NOT gt: drop, not. *)
  BEGIN EmitOp(OPext); EmitOp(SUBdrop); EmitOp(OPnot) END RealLe;
PROCEDURE RealGt;
(* [gt lt] -> gt: drop. *)
  BEGIN EmitOp(OPext); EmitOp(SUBdrop) END RealGt;
PROCEDURE RealGe;
(* [gt lt] -> NOT lt: swap, drop, not. *)
  BEGIN
    EmitOp(OPswap); EmitOp(OPext); EmitOp(SUBdrop); EmitOp(OPnot)
  END RealGe;

PROCEDURE NegInt;
  BEGIN EmitOp(OPimm0); EmitOp(OPswap); EmitOp(OPsub) END NegInt;
PROCEDURE NegReal;
  BEGIN
    EmitOp(OPimmW); EmitW64(0H);
    EmitOp(OPswap); EmitOp(OPrSub)
  END NegReal;
PROCEDURE IntToReal;
  BEGIN EmitOp(OPintToLong); EmitOp(OPlongToReal) END IntToReal;

PROCEDURE Dup;
  BEGIN EmitOp(OPdup) END Dup;
PROCEDURE Drop;
  BEGIN EmitOp(OPext); EmitOp(SUBdrop) END Drop;
PROCEDURE Swap;
  BEGIN EmitOp(OPswap) END Swap;

(* ---------------- composites ---------------- *)

PROCEDURE IdxScale (lo: INTEGER; elemBytes: CARDINAL);
  BEGIN
    PushInt(lo);
    EmitOp(OPsub);
    PushInt(VAL(INTEGER, elemBytes));
    EmitOp(OPumul);
    EmitOp(OPadd)
  END IdxScale;

PROCEDURE FieldAdd (offSlots: CARDINAL);
  BEGIN
    IF offSlots = 0 THEN RETURN END;
    PushInt(VAL(INTEGER, offSlots * 8));
    EmitOp(OPadd)
  END FieldAdd;

PROCEDURE CopyBlock;
  BEGIN EmitOp(30H) END CopyBlock;

PROCEDURE LoadByte;
  BEGIN
    PushInt(0);
    EmitOp(0DH)
  END LoadByte;

PROCEDURE StoreByte;
  BEGIN
    PushInt(0);
    EmitOp(OPswap);
    EmitOp(1DH)
  END StoreByte;

PROCEDURE PushBytes (n: CARDINAL);
  BEGIN PushInt(VAL(INTEGER, n)) END PushBytes;

PROCEDURE AllocOp;
  BEGIN EmitOp(OPext); EmitOp(05H) END AllocOp;

PROCEDURE DeallocOp;
  BEGIN EmitOp(OPext); EmitOp(06H) END DeallocOp;

PROCEDURE BitXor;
  BEGIN EmitOp(0E9H) END BitXor;

PROCEDURE StrLenOf (s: ARRAY OF CHAR): CARDINAL;
  VAR n: CARDINAL;
  BEGIN
    n := StrLen(s);
    IF n < 2 THEN RETURN 0 END;
    RETURN n - 2
  END StrLenOf;

PROCEDURE EmitString (s: ARRAY OF CHAR);
  VAR len, i: CARDINAL;
  BEGIN
    len := StrLenOf(s);
    IF len + 1 > 255 THEN
      PushInt(0); RETURN
    END;
    EmitOp(8CH);
    EmitByte(len + 1);
    i := 1;
    WHILE i <= len DO
      EmitByte(ORD(s[i])); INC(i)
    END;
    EmitByte(0)
  END EmitString;

PROCEDURE StrComp;
  BEGIN EmitOp(0C4H) END StrComp;

(* ---------------- WITH ---------------- *)

PROCEDURE WithEnter (typ: INTEGER);
  VAR tmp: INTEGER;
  BEGIN
    tmp := TempGlobal();
    StoreTemp(tmp);
    IF withTop <= 7 THEN
      withTmps[withTop] := tmp;
      withTyps[withTop] := typ;
      INC(withTop)
    END
  END WithEnter;

PROCEDURE WithExit;
  BEGIN
    IF withTop > 0 THEN DEC(withTop) END
  END WithExit;

PROCEDURE WithDepth (): CARDINAL;
  BEGIN RETURN withTop END WithDepth;

PROCEDURE WithAddr (name: ARRAY OF CHAR);
  VAR i: CARDINAL;
    off: INTEGER;
    found: BOOLEAN;
  BEGIN
    found := FALSE;
    i := withTop;
    WHILE (i > 0) & ~found DO
      DEC(i);
      IF SymTab.FieldExists(withTyps[i], name) THEN
        off := SymTab.FieldOffset(withTyps[i], name);
        LoadTemp(withTmps[i]);
        IF off > 0 THEN
          PushInt(VAL(INTEGER, VAL(CARDINAL, off) * 8));
          EmitOp(OPadd)
        ELSIF off < 0 THEN
          PushInt(0)
        END;
        found := TRUE
      END
    END;
    IF ~found THEN PushInt(0) END
  END WithAddr;

PROCEDURE PrintNum (): CARDINAL;
  BEGIN RETURN maxNum + 1 END PrintNum;

PROCEDURE CallPrint;
  BEGIN
    EmitOpB(OPprocCall, maxNum + 1);
    EmitOp(OPext); EmitOp(SUBdrop)
  END CallPrint;

PROCEDURE SysCall;
  BEGIN EmitOp(OPsys) END SysCall;

(* ---------------- control flow ---------------- *)

PROCEDURE NewLabel (): INTEGER;
  BEGIN
    IF nLab > MaxLab THEN RETURN 0 END;
    labs[nLab] := -1;
    INC(nLab);
    RETURN VAL(INTEGER, nLab - 1)
  END NewLabel;

PROCEDURE DefLabel (id: INTEGER);
  VAR i : CARDINAL;
    rel : INTEGER;
  BEGIN
    IF (id < 0) OR (id >= VAL(INTEGER, nLab)) THEN RETURN END;
    labs[id] := VAL(INTEGER, nCode);
    i := 0;
    WHILE i < nFix DO
      IF fixs[i].lab = id THEN
        rel := labs[id] - VAL(INTEGER, fixs[i].pos + 9);
        WriteS64At(fixs[i].pos + 1, rel);
        fixs[i].lab := -1
      END;
      INC(i)
    END
  END DefLabel;

PROCEDURE Jump (op: CARDINAL; id: INTEGER);
  VAR pos : CARDINAL;
    j : CARDINAL;
  BEGIN
    pos := nCode;
    EmitOp(op);
    IF (id >= 0) & (id < VAL(INTEGER, nLab)) & (labs[id] >= 0) THEN
      EmitS64(labs[id] - VAL(INTEGER, pos + 9))
    ELSE
      FOR j := 0 TO 7 DO EmitByte(0) END;
      IF (nFix <= MaxFix) & (id >= 0) & (id < VAL(INTEGER, nLab)) THEN
        fixs[nFix].pos := pos; fixs[nFix].lab := id; INC(nFix)
      END
    END
  END Jump;

PROCEDURE Jmp (id: INTEGER);
  BEGIN
    Jump(OPjp, id)
  END Jmp;

PROCEDURE Jz (id: INTEGER);
  BEGIN
    Jump(OPjz, id)
  END Jz;

PROCEDURE PushLoop (exit: INTEGER);
  BEGIN
    IF loopTop <= MaxLoop THEN
      loopSt[loopTop] := exit; INC(loopTop)
    END
  END PushLoop;

PROCEDURE PopLoop;
  BEGIN
    IF loopTop > 0 THEN DEC(loopTop) END
  END PopLoop;

PROCEDURE TopLoop (VAR exit: INTEGER): BOOLEAN;
  BEGIN
    IF loopTop = 0 THEN RETURN FALSE END;
    exit := loopSt[loopTop - 1];
    RETURN TRUE
  END TopLoop;

PROCEDURE NoSupEnter;
  BEGIN
    INC(noSup)
  END NoSupEnter;

PROCEDURE NoSupExit;
  BEGIN
    IF noSup > 0 THEN DEC(noSup) END
  END NoSupExit;

PROCEDURE NoSup (): BOOLEAN;
  BEGIN
    RETURN noSup > 0
  END NoSup;

PROCEDURE CopyName (s: ARRAY OF CHAR; VAR d: ARRAY OF CHAR);
  VAR i : CARDINAL;
  BEGIN
    i := 0;
    WHILE (i < HIGH(d)) & (i < HIGH(s)) & (s[i] # 0C) DO
      d[i] := s[i]; INC(i)
    END;
    IF i <= HIGH(d) THEN d[i] := 0C END
  END CopyName;

PROCEDURE NoEmitEnter;
  BEGIN
    INC(noEmit)
  END NoEmitEnter;

PROCEDURE NoEmitExit;
  BEGIN
    IF noEmit > 0 THEN DEC(noEmit) END
  END NoEmitExit;

(* ---------------- image assembly ---------------- *)

PROCEDURE Put32At (off: CARDINAL; v: CARDINAL);
  BEGIN
    img[off] := CHR(v MOD 256);
    img[off + 1] := CHR((v DIV 256) MOD 256);
    img[off + 2] := CHR((v DIV 65536) MOD 256);
    img[off + 3] := CHR(v DIV 16777216)
  END Put32At;

PROCEDURE Put64At (off: CARDINAL; v: LONGCARD);
  VAR j : CARDINAL;
  BEGIN
    FOR j := 0 TO 7 DO
      img[off + j] := CHR(VAL(CARDINAL, v MOD 256));
      v := v DIV 256
    END
  END Put64At;

PROCEDURE EmitPrint;
(* proc1: prints the CARDINAL parameter as decimal + CRLF.
   Uses global temps 0..3 (buffer, count, index, char). *)
  VAR l1, l2 : INTEGER;
  BEGIN
    EmitOpB(OPenter, 250);
    EmitOpB(OPimmB, 16); EmitOp(0D2H); EmitOpB(OPstoreGlb, 0);
    EmitOp(OPimm0); EmitOp(OPimm0);
    EmitOpB(OPstoreGlb, 1); EmitOpB(OPstoreGlb, 2);
    EmitOp(03H);
    l1 := NewLabel(); DefLabel(l1);
    EmitOpB(OPloadGlb, 1); EmitOp(OPinc); EmitOpB(OPstoreGlb, 1);
    EmitOp(OPdup); EmitOpB(OPimmB, 10); EmitOp(OPumod);
    EmitOp(OPswap); EmitOpB(OPimmB, 10); EmitOp(OPudiv);
    EmitOp(OPdup); EmitOp(OPaeq0);
    Jz(l1);
    EmitOp(OPext); EmitOp(SUBdrop);
    l2 := NewLabel(); DefLabel(l2);
    EmitOpB(OPimmB, 48); EmitOp(OPadd); EmitOpB(OPstoreGlb, 3);
    EmitOpB(OPloadGlb, 0); EmitOpB(OPloadGlb, 2); EmitOp(OPadd);
    EmitOp(OPimm0); EmitOpB(OPloadGlb, 3); EmitOp(1DH);
    EmitOpB(OPloadGlb, 2); EmitOp(OPinc); EmitOpB(OPstoreGlb, 2);
    EmitOpB(OPloadGlb, 1); EmitOp(OPdec); EmitOpB(OPstoreGlb, 1);
    EmitOpB(OPloadGlb, 1); EmitOp(OPaeq0);
    Jz(l2);
    EmitOpB(OPloadGlb, 0); EmitOpB(OPloadGlb, 2); EmitOp(OPadd);
    EmitOp(OPimm0); EmitOp(OPimm0); EmitOp(1DH);
    EmitOpB(OPloadGlb, 0);
    EmitOpB(OPimmB, 1); EmitOp(OPsys);
    EmitOpB(OPimmB, 3); EmitOp(0D2H);
    EmitOp(OPdup); EmitOp(OPimm0); EmitOpB(OPimmB, 13); EmitOp(1DH);
    EmitOp(OPdup); EmitOpB(OPimmB, 1); EmitOpB(OPimmB, 10); EmitOp(1DH);
    EmitOp(OPdup); EmitOpB(OPimmB, 2); EmitOp(OPimm0); EmitOp(1DH);
    EmitOpB(OPimmB, 1); EmitOp(OPsys);
    EmitOpB(OPfctLeave, 0)
  END EmitPrint;

PROCEDURE PutS64At (off, addr, slot: CARDINAL);
(* Procedure-table cell: signed (addr - slot). *)
  VAR mag : LONGCARD;
    bits : LONGCARD;
    j : CARDINAL;
  BEGIN
    IF addr >= slot THEN bits := VAL(LONGCARD, addr - slot)
    ELSE
      mag := VAL(LONGCARD, slot - addr);
      bits := 0FFFFFFFFFFFFFFFFH - mag + 1H
    END;
    FOR j := 0 TO 7 DO
      img[off + j] := CHR(VAL(CARDINAL, bits MOD 256));
      bits := bits DIV 256
    END
  END PutS64At;

PROCEDURE EndModule;
  VAR i : CARDINAL;
    codeOff, p1, pt, prNum, tabBytes : CARDINAL;
    k : CARDINAL;
    addr : CARDINAL;
    exitIdx : INTEGER;
    sum : CARDINAL;
    fname : ARRAY [0 .. 127] OF CHAR;
    f : FileIO.File;
    ch : CHAR;
  BEGIN
    IF ~inBody THEN mainAddr := nCode END;
    prNum := maxNum + 1;
    (* epilogue: print ExitCode when the convention applies *)
    exitIdx := -1;
    IF SymTab.Lookup("ExitCode")
       & (SymTab.SymKind("ExitCode") = SymTab.KindVar)
       & SymTab.IsIntFamily(SymTab.SymType("ExitCode")) THEN
      exitIdx := FindVar("ExitCode")
    END;
    IF exitIdx >= 0 THEN
      EmitOpB(OPloadGlb, VAL(CARDINAL, exitIdx));
      EmitOpB(OPprocCall, prNum);
      EmitOp(OPext); EmitOp(SUBdrop)
    END;
    EmitOp(OPend);
    p1 := nCode;
    EmitPrint;
    (* assemble the image *)
    i := 0;
    WHILE i <= MaxImg DO img[i] := 0C; INC(i) END;
    img[0] := "M"; img[1] := "C"; img[2] := "6"; img[3] := "4";
    i := 0;
    WHILE (i < 16) & (modName[i] # 0C) DO
      img[HeadSize + DName + i] := modName[i]; INC(i)
    END;
    img[HeadSize + DFlags] := CHR(4);
    img[HeadSize + DVarCount] := CHR(nVars MOD 256);
    img[HeadSize + DDepCount] := 0C;
    codeOff := DVarSizes + nVars * 8;
    i := 0;
    WHILE i < nCode DO
      img[HeadSize + codeOff + i] := code[i]; INC(i)
    END;
    pt := codeOff + nCode;
    tabBytes := (maxNum + 2) * 8;
    Put64At(HeadSize + DProcs, VAL(LONGCARD, pt));
    k := 0;
    WHILE k <= maxNum + 1 DO
      IF k = 0 THEN addr := codeOff + mainAddr
      ELSIF k <= maxNum THEN
        IF procAddr[k] < 0 THEN addr := pt + k * 8
        ELSE addr := VAL(CARDINAL, procAddr[k]) + codeOff
        END
      ELSE addr := codeOff + p1
      END;
      PutS64At(HeadSize + pt + k * 8, addr, pt + k * 8);
      INC(k)
    END;
    i := 0;
    WHILE i < nVars DO
      Put64At(HeadSize + DVarSizes + i * 8,
              VAL(LONGCARD, vSize[i] * 8));
      INC(i)
    END;
    sum := 0;
    i := HeadSize;
    WHILE i < HeadSize + pt + tabBytes DO
      IF ~((i >= 352) & (i <= 355)) THEN
        sum := sum + ORD(img[i])
      END;
      INC(i)
    END;
    Put32At(HeadSize + DChecksum, sum);
    fname[0] := 0C;
    StrCpy(fname, modName);
    i := StrLen(fname);
    fname[i] := "."; fname[i + 1] := "M"; fname[i + 2] := "C";
    fname[i + 3] := "4"; fname[i + 4] := 0C;
    FileIO.Open(f, fname, TRUE);
    IF FileIO.Okay THEN
      i := 0;
      WHILE i < HeadSize + pt + tabBytes DO
        ch := img[i];
        FileIO.Write(f, ch);
        INC(i)
      END;
      FileIO.Close(f)
    END
  END EndModule;

BEGIN
  nCode := 0; nGlb := 0; nVars := 0; nInit := 0;
  nLab := 0; nFix := 0; loopTop := 0; noSup := 0; noEmit := 0;
  actTop := 0; withTop := 0;
  maxNum := 0; mainAddr := 0;
  inBody := FALSE;
  modName[0] := 0C
END MGen.