ISNodeImpl.mesa
Copyright © 1985 by Xerox Corporation. All rights reserved.
edit by Ayers 17-May-85 14:25:00
Rick Beach, August 1, 1985 2:13:23 pm PDT
MKaplan, September 9, 1985 10:56:18 pm PDT
DIRECTORY
Context,
Environment,
Heap,
Inline,
Space,
StarWindowShell,
Window,
ISNode,
ISOut,
ISSession,
ISSessionOps,
ISToken;
ISNodeImpl: CEDAR MONITOR
IMPORTS Context, Heap, Inline, Space
EXPORTS ISNode
SHARES ISToken -- only for initialization a la 'handle ← []' due to Mesa inadequacy --
= BEGIN
nodePageAllocationUnit: CARDINAL = 8;
<<ISNodeObject: PUBLIC TYPE = RECORD [ ... in the defs so we can debug >>--
myType: Context.Type ← Context.UniqueType[];
WindowsNodeContext: PUBLIC PROCEDURE RETURNS [Context.Type] = {RETURN [myType]};
FromWindow: PUBLIC PROCEDURE [window: Window.Handle] RETURNS [ISNode.Handle] = BEGIN
data: REF ISNode.WindowsNodeContextRecord = Context.Find [myType, window];
RETURN [data.node]; -- allowing nil-check to propogate --
END;
ImplementationChainRecord: TYPE = RECORD [
next: ImplementationChainHandle,
tag: ATOM,
data: ISNode.Implementation ];
ImplementationChainHandle: TYPE = REF ImplementationChainRecord;
defaultImplChainHandle: ImplementationChainHandle;
defaultImplChain: ImplementationChainRecord ← [
next: NIL,
tag: NIL,
data: NIL ];
defaultImplChainData: ISNode.ImplementationObject ← [
internalize: NIL,
externalize: NIL,
destroy: NIL,
interpress: NIL,
createWindow: NIL,
enumerate: NIL,
copy: NIL,
getBinding: NIL,
setBinding: NIL,
getContentItem: NIL,
implementationClass: primary ];
implementationThread: ImplementationChainHandle ← NIL;
Create: PUBLIC PROCEDURE --[with: ISNode.Handle]--
RETURNS [ISNode.Handle] = BEGIN
h: ISNode.Handle ← NEW [ISNode.Object];
IF with=NIL THEN ERROR;
h ← AllocateNode [with];
h^ ← []; -- defaulting context records --
RETURN [h];
END;
PageFromNode: PRIVATE PROCEDURE [node: ISNode.Handle]
RETURNS [ISSessionOps.NodePagePointer] = INLINE
{long: Environment.Long ← LOOPHOLE[node];
long.low ← Inline.BITAND [long.low, 177400B];
RETURN [ LOOPHOLE [long, ISSessionOps.NodePagePointer] ]};
AllocateNode: PRIVATE PROCEDURE [n: ISNode.Handle]
RETURNS [ISNode.Handle] = BEGIN
loop: ISSessionOps.NodePagePointer ← PageFromNode [n];
head: ISSessionOps.NodePageBlockPointer ← loop.prefix.head;
IF head=NIL THEN ERROR; <<>>
FOR foo: ISSessionOps.NodePageBlockPointer ← head, foo[0].prefix.allocationThread
UNTIL foo=NIL DO
FOR index: NAT IN [0..ISSessionOps.pagesPerBlock) DO
IF foo[index].prefix.emptyNodeCount>0 THEN
BEGIN
FOR i: CARDINAL IN [0..ISSessionOps.nodesPerPage) DO
IF foo[index].nodes[i].empty THEN
BEGIN
foo[index].prefix.emptyNodeCount ← foo[index].prefix.emptyNodeCount - 1;
RETURN [@foo[index].nodes[i]];
END;
REPEAT
FINISHED => ERROR -- count says one here but not --
ENDLOOP;
END;
ENDLOOP;
ENDLOOP;
fall thru if all current nodepages are full --
BEGIN
block: ISSessionOps.NodePageBlockPointer
← Space.ScratchMap[ISSessionOps.pagesPerBlock];
block[0].prefix.allocationThread ← head[0].prefix.allocationThread;
head[0].prefix.allocationThread ← block;
FOR index: NAT IN [0..ISSessionOps.pagesPerBlock) DO
block[index] ← [
prefix: [session: loop.prefix.session, zone: loop.prefix.zone, head: head],
nodes: ALL [ [empty: TRUE] ] ];
ENDLOOP;
RETURN [AllocateNode [n]]; -- knowing there are now some empties --
END;
END;
AllocateInitialNode: PUBLIC PROCEDURE [session: REF, zone: UNCOUNTED ZONE]
RETURNS [ISNode.Handle] = BEGIN
block: ISSessionOps.NodePageBlockPointer
← Space.ScratchMap [ISSessionOps.pagesPerBlock];
block[0].prefix.allocationThread ← NIL; done below --
FOR index: NAT IN [0..ISSessionOps.pagesPerBlock) DO
block[index] ← [
prefix: [session: session, zone: zone, head: block],
nodes: ALL [ [empty: TRUE] ] ];
ENDLOOP;
RETURN [@block[0].nodes[0]];
END;
Copy: PUBLIC PROCEDURE [old: ISNode.Handle, with: ISNode.Handle ← NIL]
RETURNS [ISNode.Handle] = BEGIN
new: ISNode.Handle ← Create [--IF with#NIL THEN with ELSE old--];
primaryImpl: ISNode.Implementation;
primaryTag: ATOM;
[primaryImpl, primaryTag] ← GetPrimaryImplAndTag [old];
--<<>>--IF primaryImpl=NIL THEN ERROR;
FOR foo: ISNode.TagHandle ← old.tagThread, foo.next UNTIL foo=NIL DO
SetTag [new, foo.tag]; -- put the tags first --
ENDLOOP;
primaryImpl.copy [old: old, new: new]; -- let primary copy it first --
above handles the case of no tags --
FOR foo: ISNode.TagHandle ← old.tagThread, foo.next UNTIL foo=NIL DO
j: ISNode.Implementation ← GetImplementation [foo.tag, NIL];
IF j=NIL OR j.copy=NIL THEN ERROR; --<<sweat unstandard later>>--
IF foo.tag#primaryTag -- primary handled above --
AND j#NIL AND j.copy#NIL -- or error? -- THEN j.copy [old: old, new: new];
ENDLOOP;
RETURN [new];
END;
CreateWindow: PUBLIC PROCEDURE [
node: ISNode.Handle,
editMode: ISNode.EditMode,
shell: StarWindowShell.Handle,
micasPerPixel: CARDINAL]
RETURNS [Window.Handle] = BEGIN
j: ISNode.Implementation ← GetPrimaryImpl [node];
window: Window.Handle ← j.createWindow [node, editMode, shell, micasPerPixel];
RETURN [window];
END;
Externalize: PUBLIC PROCEDURE [
node: ISNode.Handle,
externalizeContext: --ISOut.Handle-- REF ] = BEGIN
j: ISNode.Implementation;
t: ATOM;
[j, t] ← GetPrimaryImplAndTag [node];
externalizeContext.PutOperator [externalizeContext, leftCurly];
j.externalize [node, externalizeContext];
FOR u: ISNode.TagHandle ← node.tagThread, u.next UNTIL u=NIL DO
IF u.tag#t THEN
BEGIN
v: ISNode.Implementation ← GetImplementation [u.tag, NIL];
IF v.implementationClass#onlyTag THEN
v.externalize [node, externalizeContext];
END;
ENDLOOP;
externalizeContext.PutOperator [externalizeContext, rightCurly];
END;
Destroy: PUBLIC PROCEDURE [is: REF REF ISNode.Object] = BEGIN
<<is^ ← NIL;>>
END;
SetContext: PUBLIC PROCEDURE [
node: REF ISNode.Object,
type: ATOM,
context: ISToken.InterscriptContext ] = BEGIN -- not checking for duplicates --
newContext: ISNode.ContextHandle ← NEW[ISNode.ContextRecord ← [context: context, next: NIL, type: type]];
IF node.contextThread=NIL THEN node.contextThread ← newContext
ELSE FOR c: ISNode.ContextHandle ← node.contextThread, c.next DO
IF c.next=NIL THEN {
c.next ← newContext;
EXIT;
};
ENDLOOP
END;
GetContext: PUBLIC PROCEDURE [node: REF ISNode.Object, type: ATOM]
RETURNS [context: ISToken.InterscriptContext] = BEGIN
FOR foo: ISNode.ContextHandle ← node.contextThread, foo.next UNTIL foo=NIL DO
IF foo.type=type THEN RETURN [foo.context];
ENDLOOP;
RETURN [NIL]; -- or error? --
END;
SetTag: PUBLIC PROCEDURE [
node: REF ISNode.Object,
tag: ATOM ] = BEGIN
IF HasTag [node, tag] THEN RETURN
ELSE
BEGIN
foo: ISNode.TagHandle ← NEW[ISNode.TagRecord ← [tag: tag, next: node.tagThread]];
node.tagThread ← foo;
node.implementationChainHandle ← NIL; -- clear accelerator --
END;
END;
ClearTag: PUBLIC PROCEDURE [node: REF ISNode.Object, tag: ATOM] = BEGIN
node.implementationChainHandle ← NIL; -- clear accelerator --
WHILE HasTag [node, tag] DO
IF node.tagThread#NIL AND node.tagThread.tag=tag THEN
node.tagThread ← node.tagThread.next
ELSE
FOR t: ISNode.TagHandle ← node.tagThread, t.next UNTIL t.next=NIL DO
IF t.next.tag=tag THEN t.next ← t.next.next;
ENDLOOP;
ENDLOOP;
END;
HasTag: PUBLIC PROCEDURE [node: REF ISNode.Object, tag: ATOM]
RETURNS [BOOLEAN] = BEGIN
FOR foo: ISNode.TagHandle ← node.tagThread, foo.next UNTIL foo=NIL DO
IF foo.tag=tag THEN RETURN [TRUE];
ENDLOOP;
RETURN [FALSE];
END;
SetImplementation: PUBLIC ENTRY PROCEDURE [
tag: ATOM,
family: ATOM,
implementation: ISNode.Implementation]
RETURNS [ISNode.Implementation] = BEGIN
icr: ImplementationChainHandle;
oldImpl: ISNode.Implementation;
This is a slightly-exciting fixup: --
IF implementation.internalize=NIL THEN
implementation.internalize ← defaultImplChain.data.internalize;
IF implementation.externalize=NIL THEN
implementation.externalize ← defaultImplChain.data.externalize;
IF implementation.destroy=NIL THEN
implementation.destroy ← defaultImplChain.data.destroy;
IF implementation.interpress=NIL THEN
implementation.interpress ← defaultImplChain.data.interpress;
IF implementation.createWindow=NIL THEN
implementation.createWindow ← defaultImplChain.data.createWindow;
IF implementation.enumerate=NIL THEN
implementation.enumerate ← defaultImplChain.data.enumerate;
IF implementation.copy=NIL THEN
implementation.copy ← defaultImplChain.data.copy;
IF implementation.createWindow=NIL THEN
implementation.createWindow ← defaultImplChain.data.createWindow;
FOR icr ← implementationThread, icr.next UNTIL icr=NIL DO
IF icr.tag=tag THEN {oldImpl ← icr.data; icr.data ← implementation; EXIT};
REPEAT
FINISHED =>
BEGIN
oldImpl ← defaultImplChain.data;
icr ← NEW [ImplementationChainRecord];
icr^ ← [next: implementationThread, tag: tag, data: implementation];
implementationThread ← icr;
END;
ENDLOOP;
IF tag=NIL AND family=NIL THEN defaultImplChain.data ← implementation;
RETURN [oldImpl];
END;
GetImplementation: PUBLIC PROCEDURE [tag: ATOM, family: ATOM]
RETURNS [ISNode.Implementation] = BEGIN
FOR icr: ImplementationChainHandle ← implementationThread, icr.next
UNTIL icr=NIL DO IF icr.tag=tag THEN RETURN [icr.data]; ENDLOOP;
RETURN [defaultImplChain.data];
END;
GetImplementationChain: PUBLIC ENTRY PROCEDURE [tag: ATOM, family: ATOM]
RETURNS [ImplementationChainHandle] = BEGIN
FOR icr: ImplementationChainHandle ← implementationThread, icr.next
UNTIL icr=NIL DO IF icr.tag=tag THEN RETURN [icr]; ENDLOOP;
RETURN [defaultImplChainHandle];
END;
Enumerate: PUBLIC ISNode.EnumerateChildrenProc = BEGIN
i: ISNode.Implementation ← GetPrimaryImpl[node];
IF i.enumerate#NIL THEN i.enumerate [node, context, enumerationProc];
END;
GetPrimaryImpl: PUBLIC PROCEDURE [node: ISNode.Handle]
RETURNS [ISNode.Implementation] = BEGIN
im: ImplementationChainHandle;
IF node=NIL THEN ERROR;--<<>>--
IF (im←NARROW[node.implementationChainHandle])=NIL THEN
BEGIN
FOR d: ISNode.TagHandle ← node.tagThread, d.next UNTIL d=NIL DO
im ← GetImplementationChain [d.tag, NIL];
IF im#NIL AND im.data.implementationClass=primary THEN EXIT;
REPEAT
FINISHED => im ← defaultImplChainHandle;
ENDLOOP; -- example of defaultable node: labels ← { Label2 Label3 } --
node.implementationChainHandle ← im;
END;
RETURN [im.data];
END;
GetPrimaryImplAndTag: PUBLIC PROCEDURE [node: ISNode.Handle]
RETURNS [implementation: ISNode.Implementation, tag: ATOM] = BEGIN
im: ImplementationChainHandle;
IF node=NIL THEN ERROR;--<<>>--
IF (im←NARROW[node.implementationChainHandle])=NIL THEN
BEGIN
FOR d: ISNode.TagHandle ← node.tagThread, d.next UNTIL d=NIL DO
im ← GetImplementationChain [d.tag, NIL];
IF im#NIL AND im.data.implementationClass=primary THEN EXIT;
REPEAT
FINISHED => im ← defaultImplChainHandle;
ENDLOOP; -- example of defaultable node: labels ← { Label2 Label3 } --
node.implementationChainHandle ← im;
END;
RETURN [im.data, im.tag];
END;
GetZone: PUBLIC PROCEDURE [handle: ISNode.Handle] RETURNS [UNCOUNTED ZONE] = BEGIN
npp: ISSessionOps.NodePagePointer ← PageFromNode [handle];
RETURN [npp.prefix.zone];
END;
defaultImplChainHandle ← NEW[ImplementationChainRecord ← defaultImplChain];
defaultImplChain.data ← NEW[ISNode.ImplementationObject ← defaultImplChainData];
[] ← SetImplementation [NIL, NIL, defaultImplChain.data];
END.