[Cyan]<CedarChest7.0>SetsAndStuff>BiRelsImpl.Mesa!7

BiRelsImpl.Mesa

Last tweaked by Mike Spreitzer on December 14, 1987 2:06:39 pm PST

DIRECTORY AbSets, Atom, BiRelBasics, BiRels, BiRelsPrivate, IntStuff, List, Process, Rope, SetBasics, SharedErrors;

BiRelsImpl: CEDAR MONITOR

LOCKS lp USING lp: LockPtr

IMPORTS AbSets, Atom, BiRelBasics, BiRels, BiRelsPrivate, IntStuff, List, Process, SetBasics, SharedErrors

EXPORTS BiRels, BiRelsPrivate

BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets, BiRelBasics, BiRels, BiRelsPrivate;

LockPtr: TYPE ~ LONG POINTER TO MONITORLOCK;

Cant: PUBLIC ERROR [br: BiRel] ~ CODE;

mappingNotSingleton: PUBLIC ROPE ~ R["mapping of %g isn't a singleton"];

fixedSide: PUBLIC ROPE ~ R["%g's %g side can't be varied"];

denseSide: PUBLIC ROPE ~ R["%g's %g side must remain dense"];

badBiRel: PUBLIC BiRel ~ [NIL, R["bad BiRel"]];

provisionKey: ATOM ~ $BiRelsImplProvision;

dirableKey: ATOM ~ $BiRelsImplDirable;

kindKey: ATOM ~ $BiRelsImplKind;

Proc: TYPE ~ PROC ANY RETURNS ANY;

CreateClass: PUBLIC PROC [cp: BiRelClassPrivate, dirable: BoolPair ← [TRUE, FALSE]] RETURNS [class: BiRelClass] ~ {

provs: Atom.PropList ← NARROW[List.Assoc[key: provisionKey, aList: cp.other]];

Sp: PROC [op: ATOM, proc: Proc] RETURNS [def: BOOL] ~ {

provs ← List.PutAssoc[op, IF (def ← proc=NIL) THEN $Default ELSE $Primitive, provs];

RETURN};

{OPEN cp;

IF Sp[$AsSet, AsSet] THEN AsSet ← DefaultAsSet;

IF Sp[$HasPair, HasPair] THEN HasPair ← DefaultHasPair;

IF Sp[$Image, Image] THEN Image ← DefaultImage;

IF Sp[$Apply, Apply] THEN Apply ← DefaultApply;

IF Sp[$ScanRestriction, ScanRestriction] THEN ScanRestriction ← DefaultScanRestriction;

IF Sp[$GetOne, GetOne] THEN GetOne ← DefaultGetOne;

IF Sp[$Get3, Get3] THEN Get3 ← DefaultGet3;

IF Sp[$Index, Index] THEN Index ← DefaultIndex;

IF Sp[$RestrictionSize, RestrictionSize] THEN RestrictionSize ← DefaultRestrictionSize;

IF Sp[$GetBounds, GetBounds] THEN GetBounds ← DefaultGetBounds;

IF Sp[$Copy, Copy] THEN Copy ← DefaultCopy;

IF Sp[$Insulate, Insulate] THEN Insulate ← DefaultInsulate;

IF Sp[$ValueOf, ValueOf] THEN ValueOf ← DefaultValueOf;

IF Sp[$Freeze, Freeze] THEN Freeze ← DefaultFreeze;

IF Sp[$Thaw, Thaw] THEN Thaw ← DefaultThaw;

IF Sp[$SetOn, SetOn] THEN SetOn ← DefaultSetOn;

IF Sp[$CurSetOn, CurSetOn] THEN CurSetOn ← DefaultCurSetOn;

IF Sp[$AddPair, AddPair] THEN AddPair ← DefaultAddPair;

IF Sp[$AddSet, AddSet] THEN AddSet ← DefaultAddSet;

IF Sp[$Swap, Swap] THEN Swap ← DefaultSwap;

IF Sp[$RemPair, RemPair] THEN RemPair ← DefaultRemPair;

IF Sp[$RemSet, RemSet] THEN RemSet ← DefaultRemSet;

IF Sp[$Delete, Delete] THEN Delete ← DefaultDelete;

IF Sp[$DeleteSet, DeleteSet] THEN DeleteSet ← DefaultDeleteSet;

IF Sp[$ReplaceMe, ReplaceMe] THEN ReplaceMe ← DefaultReplaceMe;

IF Sp[$ShiftAndClipMe, ShiftAndClipMe] THEN ShiftAndClipMe ← DefaultShiftAndClipMe;

IF Sp[$IsDense, IsDense] THEN IsDense ← DefaultIsDense;

IF Sp[$SideFixed, SideFixed] THEN SideFixed ← DefaultSideFixed;

};

cp.other ← List.PutAssoc[provisionKey, provs, cp.other];

cp.other ← List.PutAssoc[dirableKey, NEW [BoolPair ← dirable], cp.other];

class ← NEW [BiRelClassPrivate ← cp];

RETURN};

