Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*> UNSAFE MODULEPROCEDURE 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;; 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, TextF, PropertyV, PathPrivate, TextIntTbl, Wr, Rd, Palette, PlttFrnds, RTParams; PROCEDURE VBT CopyBytes (src, dst: ADDRESS; n: INTEGER) = BEGIN EVAL Cstring.memcpy(dst, src, n) END CopyBytes; PROCEDUREParent (v: T): Split RAISES {} = BEGIN LOCK v DO RETURN v.parent END END Parent; PROCEDUREDomain (v: T): Rect.T RAISES {} = BEGIN LOCK v DO RETURN v.domain END END Domain; PROCEDUREScreenTypeOf (v: T): ScreenType RAISES {} = BEGIN LOCK v DO RETURN v.st END END ScreenTypeOf; PROCEDUREMMToPixels (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; PROCEDURESetCage (v: T; READONLY cg: Cage) RAISES {} = BEGIN LOCK v DO VBTClass.SetCage(v, cg) END END SetCage; PROCEDUREOutside (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; PROCEDURECageFromRect (READONLY r: Rect.T; READONLY cp: CursorPosition): Cage = BEGIN RETURN Cage{r, InOut{cp.gone}, cp.screen} END CageFromRect; PROCEDURECageFromPosition (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; PROCEDURESetCursor (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; PROCEDUREFromRef (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; PROCEDUREToRefDefault (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; PROCEDUREReady (<*UNUSED*> v: Value): BOOLEAN = BEGIN RETURN TRUE END Ready; PROCEDURERead (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; PROCEDUREWrite (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; PROCEDUREAcquire (v: T; s: Selection; t: TimeStamp) RAISES {Error} = BEGIN LOCK v DO VBTClass.Acquire(v, s, t) END END Acquire; PROCEDURERelease (v: T; s: Selection) RAISES {} = BEGIN LOCK v DO VBTClass.Release(v, s) END END Release; PROCEDUREPut ( 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; PROCEDUREForge (v: T; type: MiscCodeType; READONLY detail: MiscCodeDetail) RAISES {Error} = BEGIN LOCK v DO VBTClass.Forge(v, type, detail) END END Forge; PROCEDUREForceRepaint (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}; PROCEDUREScroll ( 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; PROCEDUREPaintTint (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; PROCEDUREPolyTint ( 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; PROCEDUREPaintTexture ( 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; PROCEDUREPolyTexture ( 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; PROCEDUREPaintRegion ( 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; PROCEDUREPaintPixmap ( 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; PROCEDUREPixmapDomain (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; PROCEDUREPaintScrnPixmap ( 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; PROCEDUREPaintText ( 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 {} = BEGIN PaintSub(v, clp, rfpt, fntP, SUBARRAY(t^, 0, LAST(t^)), paintOp, dl) END PaintText; PROCEDUREPaintSub ( 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; PROCEDUREBoundingBox (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; PROCEDURETextWidth (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;
PROCEDUREFill ( 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; PROCEDUREStroke ( 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; PROCEDURELine ( 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; PROCEDUREPaintTrapezoid ( 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; PROCEDUREBeginGroup (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; PROCEDUREEndGroup (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; PROCEDURESync (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; PROCEDURECapture (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 = OBJECT holder : Thread.T := NIL; waitingForMe: Thread.T := NIL; END; VAR pedantic := RTParams.IsPresent("CheckShape"); PROCEDURENewShape (v: T) RAISES {} = BEGIN IF pedantic AND v.st # NIL AND LOOPHOLE(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; PROCEDUREPutProp (v: T; ref: REFANY) RAISES {} = BEGIN LOCK v DO PropertyV.Put(v.propset, ref) END END PutProp; PROCEDUREGetProp (v: T; tc: INTEGER): REFANY RAISES {} = BEGIN LOCK v DO RETURN PropertyV.Get(v.propset, tc) END END GetProp; PROCEDURERemProp (v: T; tc: INTEGER) RAISES {} = BEGIN LOCK v DO PropertyV.Remove(v.propset, tc) END END RemProp; PROCEDUREMark (v: T) RAISES {} = BEGIN LOCK v DO VBTRep.Mark(v) END END Mark; PROCEDUREIsMarked (v: T): BOOLEAN RAISES {} = BEGIN LOCK v DO RETURN VBTRep.Prop.Marked IN v.props END END IsMarked; PROCEDUREUnmark (v: T) RAISES {} = BEGIN LOCK v DO v.props := v.props - VBTRep.Props{VBTRep.Prop.Marked} END END Unmark; PROCEDUREDiscard (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; PROCEDUREMouseDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: MouseRec) RAISES {} = BEGIN END MouseDefault; PROCEDUREPositionDefault (<*UNUSED*> v : T; <*UNUSED*> READONLY cd: PositionRec) RAISES {} = BEGIN END PositionDefault; PROCEDUREReadDefault (<*UNUSED*> v : T; <*UNUSED*> s : Selection; <*UNUSED*> tc: CARDINAL ): Value RAISES {Error} = BEGIN RAISE Error(ErrorCode.Unreadable) END ReadDefault; PROCEDUREWriteDefault (<*UNUSED*> v : T; <*UNUSED*> s : Selection; <*UNUSED*> val: Value; <*UNUSED*> tc : CARDINAL ) RAISES {Error} = BEGIN RAISE Error(ErrorCode.Unwritable) END WriteDefault; PROCEDUREKeyCodeDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: KeyRec) RAISES {} = BEGIN END KeyCodeDefault; PROCEDUREMiscCodeDefault (<*UNUSED*> v: T; <*UNUSED*> READONLY cd: MiscRec) RAISES {} = BEGIN END MiscCodeDefault; PROCEDUREReshapeDefault (v: T; <*UNUSED*> READONLY cd: ReshapeRec) RAISES {} = BEGIN VBTClass.Repaint(v, Region.FromRect(v.domain)) END ReshapeDefault; PROCEDURERepaintDefault (<*UNUSED*> v : T; <*UNUSED*> READONLY rgn: Region.T) RAISES {} = BEGIN END RepaintDefault; PROCEDURERescreenDefault (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; PROCEDURERedisplayDefault (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; PROCEDUREDiscardDefault (<*UNUSED*> v: T) RAISES {} = BEGIN END DiscardDefault; PROCEDUREShapeDefault (<*UNUSED*> v : T; <*UNUSED*> ax: Axis.T; <*UNUSED*> n : CARDINAL): SizeRange RAISES {} = BEGIN RETURN DefaultShape END ShapeDefault; PROCEDUREGetSelection (name: TEXT): Selection = BEGIN RETURN Selection{GetAtom(name, sel)} END GetSelection; PROCEDUREGetMiscCodeType (name: TEXT): MiscCodeType = BEGIN RETURN MiscCodeType{GetAtom(name, mct)} END GetMiscCodeType; PROCEDURESelectionName (s: Selection): TEXT = BEGIN RETURN AtomName(s.sel, sel) END SelectionName; PROCEDUREMiscCodeTypeName (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; PROCEDUREGetAtom (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; PROCEDUREAtomName (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; PROCEDUREExtend (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; PROCEDURECrash () = <*FATAL FatalError*> BEGIN RAISE FatalError END Crash; VAR atomMu := NEW(MUTEX); sel, mct := AtomTable{0, NEW(TextIntTbl.Default).init(), NEW(TextSeq, 0)}; BEGIN mu := NEW(MUTEX); 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.