ui/src/vbt/VBT.m3


 Copyright (C) 1992, Digital Equipment Corporation 
 All rights reserved. 
 See the file COPYRIGHT for a full description. 
 
 by Steve Glassman, Mark Manasse and Greg Nelson 
 Last modified on Tue Jan 31 09:52:22 PST 1995 by kalsow   
      modified on Mon Feb 14 16:10:36 PST 1994 by msm      
      modified on Wed Jul 28 13:15:28 PDT 1993 by sfreeman 
 modified on Thu Apr 29 11:03:49 PDT 1993 by mjordan 
 modified on Fri Apr 16 09:07:45 PDT 1993 by steveg 
 modified on Mon Feb 24 13:58:32 PST 1992 by muller 
 modified on Mon Dec 30 18:11:51 PST 1991 by gnelson 

<*PRAGMA LL*>

UNSAFE MODULE VBT;

IMPORT Word, Thread, Rect, Point, Axis, Path, Trapezoid, Region, Pixmap,
       Cursor, Font, PaintOp, ScrnPixmap, BatchRep, ScrnFont, ScrnPaintOp,
       Text, VBTClass, VBTRep, TextWr, Cstring, PaintExt, PaintPrivate,
       Pickle, TextRd, PropertyV, PathPrivate, TextIntTbl, Wr, Rd,
       Palette, PlttFrnds, RTParams, MutexRep;

PROCEDURE CopyBytes (src, dst: ADDRESS; n: INTEGER) =
  BEGIN
    EVAL Cstring.memcpy(dst, src, n)
  END CopyBytes;

PROCEDURE Parent (v: T): Split RAISES {} =
  BEGIN
    LOCK v DO RETURN v.parent END
  END Parent;

PROCEDURE Domain (v: T): Rect.T RAISES {} =
  BEGIN
    LOCK v DO RETURN v.domain END
  END Domain;

PROCEDURE ScreenTypeOf (v: T): ScreenType RAISES {} =
  BEGIN
    LOCK v DO RETURN v.st END
  END ScreenTypeOf;

PROCEDURE MMToPixels (v: T; mm: REAL; ax: Axis.T): REAL RAISES {} =
  BEGIN
    LOCK v DO
      IF v.st = NIL THEN RETURN mm ELSE RETURN mm * v.st.res[ax] END
    END
  END MMToPixels;

PROCEDURE SetCage (v: T; READONLY cg: Cage) RAISES {} =
  BEGIN
    LOCK v DO VBTClass.SetCage(v, cg) END
  END SetCage;

PROCEDURE Outside (READONLY cp: CursorPosition; READONLY cg: Cage): BOOLEAN
  RAISES {} =
  BEGIN
    RETURN NOT ((cp.gone IN cg.inOut)
                  AND ((cg.screen = AllScreens) OR (cg.screen = cp.screen))
                  AND Rect.Member(cp.pt, cg.rect))
  END Outside;

PROCEDURE CageFromRect (READONLY r: Rect.T; READONLY cp: CursorPosition):
  Cage =
  BEGIN
    RETURN Cage{r, InOut{cp.gone}, cp.screen}
  END CageFromRect;

PROCEDURE CageFromPosition (READONLY cp: CursorPosition;
                            trackOutside, trackOffScreen: BOOLEAN := FALSE):
  Cage =
  BEGIN
    IF NOT cp.gone OR trackOutside AND NOT cp.offScreen OR trackOffScreen THEN
      RETURN Cage{Rect.FromPoint(cp.pt), InOut{cp.gone}, cp.screen}
    ELSIF cp.offScreen AND trackOutside THEN
      RETURN Cage{Rect.Full, InOut{FALSE, TRUE}, cp.screen}
    ELSE
      RETURN GoneCage
    END
  END CageFromPosition;

PROCEDURE SetCursor (v: T; cs: Cursor.T) RAISES {} =
  BEGIN
    LOCK v DO VBTClass.SetCursor(v, cs) END
  END SetCursor;

REVEAL
  Value = Value_Public BRANDED OBJECT
            tc : INTEGER;
            txt: TEXT
          OVERRIDES
            toRef := ToRefDefault
          END;

PROCEDURE FromRef (v: REFANY): Value RAISES {} =
  <*FATAL Wr.Failure, Pickle.Error, Thread.Alerted *>
  VAR
    res           := NEW(Value);
    wr : TextWr.T;
  BEGIN
    res.tc := TYPECODE(v);
    IF v = NIL OR res.tc = TYPECODE(TEXT) THEN
      res.txt := v
    ELSE
      wr := TextWr.New();
      Pickle.Write(wr, v);
      res.txt := TextWr.ToText(wr)
    END;
    RETURN res
  END FromRef;

PROCEDURE ToRefDefault (v: Value): REFANY RAISES {Error} =
  <*FATAL Rd.Failure, Rd.EndOfFile, Thread.Alerted *>
  BEGIN
    IF v.txt = NIL OR v.tc = TYPECODE(TEXT) THEN RETURN v.txt END;
    TRY
      RETURN Pickle.Read(TextRd.New(v.txt))
    EXCEPT
      Pickle.Error => RAISE Error(ErrorCode.WrongType)
    END;
  END ToRefDefault;

PROCEDURE Ready (<*UNUSED*> v: Value): BOOLEAN =
  BEGIN
    RETURN TRUE
  END Ready;

PROCEDURE Read (v: T; s: Selection; t: TimeStamp; tc: INTEGER := -1): Value
  RAISES {Error} =
  BEGIN
    IF s = KBFocus THEN RAISE Error(ErrorCode.Unreadable) END;
    IF tc = -1 THEN tc := TYPECODE(TEXT) END;
    WITH p = Parent(v) DO
      IF p = NIL THEN RAISE Error(ErrorCode.Uninstalled) END;
      RETURN p.readUp(v, v, s, t, tc)
    END;
  END Read;