Primitive: PUBLIC PROC [br: BiRel, op: ATOM, arg1, arg2: REF ANY ← NIL] RETURNS [BOOL] ~ {

kind: REF ANY ~ Atom.GetProp[op, kindKey];

IF arg1#NIL AND ISTYPE[arg1, LORA] THEN ERROR--somebody called with one LIST of args rather than separate args--;

WITH kind SELECT FROM

a: ATOM => SELECT a FROM

$always => RETURN [TRUE];

$argless => NULL;

$composite => ERROR;

ENDCASE => ERROR;

a: REF ArgTyping => NULL;

ENDCASE => ERROR;

IF br.class.Primitive#NIL THEN SELECT br.class.Primitive[br, op, arg1, arg2] FROM

yes => RETURN [TRUE];

no => RETURN [FALSE];

pass => NULL;

ENDCASE => ERROR;

{provs: Atom.PropList ~ NARROW[List.Assoc[provisionKey, br.class.other]];

prov: REF ANY ~ List.Assoc[op, provs];

SELECT prov FROM

$Default => RETURN [FALSE];

$Primitive => WITH kind SELECT FROM

a: ATOM => SELECT a FROM

$argless => RETURN [TRUE];

$always, $composite => ERROR;

ENDCASE => ERROR;

types: REF ArgTyping => {

args: ARRAY [1 .. 2] OF REF ANY ~ [arg1, arg2];

FOR i: NATURAL IN [1 .. 2] DO

type: ArgType ~ types[i];

SELECT type FROM

$None, $Set, $SetPair, $RelOrder, $RelOrderFN, $Want3, $limit, $When, $Side, $EndBools, $BiRel => NULL;

$Dir => {dir: Direction ~ ToDir[args[i]];

dirable: REF BoolPair ~ NARROW[List.Assoc[dirableKey, br.class.other]];

IF NOT dirable[dir] THEN RETURN [FALSE]};

$remove => IF br.MutabilityOf[]#variable AND ToBool[args[i]] THEN RETURN [TRUE];

ENDCASE => ERROR;

ENDLOOP;

RETURN [TRUE]};

ENDCASE => ERROR;

}};

refOne: RefEINT ~ FromEI[one];

refSetAllInts: RefSet ~ Sets.IIAsSet[[]].Refify;

QualityOf: PUBLIC PROC [br: BiRel, op: ATOM, arg1, arg2, arg3, arg4: REF ANY ← NIL] RETURNS [ImplQuality] ~ {

IF arg1#NIL AND ISTYPE[arg1, LORA] THEN ERROR--somebody called with one LIST of args rather than separate args--;

WITH Atom.GetProp[op, kindKey] SELECT FROM

a: ATOM => SELECT a FROM

$always => RETURN [primitive];

$argless => NULL;

$composite => SELECT op FROM

$Mapping => {dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$Image, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir]]};

$Enumerate => RETURN br.QualityOf[$Scan, arg1, arg2, arg3, arg4];

$Scan => RETURN br.QualityOf[$ScanRestriction, refNilSets, arg1];

$EnumerateImage => RETURN br.QualityOf[$ScanImage, arg1, arg2, arg3, arg4];

