XTkStreamWidgetsImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Christian Jacobi, October 18, 1988 11:22:01 am PDT
Christian Jacobi, August 19, 1993 12:08 pm PDT
DIRECTORY
Ascii,
FanoutStream,
IO,
RefText,
Rope,
Xl,
XlCursor,
XlFontOps,
XTk,
XTkFriends,
XTkPrivate,
XTkStreamWidgets;
XTkStreamWidgetsImpl:
CEDAR
MONITOR
IMPORTS FanoutStream, IO, RefText, Xl, XlCursor, XlFontOps, XTk, XTkFriends, XTkPrivate
EXPORTS XTkStreamWidgets =
BEGIN
SetWindowSize:
ENTRY
PROC [oRef:
REF OutputRec, s: Xl.Size] = {
IF oRef#NIL THEN oRef.wSize ¬ s
};
HomePos:
ENTRY
PROC [oRef:
REF OutputRec] = {
IF oRef#
NIL
THEN {
oRef.pos.x ¬ oRef.leftSpace;
oRef.pos.y ¬ oRef.topOffset;
};
};
PosAndIncrement:
ENTRY
PROC [oRef:
REF OutputRec, rr:
INT]
RETURNS [pos: Xl.Point ¬ [0, 0]] = {
--increments position but returns previous value atomicly
IF oRef#
NIL
THEN {
pos ¬ oRef.pos;
oRef.pos.x ¬ oRef.pos.x+rr;
};
};
UnflushedOutChar:
PROC [oRef:
REF OutputRec, ch:
CHAR] = {
w: XTk.Widget ~ oRef.widget;
IF w.fastAccessAllowed#ok THEN RETURN;
SELECT ch
FROM
Ascii.
CR, Ascii.
LF => {
NewLine[oRef];
};
Ascii.
FF => {
HomePos[oRef];
Xl.ClearArea[w.connection, w.window, [0, 0], [2000, 2000], FALSE];
};
Ascii.NUL => {};
Ascii.
BS => {
oRef.pos.x ¬ MAX[oRef.pos.x-oRef.charDX, 0];
Xl.ClearArea[w.connection, w.window, [oRef.pos.x, MAX[oRef.pos.y, oRef.ascent]-oRef.ascent], [oRef.charDX, oRef.lineDY], FALSE];
};
ENDCASE => {
pos: Xl.Point;
IF INT[oRef.pos.x+oRef.charDX+oRef.rightSpace]>INT[oRef.wSize.width] AND oRef.pos.x>oRef.leftSpace THEN NewLine[oRef];
pos ¬ PosAndIncrement[oRef, oRef.charDX];
Xl.ImageChar[w.connection, w.window.drawable, pos, oRef.gc, ch];
};
};
NewLine:
PROC [oRef:
REF OutputRec] = {
w: XTk.Widget ~ oRef.widget;
mustScroll: INT ¬ AdvanceLine[oRef];
IF mustScroll>0
AND w.fastAccessAllowed=ok
THEN {
y: INT;
--scrollup
Xl.CopyArea[c: w.connection, src: w.window.drawable, dst: w.window.drawable, srcP: [0, mustScroll], dstP: [0, 0], size: [oRef.wSize.width, oRef.wSize.height-mustScroll], gc: oRef.gc];
--clear bottom
y ¬ MAX[oRef.pos.y, oRef.ascent]-oRef.ascent;
Xl.ClearArea[w.connection, w.window, [0, y], [2000, 2000]];
};
};
AdvanceLine:
ENTRY
PROC [oRef:
REF OutputRec]
RETURNS [mustScroll:
INT¬0] = {
oRef.pos.y ¬ oRef.pos.y+oRef.lineDY;
oRef.pos.x ¬ oRef.leftSpace;
IF
INT[oRef.pos.y+oRef.bottomOffset] >
INT[oRef.wSize.height]
THEN {
scrolling much has fallen in disfavor compared to scrolling a single line
mustScroll ¬ MIN[MAX[oRef.wSize.height/4, oRef.lineDY], oRef.wSize.height];
mustScroll ¬ MIN[oRef.lineDY, oRef.wSize.height];
oRef.pos.y ¬ oRef.pos.y - mustScroll;
}
};
outputStreamProcs:
REF
IO.StreamProcs ¬
IO.CreateStreamProcs[
variety: $output,
class: $XlTexts,
putChar: OutputTextWindowStreamPutChar,
putBlock: OutputTextWindowStreamPutBlock,
eraseChar: OutputTextWindowStreamEraseChar
];
OutputTextWindowStreamPutChar:
PROC [self:
IO.
STREAM, char:
CHAR] = {
ENABLE UNCAUGHT => GOTO Oops;
oRef: REF OutputRec ~ NARROW[self.streamData];
w: XTk.Widget ~ oRef.widget;
IF w.fastAccessAllowed#ok THEN RETURN;
UnflushedOutChar[oRef, char];
Xl.Flush[w.connection, TRUE];
EXITS Oops => {}
};
OutputTextWindowStreamPutBlock:
PROC [self:
IO.
STREAM, block:
REF
READONLY
TEXT, startIndex:
NAT, count:
NAT] = {
ENABLE UNCAUGHT => GOTO Oops;
oRef: REF OutputRec ~ NARROW[self.streamData];
w: XTk.Widget ~ oRef.widget;
Action: PROC[c: CHAR] RETURNS [BOOL¬FALSE] = {UnflushedOutChar[oRef, c]};
IF w.fastAccessAllowed#ok THEN RETURN;
[] ¬ RefText.Map[s: block, action: Action, len: count, start: startIndex];
Xl.Flush[w.connection, TRUE];
EXITS Oops => {}
};
OutputTextWindowStreamEraseChar:
PROC [self:
IO.
STREAM, char:
CHAR] = {
OutputTextWindowStreamPutChar[self, Ascii.BS]
};
outputClass: XTk.ImplementorClass ¬ XTkFriends.CreateClass[[key: $StreamWidget, wDataNum: 1, classNameHint: $Typescript, configureLR: Configure, initInstPart: StreamInitInstPart, forgetScreenLR: ForgetScreen]];
OutputRec:
TYPE =
RECORD [
widget: XTk.Widget, --backpointer for liveness
slave: IO.STREAM ¬ NIL,
font: Xl.Font ¬ Xl.nullFont,
wSize: Xl.Size ¬ [0, 0], --size of window
lineDY: INT ¬ 15, --distance between lines
leftSpace: NAT ¬ 2, --distance between left border and first character x origin
rightSpace: NAT ¬ 2, --distance between window right border and last characters right border
topOffset, bottomOffset: NAT ¬ 2, --distance between baseline and border
ascent, descent: NAT ¬ 2,
bottomSpace: NAT ¬ 2,
charDX: NAT ¬ 10,
lineSpace: NAT ¬ 2,
pos: Xl.Point ¬ [0, 0], --position for next character; not yet clipped
gc: Xl.GContext ¬ NIL --could we somehow share gc's?
];
GetOutputData:
PROC [w: XTk.Widget]
RETURNS [
REF OutputRec] =
INLINE {
RETURN [NARROW[XTkFriends.InstPart[w, outputClass]]];
};
NiceOpenFont:
PROC [c: Xl.Connection, name: Rope.
ROPE]
RETURNS [Xl.Font ¬ Xl.nullFont] = {
font: Xl.Font;
IF Rope.IsEmpty[name] OR ~Xl.Alive[c] THEN RETURN;
font ¬ Xl.OpenFont[c, name, XTkPrivate.detailsForSynchronous ! Xl.XError => GOTO Oops];
RETURN [font];
EXITS Oops => {};
};
Configure: XTk.ConfigureProc = {
oRef: REF OutputRec ~ GetOutputData[widget];
existW: BOOL ¬ widget.actualMapping<unconfigured;
createW: BOOL ¬ mapping<unconfigured AND ~existW;
IF createW
THEN {
IF Xl.IllegalCursor[widget.attributes.cursor]
THEN
widget.attributes.cursor ¬ XlCursor.SharedStandardCursor[widget.connection, circle];
IF widget.attributes.backgroundPixel=Xl.illegalPixel
THEN
widget.attributes.backgroundPixel ¬ widget.screenDepth.screen.whitePixel;
IF widget.attributes.backingStore=illegal
THEN
widget.attributes.backingStore ¬ always;
oRef.font ¬ NiceOpenFont[widget.connection, "8x13"];
IF oRef.font=Xl.nullFont
THEN
oRef.font ¬ NiceOpenFont[widget.connection, "6x13"];
IF oRef.font=Xl.nullFont
THEN {
--Oops, we should have a fix width font but this probably isn't. I prefer bad looking text to crashing...
oRef.font ¬ XlFontOps.GetDefaultFont[widget.connection];
};
BEGIN
fi: REF READONLY Xl.FontInfoRec ¬ Xl.QueryFont[widget.connection, oRef.font];
oRef.ascent ¬ fi.fontAscent;
oRef.descent ¬ fi.fontDescent;
oRef.lineDY ¬ oRef.ascent+oRef.descent+oRef.lineSpace;
oRef.charDX ¬ fi.maxBounds.charWidth;
oRef.topOffset ¬ oRef.ascent+oRef.lineSpace;
oRef.bottomOffset ¬ oRef.descent+oRef.bottomSpace;
oRef.gc ¬ Xl.MakeGContext[widget.connection]; --should we share contexts of same screen?
Xl.SetGCForeground[oRef.gc, widget.screenDepth.screen.blackPixel];
Xl.SetGCBackground[oRef.gc, widget.screenDepth.screen.whitePixel];
Xl.SetGCFont[oRef.gc, oRef.font];
END;
HomePos[oRef];
};
XTkFriends.SimpleConfigureOneLevelLR[widget, geometry, mapping, reConsiderChildren];
IF existW OR createW THEN SetWindowSize[oRef, widget.actual.size]
};
ForgetScreen: XTk.TerminateProc = {
oRef: REF OutputRec ~ GetOutputData[widget];
oRef.font ¬ Xl.nullFont;
oRef.gc ¬ NIL;
};
StreamInitInstPart: XTk.InitInstancePartProc = {
oRef: REF OutputRec ~ NEW[OutputRec];
oRef.slave ¬ IO.CreateStream[streamProcs: outputStreamProcs, streamData: oRef];
oRef.widget ¬ widget;
XTkFriends.AssignInstPart[widget, outputClass, oRef];
};
CreateStreamWidget:
PUBLIC
PROC [widgetSpec: XTk.WidgetSpec ¬ [], widgetStream:
IO.
STREAM ¬
NIL]
RETURNS [widget: XTk.Widget] = {
widget ¬ XTk.CreateWidget[widgetSpec, outputClass];
IF widgetStream#NIL THEN BindStream[widget, widgetStream];
};
CreateStream:
PUBLIC
PROC [w: XTk.Widget ¬
NIL]
RETURNS [widgetStream:
IO.
STREAM] = {
widgetStream ¬ FanoutStream.Create[reportErrors: FALSE, forwardClose: FALSE];
IF w#NIL THEN BindStream[w, widgetStream];
};
BindStream:
PUBLIC
PROC [w: XTk.Widget, widgetStream:
IO.
STREAM] = {
oRef: REF OutputRec ~ GetOutputData[w];
FanoutStream.AddSlave[master: widgetStream, slave: oRef.slave];
};
END.