PROCEDURE Write (v  : T;
                 s  : Selection;
                 t  : TimeStamp;
                 val: Value;
                 tc : INTEGER     := -1) RAISES {Error} =
  BEGIN
    IF s = KBFocus THEN RAISE Error(ErrorCode.Unwritable) END;
    IF tc = -1 THEN tc := TYPECODE(TEXT) END;
    WITH p = Parent(v) DO
      IF p = NIL THEN RAISE Error(ErrorCode.Uninstalled) END;
      p.writeUp(v, v, s, t, val, tc)
    END;
  END Write;

PROCEDURE Acquire (v: T; s: Selection; t: TimeStamp) RAISES {Error} =
  BEGIN
    LOCK v DO VBTClass.Acquire(v, s, t) END
  END Acquire;

PROCEDURE Release (v: T; s: Selection) RAISES {} =
  BEGIN
    LOCK v DO VBTClass.Release(v, s) END
  END Release;

PROCEDURE Put (         v     : T;
                        s     : Selection;
                        t     : TimeStamp;
                        type  : MiscCodeType;
               READONLY detail: MiscCodeDetail) RAISES {Error} =
  BEGIN
    LOCK v DO VBTClass.Put(v, s, t, type, detail) END
  END Put;

PROCEDURE Forge (v: T; type: MiscCodeType; READONLY detail: MiscCodeDetail)
  RAISES {Error} =
  BEGIN
    LOCK v DO VBTClass.Forge(v, type, detail) END
  END Forge;

PROCEDURE ForceRepaint (v: T; READONLY rgn: Region.T) RAISES {} =
  BEGIN
    LOCK v DO VBTClass.ForceRepaint(v, rgn) END
  END ForceRepaint;

CONST
  BigScrollArea = 100000;
  (* To prevent clients from queuing up lots of scrolling commands, we
     force the batch after any scrolling command larger than this. *)

  CoveredProps = VBTRep.AllProps
                   - VBTRep.Props{VBTRep.Prop.Covered, VBTRep.Prop.OnQ,
                                  VBTRep.Prop.ExcessBegins};