$ScanImage => {

set: RefSet ~ ToSet[arg1];

dir: Direction ~ ToDir[arg2];

ro: Sets.RelOrder ~ Sets.ToRO[arg3];

RETURN br.QualityOf[$ScanHalfRestriction, set, FromSide[Source[dir]], FromRO[ConsRelOrder[Dest[dir], ro]]]};

$EnumerateMapping => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$EnumerateImage, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$ScanMapping => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$ScanImage, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$EnumerateHalfRestriction => RETURN br.QualityOf[$ScanHalfRestriction, arg1, arg2, arg3, arg4];

$ScanHalfRestriction => RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[ToSide[arg2], ToSet[arg1]^]], arg3];

$APair => RETURN QMin[br.QualityOf[$GetOne, $FALSE, arg1, arg2], goodDefault];

$Pop => RETURN QMin[br.QualityOf[$GetOne, $TRUE, arg1, arg2], goodDefault];

$Next => RETURN br.QualityOf[$Get3, FromRO[ToRO[arg1, [[fwd, no]]]], $FFT];

$Prev => RETURN br.QualityOf[$Get3, FromRO[ToRO[arg1, [[fwd, no]]]], $TFF];

$SkipTo => {

goal: RefSet ~ ToSet[arg1];

bounds: Interval ~ ToInterval[arg2]^;

side: Side ~ ToSide[arg3];

bwd: BOOL ~ ToBool[arg4];

RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[side, IntervalAsSet[br.Spaces[][side], bounds], goal^]], FromRO[ConsRelOrder[side, IF bwd THEN bwd ELSE fwd]]]};

$Lookup => {

bounds: RefInterval ~ ToInterval[arg1];

side: Side ~ ToSide[arg2];

RETURN br.QualityOf[$SkipTo, Sets.FakeRefSingleton[br.Spaces[][side]], arg1, arg2, arg3]};

$Size => RETURN br.QualityOf[$RestrictionSize, refNilSets, arg1];

$Empty => RETURN br.QualityOf[$Size, refOne];

$ImageSize => {set: Set ~ ToSet[arg1]^;

limit: RefEINT ~ ToEI[arg3];

easy: BOOL ~ set.GoodImpl[$Size] AND set.Size[two].Compare[two]<equal;

IF easy THEN RETURN br.QualityOf[$RestrictionSize, FromSets[ConsSets[Source[ToDir[arg2]], set]], limit];

IF NOT br.Can[$Scan] THEN RETURN [cant];

RETURN [IF limit^.Compare[two]<=equal THEN goodDefault ELSE poorDefault]};

$MappingSize => {

dir: Direction ~ ToDir[arg1];

RETURN br.QualityOf[$ImageSize, Sets.FakeRefSingleton[br.Spaces[][Source[dir]]], FromDir[dir], arg2]};

$AddNewPair => RETURN br.QualityOf[$AddPair];

$AddNewSet => RETURN br.QualityOf[$AddSet, arg1];

$Erase => RETURN br.QualityOf[$RemSet, br.Refify];

$GetIntDom => RETURN br.QualityOf[$GetBounds, arg1, arg2, arg3, arg4];

ENDCASE => ERROR;

a: REF ArgTyping => NULL;

ENDCASE => ERROR;

IF Primitive[br, op, arg1, arg2] THEN RETURN [primitive];

SELECT op FROM

$AsSet => RETURN [goodDefault];

$HasPair => {spaces: SpacePair ~ br.Spaces[];

RETURN br.QualityOf[$ScanRestriction, FromSets[[Sets.FakeSingleton[spaces[left]], Sets.FakeSingleton[spaces[right]]]]].QMin[goodDefault]};

$Image => {set: RefSet ~ ToSet[arg1];

dir: Direction ~ ToDir[arg2];

RETURN [IF br.GoodImpl[$ScanRestriction, FromSets[ConsSets[Source[dir], set^]]] THEN goodDefault ELSE poorDefault]};

$Apply => {src: Side ~ Source[ToDir[arg1]];

RETURN br.QualityOf[$ScanRestriction, FromSets[ConsSets[src, Sets.CreateSingleton[noValue, br.Spaces[][src]]]]].QMin[goodDefault]};

