Copyright (C) 1994, Digital Equipment Corp.
by Steve Glassman, Mark Manasse and Greg Nelson
<*PRAGMA LL*>
UNSAFE MODULE XScreenType;
IMPORT X, XClient, Rect, PaintOp, Pixmap, TrestleComm, ScreenType, Axis,
TrestleOnX, XScrnTpRep, XScrnFont, XScrnCmap, XScrnCrsr, XScrnPntOp,
XScrnPxmp, XGC, Ctypes, Word;
REVEAL T = XGC.T BRANDED OBJECT END;
PROCEDURE New (trsl: XClient.T; dpy: X.DisplayStar; i: INTEGER): T =
VAR
res := NEW(T, trsl := trsl);
n : Ctypes.int;
template: X.XVisualInfo;
visuals : X.XVisualInfoStar;
BEGIN
TRY
TrestleOnX.Enter(trsl);
TRY
template.visualid :=
X.XVisualIDFromVisual(X.XDefaultVisual(dpy, i));
template.screen := i;
visuals :=
X.XGetVisualInfo(dpy, X.VisualIDMask + X.VisualScreenMask,
ADR(template), ADR(n));
TRY
WITH vis = LOOPHOLE(visuals, UNTRACED REF
ARRAY [0 .. 9999] OF X.XVisualInfo) DO
template.depth := -1;
FOR i := 0 TO n - 1 DO
IF vis[i].depth > template.depth THEN template := vis[i]; END
END
END
FINALLY
X.XFree(LOOPHOLE(visuals, Ctypes.char_star))
END;
(* res.depth > 0, since the default visual must be supported. *)
res.depth := template.depth;
res.color := (template.class # X.StaticGray)
AND (template.class # X.GrayScale);
res.bg := X.XWhitePixel(dpy, i);
res.fg := X.XBlackPixel(dpy, i);
(* res.backing_store := X.XDoesBackingStore(X.XScreenOfDisplay(dpy,
i)); *)
New2(dpy, i, res);
res.font := XScrnFont.NewOracle(res);
res.cmap := XScrnCmap.NewOracle(res, template);
res.nullCursor := XScrnCrsr.NullCursor(dpy, res.root)
FINALLY
TrestleOnX.Exit(trsl)
END;
res.bits := NewDepthOne(trsl, dpy, i)
EXCEPT
X.Error, TrestleComm.Failure => (*skip*)
END;
RETURN res
END New;
PROCEDURE NewDepthOne (trsl: XClient.T; dpy: X.DisplayStar; i: INTEGER):
T =
VAR res := NEW(T, trsl := trsl);
BEGIN
TRY
TrestleOnX.Enter(trsl);
TRY
res.depth := 1;
res.color := FALSE;
res.bg := 0;
res.fg := 1;
res.bits := res;
New2(dpy, i, res);
res.font := XScrnFont.NewOracle(res, TRUE);
res.cmap := NIL
FINALLY
TrestleOnX.Exit(trsl)
END
EXCEPT
TrestleComm.Failure => (*skip*)
END;
RETURN res
END NewDepthOne;
CONST GCValueMask = Word.Or(X.GCFunction, X.GCPlaneMask);
VAR gcValues := NEW(X.XGCValuesStar);
PROCEDURE New2 (dpy: X.DisplayStar; i: INTEGER; res: T)
RAISES {TrestleComm.Failure} =
(* The initialization common to st and st.bits. LL = trsl *)
BEGIN
TRY
res.res[Axis.T.Hor] :=
FLOAT(X.XDisplayWidth(dpy, i)) / FLOAT(X.XDisplayWidthMM(dpy, i));
res.res[Axis.T.Ver] :=
FLOAT(X.XDisplayHeight(dpy, i)) / FLOAT(X.XDisplayHeightMM(dpy, i));
res.op := XScrnPntOp.NewOracle(res);
res.cursor := XScrnCrsr.NewOracle(res);
res.pixmap := XScrnPxmp.NewOracle(res);
res.optable :=
NEW(REF ARRAY OF XScrnTpRep.OpRecord, NUMBER(PaintOp.Predefined));
res.pmtable :=
NEW(REF ARRAY OF XScrnTpRep.PixmapRecord, NUMBER(Pixmap.Predefined));
res.root := X.XRootWindow(dpy, i);
res.rootDom :=
Rect.FromSize(X.XDisplayWidth(dpy, i), X.XDisplayHeight(dpy, i));
res.screenID := i;
res.visual := X.XDefaultVisual(dpy, i);
res.imageGC := X.XCreateGC(dpy, res.root, GCValueMask, gcValues);
EXCEPT X.Error => RAISE TrestleComm.Failure END;
END New2;
BEGIN
gcValues.function := X.GXcopy;
gcValues.plane_mask := X.XAllPlanes();
END XScreenType.