PROCEDURE Scroll (         v      : Leaf;
                  READONLY clp    : Rect.T;
                  READONLY dlta   : Point.T;
                           paintOp            := PaintOp.Copy) RAISES {} =
  VAR
    clip: Rect.T;
    p   : PaintPrivate.ScrollPtr;
  CONST
    bsize = ADRSIZE(PaintPrivate.ScrollRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    IF Rect.HorSize(clp) * Rect.VerSize(clp) > BigScrollArea THEN
      Sync(v)
    END;
    LOOP
      LOCK v DO
        IF NOT (VBTRep.Prop.Reshaping IN v.props) THEN
          clip := Rect.Meet(clp, Rect.Move(v.domain, dlta))
        ELSE
          clip := clp
        END;
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR po: ScrnPaintOp.T := NIL;
        BEGIN
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF po # NIL AND po # PlttFrnds.noOp THEN
            DEC(v.remaining, bsize);
            WITH b  = v.batch,
                 ss = b.scrollSource DO
              p := b.next;
              INC(b.next, bsize);
              p.command := PaintPrivate.PaintCommand.ScrollCom;
              p.clip := clip;
              p.op := po.id;
              p.delta := dlta;
              ss := Rect.Join(ss, Rect.Sub(clip, dlta))
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveOp(st, paintOp) END
      END
    END
  END Scroll;

PROCEDURE PaintTint (v: Leaf; READONLY clp: Rect.T; paintOp: PaintOp.T)
  RAISES {} =
  VAR p: PaintPrivate.TintPtr;
  CONST
    bsize = ADRSIZE(PaintPrivate.TintRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    IF Rect.IsEmpty(clp) THEN RETURN END;
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR po: ScrnPaintOp.T := NIL;
        BEGIN
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF po # NIL AND po # PlttFrnds.noOp THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.command := PaintPrivate.PaintCommand.TintCom;
              p.clip := clp;
              p.op := po.id
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveOp(st, paintOp) END
      END
    END
  END PaintTint;

PROCEDURE PolyTint (         v      : Leaf;
                    READONLY clp    : ARRAY OF Rect.T;
                             paintOp: PaintOp.T        ) RAISES {} =
  VAR
    pAdr, endP: ADDRESS;
    i         : CARDINAL;
  CONST
    bsize1 = ADRSIZE(PaintPrivate.TintRec);
    size1  = bsize1 DIV ADRSIZE(Word.T);
    bsize2 = ADRSIZE(PaintPrivate.CommandRec);
  BEGIN
    LOOP
      LOCK v DO
        IF v.st = NIL THEN RETURN END;
        VAR po: ScrnPaintOp.T := NIL;
        BEGIN
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF po # NIL AND po # PlttFrnds.noOp THEN
            i := 0;
            WHILE i # NUMBER(clp) DO
              IF Rect.IsEmpty(clp[i]) THEN
                INC(i)
              ELSE
                IF v.remaining < bsize1 THEN
                  IF v.st = NIL THEN RETURN END;
                  VBTRep.NewBatch(v, size1)
                END;
                DEC(v.remaining, bsize1);
                pAdr := v.batch.next;
                WITH p = LOOPHOLE(pAdr, PaintPrivate.TintPtr) DO
                  p.command := PaintPrivate.PaintCommand.TintCom;
                  p.clip := clp[i];
                  p.op := po.id
                END;
                INC(i);
                INC(pAdr, bsize1);
                WHILE i # NUMBER(clp) AND v.remaining >= bsize2 DO
                  WITH nbsize = MIN(
                                  NUMBER(clp) - i, v.remaining DIV bsize2)
                                  * bsize2 DO
                    DEC(v.remaining, nbsize);
                    endP := pAdr + nbsize
                  END;
                  WHILE pAdr # endP DO
                    IF Rect.IsEmpty(clp[i]) THEN
                      DEC(endP, bsize2);
                      INC(v.remaining, bsize2)
                    ELSE
                      WITH comP = LOOPHOLE(pAdr, PaintPrivate.RepeatPtr) DO
                        comP.command :=
                          PaintPrivate.PaintCommand.RepeatCom;
                        comP.clip := clp[i]
                      END;
                      INC(pAdr, bsize2)
                    END;
                    INC(i)
                  END
                END;
	        v.batch.next := pAdr
              END
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveOp(st, paintOp) END
      END
    END
  END PolyTint;

PROCEDURE PaintTexture (         v      : Leaf;
                        READONLY clp    : Rect.T;
                                 paintOp: PaintOp.T;
                                 src    : Pixmap.T;
                        READONLY dlta   : Point.T    ) RAISES {} =
  VAR p: PaintPrivate.TexturePtr;
  CONST
    bsize = ADRSIZE(PaintPrivate.PixmapRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    IF Rect.IsEmpty(clp) THEN RETURN END;
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF pm # NIL AND pm # PlttFrnds.noPixmap AND po # NIL
               AND po # PlttFrnds.noOp THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.command := PaintPrivate.PaintCommand.TextureCom;
              p.clip := clp;
              p.delta := dlta;
              p.pm := pm.id;
              p.op := po.id
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolveOp(st, paintOp);
          EVAL Palette.ResolvePixmap(st, src)
        END
      END
    END
  END PaintTexture;

PROCEDURE PolyTexture (         v      : Leaf;
                       READONLY clp    : ARRAY OF Rect.T;
                                paintOp: PaintOp.T;
                                src    : Pixmap.T;
                       READONLY dlta   : Point.T          ) RAISES {} =
  VAR
    pAdr, endP: ADDRESS;
    i         : CARDINAL;
  CONST
    bsize1 = ADRSIZE(PaintPrivate.PixmapRec);
    size1  = bsize1 DIV ADRSIZE(Word.T);
    bsize2 = ADRSIZE(PaintPrivate.CommandRec);
  BEGIN
    LOOP
      LOCK v DO
        IF v.st = NIL THEN RETURN END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF pm # NIL AND pm # PlttFrnds.noPixmap AND po # NIL
               AND po # PlttFrnds.noOp THEN
            i := 0;
            WHILE i # NUMBER(clp) DO
              IF Rect.IsEmpty(clp[i]) THEN
                INC(i)
              ELSE
                IF v.remaining < bsize1 THEN
                  IF v.st = NIL THEN RETURN END;
                  VBTRep.NewBatch(v, size1)
                END;
                DEC(v.remaining, bsize1);
                pAdr := v.batch.next;
                WITH p = LOOPHOLE(pAdr, PaintPrivate.TexturePtr) DO
                  p.command := PaintPrivate.PaintCommand.TextureCom;
                  p.clip := clp[i];
                  p.delta := dlta;
                  p.pm := pm.id;
                  p.op := po.id
                END;
                INC(i);
                INC(pAdr, bsize1);
                WHILE i # NUMBER(clp) AND v.remaining >= bsize2 DO
                  WITH nbsize = MIN(
                                  NUMBER(clp) - i, v.remaining DIV bsize2)
                                  * bsize2 DO
                    DEC(v.remaining, nbsize);
                    endP := pAdr + nbsize
                  END;
                  WHILE pAdr # endP DO
                    IF Rect.IsEmpty(clp[i]) THEN
                      DEC(endP, bsize2);
                      INC(v.remaining, bsize2)
                    ELSE
                      WITH comP = LOOPHOLE(pAdr, PaintPrivate.RepeatPtr) DO
                        comP.command :=
                          PaintPrivate.PaintCommand.RepeatCom;
                        comP.clip := clp[i]
                      END;
                      INC(pAdr, bsize2)
                    END;
                    INC(i)
                  END
                END;
                v.batch.next := pAdr
              END
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolveOp(st, paintOp);
          EVAL Palette.ResolvePixmap(st, src)
        END
      END
    END
  END PolyTexture;

PROCEDURE PaintRegion (         v    : Leaf;
                       READONLY rgn  : Region.T;
                                op   : PaintOp.T;
                                src  : Pixmap.T;
                       READONLY delta: Point.T    ) RAISES {} =
  BEGIN
    WITH list = Region.ToRects(rgn) DO
      PolyTexture(v, list^, op, src, delta)
    END
  END PaintRegion;

PROCEDURE PaintPixmap (         v      : Leaf;
                       READONLY clp    : Rect.T;
                                paintOp: PaintOp.T;
                                src    : Pixmap.T;
                       READONLY dlta   : Point.T    ) RAISES {} =
  VAR
    p  : PaintPrivate.PixmapPtr;
    clpp: Rect.T;
  CONST
    bsize = ADRSIZE(PaintPrivate.PixmapRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF pm # NIL AND pm # PlttFrnds.noPixmap AND po # NIL
               AND po # PlttFrnds.noOp THEN
            clpp := Rect.Meet(clp, Rect.Move(pm.bounds, dlta));
            IF NOT Rect.IsEmpty(clpp) THEN
              DEC(v.remaining, bsize);
              WITH b = v.batch DO
                p := b.next;
                INC(b.next, bsize);
                p.command := PaintPrivate.PaintCommand.PixmapCom;
                p.clip := clpp;
                p.pm := pm.id;
                p.delta := dlta;
                p.op := po.id
              END;
              IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END
            END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolveOp(st, paintOp);
          EVAL Palette.ResolvePixmap(st, src)
        END
      END
    END
  END PaintPixmap;

PROCEDURE PixmapDomain (v: T; pix: Pixmap.T): Rect.T =
  BEGIN
    LOOP
      LOCK v DO
        WITH st = v.st DO
          IF st = NIL THEN RETURN Rect.Empty END;
          VAR pm: ScrnPixmap.T := NIL;
          BEGIN
            IF pix.pm < NUMBER(st.pixmaps^) THEN
              pm := st.pixmaps[pix.pm]
            END;
            IF pm # NIL AND pm # PlttFrnds.noPixmap THEN
              RETURN pm.bounds
            END
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolvePixmap(st, pix) END
      END
    END
  END PixmapDomain;

PROCEDURE PaintScrnPixmap (         v   : Leaf;
                           READONLY clp : Rect.T;
                                    op  : PaintOp.T      := PaintOp.Copy;
                                    src : ScrnPixmap.T;
                           READONLY dlta: Point.T                         ) =
  VAR
    p  : PaintPrivate.PixmapPtr;
    clpp: Rect.T;
  CONST
    bsize = ADRSIZE(PaintPrivate.PixmapRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR po: ScrnPaintOp.T := NIL;
        BEGIN
          IF op.op < NUMBER(v.st.ops^) THEN po := v.st.ops[op.op] END;
          IF po # NIL AND po # PlttFrnds.noOp THEN
            clpp := Rect.Meet(clp, Rect.Move(src.bounds, dlta));
            IF NOT Rect.IsEmpty(clp) THEN
              DEC(v.remaining, bsize);
              WITH b = v.batch DO
                p := b.next;
                INC(b.next, bsize);
                p.command := PaintPrivate.PaintCommand.PixmapCom;
                p.clip := clpp;
                p.delta := dlta;
                p.pm := src.id;
                p.op := po.id
              END;
              IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END
            END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveOp(st, op) END
      END
    END
  END PaintScrnPixmap;

PROCEDURE PaintText (         v      : Leaf;
                     READONLY clp    : Rect.T;
                     READONLY rfpt   : Point.T;
                              fntP   : Font.T;
                              t      : Text.T;
                              paintOp: PaintOp.T;
                     READONLY dl := ARRAY OF Displacement{}) RAISES {} =
  VAR
    len := Text.Length(t);
    buf : ARRAY [0..127] OF CHAR;
    rbuf: REF ARRAY OF CHAR;
  BEGIN
    IF (len <= NUMBER(buf)) THEN
      Text.SetChars (buf, t);
      PaintSub(v, clp, rfpt, fntP, SUBARRAY(buf, 0, len), paintOp, dl)
    ELSE
      rbuf := NEW (REF ARRAY OF CHAR, len);
      Text.SetChars (rbuf^, t);
      PaintSub(v, clp, rfpt, fntP, rbuf^, paintOp, dl)
    END;
  END PaintText;

PROCEDURE PaintSub (         v      : Leaf;
                    READONLY clp    : Rect.T;
                    READONLY rfpt   : Point.T;
                             fntP   : Font.T;
                    READONLY t      : ARRAY OF CHAR;
                             paintOp: PaintOp.T       := PaintOp.BgFg;
                    READONLY dl := ARRAY OF Displacement{}) RAISES {} =
  VAR
    p          : PaintPrivate.TextPtr;
    size, bsize: INTEGER;
    dstAdr     : ADDRESS;
    ndl                               := NUMBER(dl);
    dlsize                            := ADRSIZE(Displacement) * ndl;
    txtsize                           := ADRSIZE(CHAR) * NUMBER(t);
    valid                             := TRUE;
  BEGIN
    bsize := ADRSIZE(PaintPrivate.TextRec) + dlsize + txtsize;
    size := (bsize + ADRSIZE(Word.T) - 1) DIV ADRSIZE(Word.T);
    bsize := ADRSIZE(Word.T) * size;
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          sf: ScrnFont.T    := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF fntP.fnt < NUMBER(v.st.fonts^) THEN
            sf := v.st.fonts[fntP.fnt]
          END;
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF sf # NIL AND sf # PlttFrnds.noFont AND po # NIL
               AND po # PlttFrnds.noOp THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch,
                 bb = Rect.Move(
                        ScrnFont.BoundingBoxSubValid(t, sf, valid), rfpt) DO
              p := b.next;
              INC(b.next, bsize);
              p.command := PaintPrivate.PaintCommand.TextCom;
              IF NOT Rect.Subset(bb, clp) THEN
                p.props := PaintPrivate.Props{PaintPrivate.Prop.Clipped}
              ELSE
                p.props := PaintPrivate.Props{}
              END;
              p.clip := Rect.Meet(bb, clp);
              p.refpt := rfpt;
              p.byteOrder := PaintPrivate.HostByteOrder;
              p.fnt := sf.id;
              p.txtsz := NUMBER(t);
              p.dlsz := NUMBER(dl);
              p.op := po.id;
              p.szOfRec := size
            END;
            dstAdr := p + ADRSIZE(p^);
            (* Copy in the displacement list: *)
            IF dlsize > 0 THEN
              CopyBytes(ADR(dl[0]), dstAdr, dlsize);
              dstAdr := dstAdr + dlsize;
            END;
            IF txtsize > 0 THEN CopyBytes(ADR(t[0]), dstAdr, txtsize) END;
            IF NOT valid THEN
              WITH m    = sf.metrics,
                   fc   = m.firstChar,
                   lc   = m.lastChar,
                   dc   = m.defaultChar,
                   dcOk = fc <= dc AND dc <= lc DO
                VAR
                  chA: UNTRACED REF ARRAY [0 .. 999999] OF CHAR := dstAdr;
                  dlA: UNTRACED REF ARRAY [0 .. 999999] OF Displacement := dstAdr
                                                                             - dlsize;
                  j, k, l, n          := 0;
                  ch        : INTEGER;
                BEGIN
                  IF dcOk THEN
                    FOR i := 0 TO txtsize - 1 DO
                      ch := ORD(chA[i]);
                      IF ch < fc OR lc < ch THEN
                        chA[i] := VAL(dc, CHAR)
                      END
                    END
                  ELSE
                    WHILE j < txtsize DO
                      k := j;
                      LOOP
                        ch := ORD(chA[k]);
                        IF ch < fc OR lc < ch THEN EXIT END;
                        INC(k);
                        IF k = txtsize THEN EXIT END
                      END;
                      IF l # 0 AND j # k THEN
                        CopyBytes(ADR(chA[j]), ADR(chA[j - l]), k - j)
                      END;
                      WHILE n < ndl AND dlA[n].index <= k DO
                        IF l # 0 THEN DEC(dlA[n].index, l) END;
                        INC(n)
                      END;
                      INC(l);
                      j := k + 1
                    END;
                    IF l # 0 THEN
                      WHILE n < ndl DO
                        IF l # 0 THEN DEC(dlA[n].index, l) END;
                        INC(n)
                      END;
                      DEC(p.txtsz, l)
                    END
                  END
                END
              END
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolveFont(st, fntP);
          EVAL Palette.ResolveOp(st, paintOp)
        END
      END
    END
  END PaintSub;

PROCEDURE BoundingBox (v: Leaf; txt: TEXT; fnt: Font.T): Rect.T =
  BEGIN
    LOOP
      LOCK v DO
        IF v.st = NIL THEN RETURN ScrnFont.BoundingBox(txt, NIL) END;
        VAR sf: ScrnFont.T := NIL;
        BEGIN
          IF fnt.fnt < NUMBER(v.st.fonts^) THEN
            sf := v.st.fonts[fnt.fnt]
          END;
          IF sf # NIL AND sf # PlttFrnds.noFont THEN
            RETURN ScrnFont.BoundingBox(txt, sf)
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveFont(st, fnt) END
      END
    END
  END BoundingBox;

PROCEDURE TextWidth (v: Leaf; txt: TEXT; fnt: Font.T): INTEGER =
  BEGIN
    LOOP
      LOCK v DO
        IF v.st = NIL THEN RETURN 0 END;
        VAR sf: ScrnFont.T := NIL;
        BEGIN
          IF fnt.fnt < NUMBER(v.st.fonts^) THEN
            sf := v.st.fonts[fnt.fnt]
          END;
          IF sf # NIL AND sf # PlttFrnds.noFont THEN
            RETURN ScrnFont.TextWidth(txt, sf)
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN EVAL Palette.ResolveFont(st, fnt) END
      END
    END
  END TextWidth;
PROCEDURE PaintPatch( v: Leaf; READONLY clip: Rect.T; hl, hr, vlo, vhi, start: INTEGER; READONLY deltaArray: ARRAY OF DeltaPair; op: PaintOp.T := PaintOp.BgFg; src: Pixmap.T := Pixmap.Solid; READONLY delta: Point.T := Point.Origin) = BEGIN Crash() END PaintPatch;

PROCEDURE Fill (         v    : Leaf;
                READONLY clip : Rect.T;
                         path : Path.T;
                         wind : WindingCondition;
                         op   : PaintOp.T          := PaintOp.BgFg;
                         src  : Pixmap.T           := Pixmap.Solid;
                READONLY delta: Point.T            := Point.Origin  )
  RAISES {} =
  VAR
    p          : PaintExt.FillPtr;
    size, bsize: INTEGER;
    dstAdr     : ADDRESS;
    l                             := PathPrivate.Freeze(path);
    pathsize                      := path.next - path.start;
  BEGIN
    IF pathsize = 0 THEN PathPrivate.Thaw(l); RETURN END;
    bsize := ADRSIZE(PaintExt.FillRec) + pathsize;
    size := bsize DIV ADRSIZE(Word.T);
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF op.op < NUMBER(v.st.ops^) THEN po := v.st.ops[op.op] END;
          IF po # NIL AND po # PlttFrnds.noOp AND pm # NIL
               AND pm # PlttFrnds.noPixmap THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.ext.command := PaintPrivate.PaintCommand.ExtensionCom;
              p.ext.clip := clip;
              p.ext.op := po.id;
              p.ext.szOfRec := size;
              p.ext.delta := Point.Origin;
              p.ext.pm := pm.id;
              p.ext.fnt := 0;
              p.ext.subCommand := PaintExt.FillCommand;
              p.delta := delta;
              p.wind := wind;
              p.path.curveCount := path.curveCount
            END;
            dstAdr := p + ADRSIZE(p^);
            CopyBytes(path.start, dstAdr, pathsize);
            PathPrivate.Thaw(l);
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolvePixmap(st, src);
          EVAL Palette.ResolveOp(st, op)
        END
      END
    END
  END Fill;

PROCEDURE Stroke (         v    : Leaf;
                  READONLY clip : Rect.T;
                           path : Path.T;
                           width: CARDINAL  := 1;
                           end              := EndStyle.Round;
                           join             := JoinStyle.Round;
                           op   : PaintOp.T := PaintOp.BgFg;
                           src  : Pixmap.T  := Pixmap.Solid;
                  READONLY delta: Point.T   := Point.Origin     )
  RAISES {} =
  VAR
    p          : PaintExt.StrokePtr;
    size, bsize: INTEGER;
    dstAdr     : ADDRESS;
    l                               := PathPrivate.Freeze(path);
    pathsize                        := path.next - path.start;
  BEGIN
    IF pathsize = 0 THEN PathPrivate.Thaw(l); RETURN END;
    LOOP
      bsize := ADRSIZE(PaintExt.StrokeRec) + pathsize;
      size := bsize DIV ADRSIZE(Word.T);
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF op.op < NUMBER(v.st.ops^) THEN po := v.st.ops[op.op] END;
          IF po # NIL AND po # PlttFrnds.noOp AND pm # NIL
               AND pm # PlttFrnds.noPixmap THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.ext.command := PaintPrivate.PaintCommand.ExtensionCom;
              p.ext.clip := clip;
              p.ext.op := po.id;
              p.ext.szOfRec := size;
              p.ext.delta := Point.Origin;
              p.ext.pm := pm.id;
              p.ext.fnt := 0;
              p.ext.subCommand := PaintExt.StrokeCommand;
              p.delta := delta;
              p.width := width;
              p.end := end;
              p.join := join;
              p.path.curveCount := path.curveCount
            END;
            dstAdr := p + ADRSIZE(p^);
            CopyBytes(path.start, dstAdr, pathsize);
            PathPrivate.Thaw(l);
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolvePixmap(st, src);
          EVAL Palette.ResolveOp(st, op)
        END
      END
    END
  END Stroke;

PROCEDURE Line (         v     : Leaf;
                READONLY clip  : Rect.T;
                         p0, p1: Point.T;
                         width : CARDINAL  := 1;
                         end               := EndStyle.Round;
                         op    : PaintOp.T := PaintOp.BgFg;
                         src   : Pixmap.T  := Pixmap.Solid;
                READONLY delta : Point.T   := Point.Origin    ) RAISES {} =
  CONST
    bsize = ADRSIZE(PaintExt.LineRec);
    size  = bsize DIV ADRSIZE(Word.T);
  VAR p: PaintExt.LinePtr;
  BEGIN
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF op.op < NUMBER(v.st.ops^) THEN po := v.st.ops[op.op] END;
          IF po # NIL AND po # PlttFrnds.noOp AND pm # NIL
               AND pm # PlttFrnds.noPixmap THEN
            DEC(v.remaining, bsize);
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.ext.command := PaintPrivate.PaintCommand.ExtensionCom;
              p.ext.clip := clip;
              p.ext.op := po.id;
              p.ext.szOfRec := size;
              p.ext.delta := Point.Origin;
              p.ext.pm := pm.id;
              p.ext.fnt := 0;
              p.ext.subCommand := PaintExt.LineCommand;
              p.delta := delta;
              p.width := width;
              p.end := end;
              p.p := p0;
              p.q := p1
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolvePixmap(st, src);
          EVAL Palette.ResolveOp(st, op)
        END
      END
    END
  END Line;

PROCEDURE PaintTrapezoid (         v      : Leaf;
                          READONLY clp    : Rect.T;
                          READONLY trp    : Trapezoid.T;
                                   paintOp: PaintOp.T     := PaintOp.BgFg;
                                   src    : Pixmap.T      := Pixmap.Solid;
                          READONLY dlta   : Point.T       := Point.Origin  )
  RAISES {} =
  VAR
    p     : PaintPrivate.TrapPtr;
    pmP   : PaintPrivate.Pixmap;
    lo, hi: INTEGER;
  CONST
    bsize = ADRSIZE(PaintPrivate.TrapRec);
    size  = bsize DIV ADRSIZE(Word.T);
  BEGIN
    lo := MAX(trp.vlo, clp.north);
    hi := MIN(trp.vhi, clp.south);
    IF lo >= hi THEN
      RETURN
    ELSIF (trp.m1.n = 0) OR (trp.m2.n = 0) THEN
      Crash()
    END;
    LOOP
      LOCK v DO
        IF v.remaining < bsize THEN
          IF v.st = NIL THEN RETURN END;
          VBTRep.NewBatch(v, size)
        END;
        VAR
          pm: ScrnPixmap.T  := NIL;
          po: ScrnPaintOp.T := NIL;
        BEGIN
          IF src.pm < NUMBER(v.st.pixmaps^) THEN
            pm := v.st.pixmaps[src.pm]
          END;
          IF paintOp.op < NUMBER(v.st.ops^) THEN
            po := v.st.ops[paintOp.op]
          END;
          IF po # NIL AND po # PlttFrnds.noOp AND pm # NIL
               AND pm # PlttFrnds.noPixmap THEN
            DEC(v.remaining, bsize);
            pmP := pm.id;
            WITH b = v.batch DO
              p := b.next;
              INC(b.next, bsize);
              p.command := PaintPrivate.PaintCommand.TrapCom;
              p.clip.west := clp.west;
              p.clip.east := clp.east;
              p.clip.north := lo;
              p.clip.south := hi;
              p.delta := dlta;
              p.op := po.id;
              p.p1 := trp.p1;
              p.p2 := trp.p2;
              p.m1 := trp.m1;
              p.m2 := trp.m2;
              p.pm := pmP;
            END;
            IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END;
            EXIT
          END
        END
      END;
      VAR st: ScreenType;
      BEGIN
        LOCK v DO st := v.st END;
        IF st # NIL THEN
          EVAL Palette.ResolvePixmap(st, src);
          EVAL Palette.ResolveOp(st, paintOp)
        END
      END
    END
  END PaintTrapezoid;

PROCEDURE BeginGroup (v: Leaf; sizeHint: INTEGER := 0) =
  BEGIN
    LOCK v DO
      IF v.remaining < sizeHint OR v.batch = NIL THEN
        IF v.st = NIL THEN RETURN END;
        VBTRep.NewBatch(v, sizeHint DIV BYTESIZE(Word.T))
      END;
      INC(v.batch.excessBegins);
      v.props := v.props + VBTRep.Props{VBTRep.Prop.ExcessBegins}
    END
  END BeginGroup;

PROCEDURE EndGroup (v: Leaf) =
  BEGIN
    LOCK v DO
      IF v.batch = NIL THEN RETURN END;
      WITH ba = v.batch DO
        DEC(ba.excessBegins);
        IF ba.excessBegins < 0 THEN
          VBTRep.ForceBatch(v)
        ELSIF ba.excessBegins = 0 THEN
          v.props := v.props - VBTRep.Props{VBTRep.Prop.ExcessBegins};
          IF v.props <= CoveredProps THEN VBTRep.Enqueue(v) END
        END
      END
    END
  END EndGroup;

PROCEDURE Sync (v: Leaf; wait := TRUE) =
  BEGIN
    LOCK v DO
      IF v.batch # NIL THEN VBTRep.ForceBatch(v) END;
      WITH p = v.parent DO IF p # NIL THEN p.sync(v, wait) END END
    END
  END Sync;

PROCEDURE Capture (v: T; READONLY clip: Rect.T; VAR (*out*) br: Region.T):
  ScrnPixmap.T RAISES {} =
  VAR bad: Region.T;
  BEGIN
    LOCK v DO
      bad := VBTClass.GetBadRegion(v);
      IF v.parent = NIL THEN
        br := Region.FromRect(clip);
        RETURN NIL
      ELSIF Rect.Subset(clip, v.domain) AND Region.IsEmpty(bad) THEN
        RETURN v.parent.capture(v, clip, br)
      ELSE
        WITH res = v.parent.capture(v, Rect.Meet(clip, v.domain), br) DO
          br := Region.Join(Region.Join(br, bad),
                            Region.Difference(Region.FromRect(clip),
                                              Region.FromRect(v.domain)));
          RETURN res
        END
      END
    END
  END Capture;

TYPE
  Mutex = MUTEX OBJECT
    holder: Thread.T := NIL;
  OVERRIDES
    acquire := PedanticAcquire;
    release := PedanticRelease;
  END;

PROCEDURE PedanticAcquire(m: Mutex) =
  BEGIN
    MUTEX.acquire(m);
    m.holder := Thread.Self();
  END PedanticAcquire;

PROCEDURE PedanticRelease(m: Mutex) =
  BEGIN
    m.holder := NIL;
    MUTEX.release(m);
  END PedanticRelease;

VAR pedantic := RTParams.IsPresent("CheckShape");

PROCEDURE NewShape (v: T) RAISES {} =
  BEGIN
    IF pedantic AND v.st # NIL
         AND NARROW(mu, Mutex).holder # Thread.Self() THEN
      Crash()
    END;
    LOCK v DO
      v.props := v.props + VBTRep.Props{VBTRep.Prop.HasNewShape};
      IF (v.parent # NIL) AND NOT (VBTRep.Prop.BlockNewShape IN v.props) THEN
        v.props := v.props + VBTRep.Props{VBTRep.Prop.BlockNewShape};
        v.parent.newShape(v)
      END
    END
  END NewShape;

PROCEDURE PutProp (v: T; ref: REFANY) RAISES {} =
  BEGIN
    LOCK v DO PropertyV.Put(v.propset, ref) END
  END PutProp;

PROCEDURE GetProp (v: T; tc: INTEGER): REFANY RAISES {} =
  BEGIN
    LOCK v DO RETURN PropertyV.Get(v.propset, tc) END
  END GetProp;

PROCEDURE RemProp (v: T; tc: INTEGER) RAISES {} =
  BEGIN
    LOCK v DO PropertyV.Remove(v.propset, tc) END
  END RemProp;

PROCEDURE Mark (v: T) RAISES {} =
  BEGIN
    LOCK v DO VBTRep.Mark(v) END
  END Mark;

PROCEDURE IsMarked (v: T): BOOLEAN RAISES {} =
  BEGIN
    LOCK v DO RETURN VBTRep.Prop.Marked IN v.props END
  END IsMarked;

PROCEDURE Unmark (v: T) RAISES {} =
  BEGIN
    LOCK v DO v.props := v.props - VBTRep.Props{VBTRep.Prop.Marked} END
  END Unmark;

PROCEDURE Discard (v: T) RAISES {} =
  BEGIN
    v.discard()
  END Discard;

REVEAL
  Leaf = T BRANDED OBJECT
         OVERRIDES
           reshape   := ReshapeDefault;
           repaint   := RepaintDefault;
           rescreen  := RescreenDefault;
           mouse     := MouseDefault;
           key       := KeyCodeDefault;
           position  := PositionDefault;
           misc      := MiscCodeDefault;
           shape     := ShapeDefault;
           read      := ReadDefault;
           write     := WriteDefault;
           redisplay := RedisplayDefault;
           discard   := DiscardDefault;
         END;

PROCEDURE MouseDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: MouseRec)
  RAISES {} =
  BEGIN
  END MouseDefault;

PROCEDURE PositionDefault (<*UNUSED*>          v : T;
                           <*UNUSED*> READONLY cd: PositionRec) RAISES {} =
  BEGIN
  END PositionDefault;

PROCEDURE ReadDefault (<*UNUSED*> v : T;
                       <*UNUSED*> s : Selection;
                       <*UNUSED*> tc: CARDINAL   ): Value RAISES {Error} =
  BEGIN
    RAISE Error(ErrorCode.Unreadable)
  END ReadDefault;

PROCEDURE WriteDefault (<*UNUSED*> v  : T;
                        <*UNUSED*> s  : Selection;
                        <*UNUSED*> val: Value;
                        <*UNUSED*> tc : CARDINAL   ) RAISES {Error} =
  BEGIN
    RAISE Error(ErrorCode.Unwritable)
  END WriteDefault;

PROCEDURE KeyCodeDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: KeyRec)
  RAISES {} =
  BEGIN
  END KeyCodeDefault;

PROCEDURE MiscCodeDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: MiscRec)
  RAISES {} =
  BEGIN
  END MiscCodeDefault;

PROCEDURE ReshapeDefault (v: T; <*UNUSED*> READONLY cd: ReshapeRec)
  RAISES {} =
  BEGIN
    VBTClass.Repaint(v, Region.FromRect(v.domain))
  END ReshapeDefault;

PROCEDURE RepaintDefault (<*UNUSED*>          v  : T;
                          <*UNUSED*> READONLY rgn: Region.T) RAISES {} =
  BEGIN
  END RepaintDefault;

PROCEDURE RescreenDefault (v: T; READONLY cdP: RescreenRec) RAISES {} =
  VAR cd: ReshapeRec;
  BEGIN                          (* LL = v's share of VBT.mu *)
    NewShape(v);
    cd.new := Rect.Empty;
    cd.saved := Rect.Empty;
    cd.prev := cdP.prev;
    cd.marked := cdP.marked;
    v.reshape(cd)
  END RescreenDefault;

PROCEDURE RedisplayDefault (v: T) RAISES {} =
  VAR cd: ReshapeRec;
  BEGIN
    cd.new := v.domain;
    cd.prev := v.domain;
    cd.saved := Rect.Empty;
    cd.marked := TRUE;
    v.reshape(cd)
  END RedisplayDefault;

PROCEDURE DiscardDefault (<*UNUSED*> v: T) RAISES {} =
  BEGIN
  END DiscardDefault;

PROCEDURE ShapeDefault (<*UNUSED*> v : T;
                        <*UNUSED*> ax: Axis.T;
                        <*UNUSED*> n : CARDINAL): SizeRange RAISES {} =
  BEGIN
    RETURN DefaultShape
  END ShapeDefault;

PROCEDURE GetSelection (name: TEXT): Selection =
  BEGIN
    RETURN Selection{GetAtom(name, sel)}
  END GetSelection;

PROCEDURE GetMiscCodeType (name: TEXT): MiscCodeType =
  BEGIN
    RETURN MiscCodeType{GetAtom(name, mct)}
  END GetMiscCodeType;

PROCEDURE SelectionName (s: Selection): TEXT =
  BEGIN
    RETURN AtomName(s.sel, sel)
  END SelectionName;

PROCEDURE MiscCodeTypeName (type: MiscCodeType): TEXT =
  BEGIN
    RETURN AtomName(type.typ, mct)
  END MiscCodeTypeName;

TYPE
  TextSeq = REF ARRAY OF TEXT;
  AtomTable = RECORD
                cnt: CARDINAL;
                tbl: TextIntTbl.T;
                nm : TextSeq
              END;

PROCEDURE GetAtom (nm: TEXT; VAR tbl: AtomTable): CARDINAL =
  VAR res: INTEGER;
  BEGIN
    LOCK atomMu DO
      IF tbl.tbl.get(nm, res) THEN RETURN res END;
      res := tbl.cnt;
      INC(tbl.cnt);
      IF tbl.cnt > NUMBER(tbl.nm^) THEN Extend(tbl.nm) END;
      tbl.nm[res] := nm;
      EVAL tbl.tbl.put(nm, res);
      RETURN res
    END
  END GetAtom;

PROCEDURE AtomName (atm: CARDINAL; READONLY tbl: AtomTable): TEXT =
  BEGIN
    LOCK atomMu DO
      IF atm >= tbl.cnt THEN RETURN NIL ELSE RETURN tbl.nm[atm] END
    END
  END AtomName;

PROCEDURE Extend (VAR seq: TextSeq) =
  VAR
    new: TextSeq;
    n            := NUMBER(seq^);
  BEGIN
    new := NEW(TextSeq, MAX(6, 2 * n));
    SUBARRAY(new^, 0, n) := seq^;
    seq := new
  END Extend;

EXCEPTION FatalError;

PROCEDURE Crash() =
  <*FATAL FatalError*>
  BEGIN
    RAISE FatalError
  END Crash;

VAR
  atomMu := NEW(MUTEX);
  sel, mct := AtomTable{0, NEW(TextIntTbl.Default).init(), NEW(TextSeq, 0)};

BEGIN
  IF pedantic
    THEN mu := NEW(Mutex);
    ELSE mu := NEW(MUTEX);
  END;
  NilSel := GetSelection("NilSel");
  Forgery := GetSelection("Forgery");
  KBFocus := GetSelection("KBFocus");
  Target := GetSelection("Target");
  Source := GetSelection("Source");
  Deleted := GetMiscCodeType("Deleted");
  Disconnected := GetMiscCodeType("Disconnected");
  TakeSelection := GetMiscCodeType("TakeSelection");
  Lost := GetMiscCodeType("Lost");
  TrestleInternal := GetMiscCodeType("TrestleInternal");
  Moved := GetMiscCodeType("Moved");
END VBT.