$ScanRestriction => {

sets: RefSetPair ~ ToSets[arg1];

ro: RelOrder ~ ToRO[arg2].CanonizeRelOrder[br.Functional[]];

plan: BiRelsPrivate.Analysis;

can: BOOL;

[can, plan] ← BiRelsPrivate.PlanDefaultScanRestriction[br, sets^, ro];

IF NOT can THEN RETURN [cant];

RETURN [IF plan.cost.sort = ALL[asIs] THEN goodDefault ELSE poorDefault]};

$GetOne => {remove: BOOL ~ ToBool[arg1];

ro: RelOrder ~ ToRO[arg2];

IF remove AND br.MutabilityOf[]#variable THEN RETURN [goodDefault];

RETURN QMin[

br.QualityOf[$Scan, FromRO[ro]].QMin[goodDefault],

IF remove THEN br.QualityOf[$RemPair] ELSE goodDefault]};

$Get3 => {

ro: RelOrder ~ ToRO[arg1, [[fwd, no]]].CanonizeRelOrder[br.Functional];

fq, bq, nq: ImplQuality ← br.QualityOf[$Scan, FromRO[ro]];

rro: RelOrder;

IF ro.sub # ALL[no] THEN {

rro ← ro.ReverseRO[];

bq ← br.QualityOf[$Scan, FromRO[rro]];

nq ← br.QualityOf[$Scan]};

{max: ImplQuality ~ QMax[nq, QMax[fq, bq]];

uro: RelOrder ~ IF bq=max AND fq<max THEN rro ELSE IF fq=max THEN ro ELSE [];

RETURN br.QualityOf[$Scan, FromRO[uro]].QMin[goodDefault]}};

$Index => {goal: IntRel ~ ToBiRel[arg1]^;

RETURN QMin[QMin[poorDefault, goal.QualityOf[$GetIntDom]],

QMin[br.QualityOf[$Mapping], goal.QualityOf[$Mapping]]]};

$RestrictionSize => {

sets: RefSetPair ~ ToSets[arg1];

limit: EINT ~ ToEI[arg2]^;

RETURN br.QualityOf[$ScanRestriction, sets].QMin[IF limit.Compare[two]<=equal THEN goodDefault ELSE poorDefault]};

$GetBounds => {

want: EndBools ~ ToEB[arg1];

ro: RelOrder ~ ToRO[arg2, [[fwd, no]]].CanonizeRelOrder[br.Functional];

rro: RelOrder ~ ro.ReverseRO[];

((NOT want[min]) OR Primitive[br, $ScanRestriction, refNilSets, FromRO[ro]]) AND

((NOT want[max]) OR Primitive[br, $ScanRestriction, refNilSets, FromRO[rro]])

THEN {q: ImplQuality ← goodDefault;

FOR e: End IN End DO

IF want[e] THEN {

uro: RelOrder ~ IF e=min THEN ro ELSE rro;

q ← q.QMin[br.QualityOf[$APair, FromRO[uro]]]};

ENDLOOP;

RETURN [q]}

ELSE RETURN br.QualityOf[$Scan].QMin[poorDefault]};

$Copy => RETURN [cant];

$Insulate => RETURN [goodDefault];

$ValueOf => RETURN [IF br.MutabilityOf#constant THEN QMin[br.QualityOf[$Copy], br.QualityOf[$Freeze]].QMin[goodDefault] ELSE goodDefault];

$Freeze, $Thaw => RETURN [IF br.MutabilityOf#variable THEN goodDefault ELSE cant];

$SetOn => RETURN [poorDefault];

$CurSetOn => RETURN [IF br.MutabilityOf=constant THEN poorDefault ELSE cant];

$AddPair => RETURN [IF Primitive[br, $AddSet, FakeRefSingleton[br.Spaces[]]] THEN goodDefault ELSE cant];

$AddSet => RETURN [IF Primitive[br, $AddPair] THEN goodDefault ELSE cant];

$Swap => {side: Side ~ ToSide[arg1]; dir: Direction ~ From[side];

RETURN QMin[QMin[

br.QualityOf[$Mapping, FromDir[dir]],

br.QualityOf[$Delete, FromSide[side]]], QMin[

br.QualityOf[$ScanMapping, FromDir[dir]],

br.QualityOf[$AddPair]]].QMin[

goodDefault]};

$RemPair => RETURN [IF Primitive[br, $RemSet, FakeRefSingleton[br.Spaces[]]] THEN goodDefault ELSE cant];

$RemSet => RETURN [IF Primitive[br, $RemPair] THEN goodDefault ELSE cant];

$Delete => {side: Side ~ ToSide[arg1];

RETURN br.QualityOf[$DeleteSet, Sets.FakeRefSingleton[br.Spaces[][side]], FromSide[side]].QMin[goodDefault]};

$DeleteSet => {set: RefSet ~ ToSet[arg1];

side: Side ~ ToSide[arg2];

IF Primitive[br, $Delete, FromSide[side]] THEN RETURN [goodDefault];

RETURN QMin[QMin[

set^.QualityOf[$Scan],

br.QualityOf[$RemPair]], QMin[

br.QualityOf[$ScanMapping, FromDir[From[side]]],

poorDefault]]};

$ReplaceMe => {with: IntRel ~ ToBiRel[arg1]^;

RETURN QMin[QMin[

with.QualityOf[$GetIntDom],

br.QualityOf[$DeleteSet, refSetAllInts]], QMin[

SubShiftQuality[br],

br.QualityOf[$AddSet, with.Refify]]].QMin[

poorDefault]};

$ShiftAndClipMe => RETURN QMin[QMin[poorDefault,

br.QualityOf[$DeleteSet, refSetAllInts]],

SubShiftQuality[br]];

$IsDense => RETURN [poorDefault];

$SideFixed => RETURN [IF br.MutabilityOf[]=constant THEN goodDefault ELSE poorDefault];

ENDCASE => ERROR;

};

SubShiftQuality: PROC [br: BiRel] RETURNS [ImplQuality] ~ {

RETURN QMin[QMin[

br.QualityOf[$GetIntDom],

br.QualityOf[$ScanMapping]], QMin[

br.QualityOf[$AddPair],

br.QualityOf[$RemPair]]]};

Enumerate: PUBLIC PROC [br: BiRel, Consume: PROC [Pair], ro: RelOrder ← []] ~ {

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair]; RETURN [FALSE]};

IF br.Scan[Pass, ro].found THEN ERROR};

EnumAA: PUBLIC PROC [br: BiRel, Consume: PROC [REF ANY, REF ANY], ro: RelOrder ← []] ~ {

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VA, pair[right].VA]; RETURN [FALSE]};

IF br.Scan[Pass, ro].found THEN ERROR};

EnumIA: PUBLIC PROC [br: BiRel, Consume: PROC [INT, REF ANY], ro: RelOrder ← []] ~ {

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VI, pair[right].VA]; RETURN [FALSE]};

IF br.Scan[Pass, ro].found THEN ERROR};

EnumII: PUBLIC PROC [br: BiRel, Consume: PROC [INT, INT], ro: RelOrder ← []] ~ {

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[left].VI, pair[right].VI]; RETURN [FALSE]};

IF br.Scan[Pass, ro].found THEN ERROR};

EnumerateImage: PUBLIC PROC [br: BiRel, set: Set, Consume: PROC [Value], dir: Direction ← leftToRight, ro: Sets.RelOrder ← no] ~ {

dest: Side ~ Dest[dir];

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {Consume[pair[dest]]; RETURN [FALSE]};

IF br.ScanHalfRestriction[set, Pass, Source[dir], ConsRelOrder[dest, ro]].found THEN ERROR;

RETURN};

Forked: TYPE ~ REF ForkedPrivate;

ForkedPrivate: TYPE ~ RECORD [

set: ARRAY Which OF BiRel,

ready: ARRAY Which OF BOOL ← ALL[FALSE],

done: BOOL ← FALSE,

change: CONDITION ← [timeout: Process.SecondsToTicks[10]],

val: ARRAY Which OF MaybePair ← ALL[[TRUE, noPair]],

lock: MONITORLOCK ← []

];

InterleavedProduceRestriction: PUBLIC PROC [a, b: BiRel, Consume: InterleavedConsumer, setsA, setsB: SetPair ← [], roA, roB: RelOrder ← []] RETURNS [ans: MaybePair ← noMaybePair] ~ {

fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b]]];

GenA: PROC ~ {ForkScan[fkd, a, setsA, roA]};

GenB: PROC ~ {ForkScan[fkd, b, setsB, roB]};

TestAB: PROC ~ TRUSTED {

Produce: PROC [w: Which] RETURNS [MaybePair] ~ TRUSTED {

Wait: ENTRY SAFE PROC [lp: LockPtr] RETURNS [MaybePair] ~ CHECKED {

ENABLE UNWIND => NULL;

UNTIL fkd.ready[w] DO WAIT fkd.change ENDLOOP;

RETURN [fkd.val[w]]};

RETURN Wait[@fkd.lock]};

Finish: ENTRY SAFE PROC [lp: LockPtr] ~ CHECKED {

ENABLE UNWIND => NULL;

fkd.done ← TRUE;

fkd.ready ← ALL[FALSE];

BROADCAST fkd.change;

RETURN};

ans ← Consume[Produce];

Finish[@fkd.lock];

RETURN};

TRUSTED {

Process.EnableAborts[@fkd.change];

SharedErrors.Fork[LIST[GenA, GenB, TestAB]]};

RETURN};

ParallelScanRestriction: PUBLIC PROC [a, b: BiRel, Test: ParallelTester, setsA, setsB: SetPair ← [], roA, roB: RelOrder ← []] RETURNS [pf: ParallelFind ← [FALSE, noMaybePair, noMaybePair]] ~ {

fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b] ]];

GenA: PROC ~ {ForkScan[fkd, a, setsA, roA]};

GenB: PROC ~ {ForkScan[fkd, b, setsB, roB]};

TestAB: PROC ~ TRUSTED {

WaitForReq: ENTRY SAFE PROC [lp: LockPtr] RETURNS [continue: BOOL] ~ CHECKED {

ENABLE UNWIND => NULL;

IF NOT fkd.ready[a] THEN {WAIT fkd.change; LOOP};

IF NOT fkd.ready[b] THEN {WAIT fkd.change; LOOP};

RETURN [fkd.val[a].found OR fkd.val[b].found];

ENDLOOP;

};

Satisfy: ENTRY SAFE PROC [lp: LockPtr] ~ CHECKED {

ENABLE UNWIND => NULL;

fkd.ready[a] ← fkd.ready[b] ← FALSE;

BROADCAST fkd.change;

RETURN};

UNTIL fkd.done DO

IF NOT WaitForReq[@fkd.lock]

THEN fkd.done ← TRUE

ELSE {IF (fkd.done ← Test[fkd.val[a], fkd.val[b]]) THEN pf ← [TRUE, fkd.val[a], fkd.val[b]]};

Satisfy[@fkd.lock];

ENDLOOP;

};

TRUSTED {

Process.EnableAborts[@fkd.change];

SharedErrors.Fork[LIST[GenA, GenB, TestAB]]};

RETURN};

ForkScan: PROC [fkd: Forked, which: Which, sets: SetPair, ro: RelOrder] ~ TRUSTED {

Mediate: SAFE PROC [val: Pair] RETURNS [pass: BOOL ← FALSE] ~ TRUSTED {

WithLock: ENTRY PROC [lp: LockPtr] ~ TRUSTED {

ENABLE UNWIND => NULL;

fkd.val[which].it ← val;

fkd.ready[which] ← TRUE;

BROADCAST fkd.change;

UNTIL NOT fkd.ready[which] DO WAIT fkd.change ENDLOOP;

pass ← fkd.done;

RETURN};

WithLock[@fkd.lock];

RETURN};

Finish: ENTRY PROC [lp: LockPtr] ~ TRUSTED {

ENABLE UNWIND => NULL;

fkd.val[which] ← noMaybePair;

UNTIL fkd.done DO

fkd.ready[which] ← TRUE;

BROADCAST fkd.change;

UNTIL NOT fkd.ready[which] DO WAIT fkd.change ENDLOOP;

ENDLOOP;

RETURN};

[] ← fkd.set[which].ScanRestriction[sets, Mediate, ro];

Finish[@fkd.lock];

RETURN};

ScanImage: PUBLIC PROC [br: BiRel, set: Set, Test: Sets.Tester, dir: Direction ← leftToRight, ro: Sets.RelOrder ← no] RETURNS [MaybePair] ~ {

dest: Side ~ Dest[dir];

Pass: PROC [pair: Pair] RETURNS [BOOL] ~ {RETURN Test[pair[dest]]};

RETURN br.ScanHalfRestriction[set, Pass, Source[dir], ConsRelOrder[dest, ro]]};

Has: PUBLIC PROC [br, other: BiRel, want: BoolPair] RETURNS [hsp: HadSetPair ← []] ~ {

spaces: SpacePair ~ br.Spaces[];

Per: PROC [pair: Pair] RETURNS [BOOL] ~ {

IF want[leftToRight] THEN {

mv: MaybeValue ~ br.Apply[pair[left], leftToRight];

SELECT TRUE FROM

NOT mv.found => hsp[leftToRight][none] ← TRUE;

spaces[right].SEqual[pair[right], mv.it] => hsp[leftToRight][same] ← TRUE;

ENDCASE => hsp[leftToRight][different] ← TRUE};

IF want[rightToLeft] THEN {

mv: MaybeValue ~ br.Apply[pair[right], rightToLeft];

SELECT TRUE FROM

NOT mv.found => hsp[rightToLeft][none] ← TRUE;

spaces[left].SEqual[pair[left], mv.it] => hsp[rightToLeft][same] ← TRUE;

ENDCASE => hsp[rightToLeft][different] ← TRUE};

RETURN [FALSE]};

IF want#ALL[FALSE] AND other.Scan[Per].found THEN ERROR;

RETURN};

AddAA: PUBLIC PROC [br: BiRel, left, right: REF ANY, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[[a[left]], [a[right]]], if]};

AddIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[[i[left]], [a[right]]], if]};

AddII: PUBLIC PROC [br: BiRel, left, right: INT, if: IfHadPair ← alwaysAdd] RETURNS [had: HadPair]

~ {RETURN br.AddPair[[[i[left]], [i[right]]], if]};

AddNewPair: PUBLIC PROC [br: BiRel, pair: Pair] ~ {

had: HadPair ~ br.AddPair[pair, addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewAA: PUBLIC PROC [br: BiRel, left, right: REF ANY] ~ {

had: HadPair ~ br.AddPair[[[a[left]], [a[right]]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY] ~ {

had: HadPair ~ br.AddPair[[[i[left]], [a[right]]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

AddNewII: PUBLIC PROC [br: BiRel, left, right: INT] ~ {

had: HadPair ~ br.AddPair[[[i[left]], [i[right]]], addIfNew];

IF br.Functional[][leftToRight] AND had[leftToRight]#none THEN ERROR;

IF br.Functional[][rightToLeft] AND had[rightToLeft]#none THEN ERROR;

RETURN};

RemAA: PUBLIC PROC [br: BiRel, left, right: REF ANY] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[[a[left]], [a[right]]]]};

RemIA: PUBLIC PROC [br: BiRel, left: INT, right: REF ANY] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[[i[left]], [a[right]]]]};

RemII: PUBLIC PROC [br: BiRel, left, right: INT] RETURNS [had: HadPair]

~ {RETURN br.RemPair[[[i[left]], [i[right]]]]};

refNilSets: REF ANY ~ FromSets[ALL[nilSet]];

AddComposite: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $composite, atom: op];

};

AddAlways: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $always, atom: op];

};

AddArgless: PROC [op: ATOM] ~ {

Atom.PutProp[prop: kindKey, val: $argless, atom: op];

};

AddArgfull: PROC [op: ATOM, arg1, arg2: ArgType ← None] ~ {

Atom.PutProp[prop: kindKey, val: NEW [ArgTyping ← [arg1, arg2]], atom: op];

};

Start: PROC ~ {

AddComposite[$Mapping];

AddComposite[$Enumerate];

AddComposite[$Scan];

AddComposite[$EnumerateImage];

AddComposite[$ScanImage];

AddComposite[$EnumerateMapping];

AddComposite[$ScanMapping];

AddComposite[$EnumerateHalfRestriction];

AddComposite[$ScanHalfRestriction];

AddComposite[$APair];

AddComposite[$Pop];

AddComposite[$Next];

AddComposite[$Prev];

AddComposite[$SkipTo];

AddComposite[$Lookup];

AddComposite[$Size];

AddComposite[$Empty];

AddComposite[$ImageSize];

AddComposite[$MappingSize];

AddComposite[$AddNewPair];

AddComposite[$AddNewSet];

AddComposite[$Erase];

AddComposite[$GetIntDom];

AddArgless[$AsSet];

AddArgless[$HasPair];

AddArgfull[$Image, $Set, $Dir];

AddArgfull[$Apply, $Dir];

AddArgfull[$ScanRestriction, $SetPair, $RelOrder];

AddArgfull[$GetOne, $remove, $RelOrder];

AddArgfull[$Get3, $RelOrderFN, $Want3];

AddArgfull[$RestrictionSize, $SetPair, $limit];

AddArgfull[$IsDense, $When, $Side];

AddArgfull[$SideFixed, $Side];

AddArgfull[$GetBounds, $EndBools, $RelOrderFN];

AddArgless[$Copy];

AddArgless[$Insulate];

AddArgless[$ValueOf];

AddArgless[$Freeze];

AddArgless[$Thaw];

AddArgless[$AddPair];

AddArgfull[$AddSet, $BiRel];

AddArgfull[$Swap, $Side];

AddArgless[$RemPair];

AddArgfull[$RemSet, $BiRel];

AddArgless[$Delete];

AddArgfull[$DeleteSet, $Set, $Side];

AddArgless[$QuaIntInterval];

AddAlways[$MutabilityOf];

AddAlways[$Spaces];

AddArgfull[$SetOn, $Side];

AddArgfull[$CurSetOn, $Side];

AddAlways[$Functional];

AddAlways[$PreservePair];

RETURN};

FOR l2r: BOOL IN BOOL DO FOR r2l: BOOL IN BOOL DO FOR mut: Mutability IN Mutability DO

classes[l2r][r2l][mut] ← CreateClass[

cp: [

Primitive: PrefixPrimitive,

AsSet: PrefixAsSet,

HasPair: PrefixHasPair,

Image: PrefixImage,

Apply: PrefixApply,

ScanRestriction: PrefixScanRestriction,

GetOne: PrefixGetOne,

Get3: PrefixGet3,

Index: PrefixIndex,

RestrictionSize: PrefixRestrictionSize,

GetBounds: PrefixGetBounds,

Copy: PrefixCopy,

Insulate: IF mut=variable THEN PrefixInsulate ELSE NIL,

ValueOf: IF mut#constant THEN PrefixValueOf ELSE NIL,

Freeze: IF mut=variable THEN PrefixFreeze ELSE NIL,

Thaw: IF mut=variable THEN PrefixThaw ELSE NIL,

SetOn: PrefixSetOn,

CurSetOn: PrefixCurSetOn,

AddPair: IF mut=variable THEN PrefixAddPair ELSE NIL,

AddSet: IF mut=variable THEN PrefixAddSet ELSE NIL,

Swap: IF mut=variable THEN PrefixSwap ELSE NIL,

RemPair: IF mut=variable THEN PrefixRemPair ELSE NIL,

RemSet: IF mut=variable THEN PrefixRemSet ELSE NIL,

Delete: IF mut=variable THEN PrefixDelete ELSE NIL,

DeleteSet: IF mut=variable THEN PrefixDeleteSet ELSE NIL,

ReplaceMe: IF mut=variable THEN PrefixReplaceMe ELSE NIL,

ShiftAndClipMe: IF mut=variable THEN PrefixShiftAndClipMe ELSE NIL,

Spaces: PrefixSpaces,

IsDense: PrefixIsDense,

SideFixed: PrefixSideFixed,

functional: [l2r, r2l],

mutability: mut]],

dirable: ALL[TRUE]

];

ENDLOOP ENDLOOP ENDLOOP;

Start[];

END.