SetsImpl.Mesa
Last tweaked by Mike Spreitzer on December 14, 1987 1:45:53 pm PST
DIRECTORY AbSets, Atom, IntStuff, List, Process, Rope, SetBasics, SharedErrors;
SetsImpl: CEDAR MONITOR
LOCKS lp USING lp: LockPtr
IMPORTS AbSets, Atom, IntStuff, List, Process, Rope, SetBasics, SharedErrors
EXPORTS SetBasics, AbSets
=
BEGIN OPEN IntStuff, SetBasics, Sets:AbSets, Sets;
LockPtr: TYPE ~ LONG POINTER TO MONITORLOCK;
Error: PUBLIC ERROR [msg: ROPE, args: LOV] ~ CODE;
Cant: PUBLIC ERROR [set: Set] ~ CODE;
notConstant: PUBLIC ROPE ~ R["%g not constant"];
notVariable: PUBLIC ROPE ~ R["%g not variable"];
writeable: PUBLIC ROPE ~ R["%g not unwriteable"];
frozen: PUBLIC ROPE ~ R["%g frozen"];
unfrozen: PUBLIC ROPE ~ R["%g unfrozen"];
notASingleton: PUBLIC ROPE ~ R["%g not a singleton"];
narrowFault: PUBLIC ROPE ~ R["%g not in range"];
notFound: PUBLIC ROPE ~ R["no appropriate value"];
badSet: PUBLIC Set ← [NIL, [a[$bad]]];
refFullInterval: PUBLIC RefInterval ~ NEW [Interval ← []];
refAllInts: PUBLIC RefInterval ~ NEW [Interval ← [[i[INT.FIRST]], [i[INT.LAST]]]];
kindKey: ATOM ~ $SetsImplKind;
provisionKey: ATOM ~ $SetsImplProvision;
relableKey: ATOM ~ $SetsImplRelable;
Cons: PUBLIC PROC [class: SetClass, data: Value] RETURNS [Set]
~ {RETURN [[class, data]]};
Proc: TYPE ~ PROC ANY RETURNS ANY;
CreateClass: PUBLIC PROC [cp: SetClassPrivate, relable: Relable ← [TRUE, FALSE, FALSE]] RETURNS [class: SetClass] ~ {
provs: Atom.PropList ← NARROW[List.Assoc[provisionKey, cp.other]];
Sp: PROC [op: ATOM, proc: Proc] RETURNS [def: BOOL] ~ {
provs ← List.PutAssoc[op, IF (def ← proc=NIL) THEN $Default ELSE $Primitive, provs]};
{OPEN cp;
IF Sp[$HasMember, HasMember] THEN HasMember ← DefaultHasMember;
IF Sp[$Scan, Scan] THEN Scan ← DefaultScan;
IF Sp[$TheElt, TheElt] THEN TheElt ← DefaultTheElt;
IF Sp[$GetOne, GetOne] THEN GetOne ← DefaultGetOne;
IF Sp[$Get3, Get3] THEN Get3 ← DefaultGet3;
IF Sp[$Size, Size] THEN Size ← DefaultSize;
IF Sp[$IsDense, IsDense] THEN IsDense ← DefaultIsDense;
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[$AddSet, AddSet] THEN AddSet ← DefaultAddSet;
IF Sp[$RemSet, RemSet] THEN RemSet ← DefaultRemSet;
IF Sp[$QuaBiRel, QuaBiRel] THEN QuaBiRel ← DefaultQuaBiRel;
IF Sp[$QuaIntInterval, QuaIntInterval] THEN QuaIntInterval ← DefaultQuaIntInterval;
};
cp.other ← List.PutAssoc[provisionKey, provs, cp.other];
cp.other ← List.PutAssoc[relableKey, NEW [Relable ← relable], cp.other];
class ← NEW [SetClassPrivate ← cp];
RETURN};
Primitive: PROC [set: Set, op: ATOM, arg1, arg2: REF ANYNIL] 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--;
SELECT kind FROM
$class, $classO, $classRO, $classL, $classS, $classW, $classW2, $classW3 => NULL;
$classA => RETURN [TRUE];
ENDCASE => ERROR;
IF set.class.Primitive#NIL THEN SELECT set.class.Primitive[set, op, arg1, arg2] FROM
yes => RETURN [TRUE];
no => RETURN [FALSE];
pass => NULL;
ENDCASE => ERROR;
{provs: Atom.PropList ~ NARROW[List.Assoc[provisionKey, set.class.other]];
prov: REF ANY ~ List.Assoc[op, provs];
RETURN [SELECT prov FROM
$Default => FALSE,
$Primitive => SELECT kind FROM
$class, $classL, $classS, $classW, $classW2, $classW3 => TRUE,
$classO => (NARROW[List.Assoc[relableKey, set.class.other], REF Relable])[ToRO[arg1]],
$classRO => (set.MutabilityOf[]#variable AND ToBool[arg1]) OR (NARROW[List.Assoc[relableKey, set.class.other], REF Relable])[ToRO[arg2]],
ENDCASE => ERROR,
ENDCASE => ERROR];
}};
QualityOf: PUBLIC PROC [set: Set, op: ATOM, arg1, arg2: REF ANYNIL] RETURNS [ImplQuality] ~ {
SELECT Atom.GetProp[op, kindKey] FROM
$class, $classO, $classRO, $classL, $classS, $classW, $classW2, $classW3 => NULL;
$classA => RETURN [primitive];
$composite => SELECT op FROM
$Enumerate => RETURN set.QualityOf[$Scan, arg1, arg2];
$AnElt => RETURN set.QualityOf[$GetOne, $FALSE, arg1];
$Pop => RETURN set.QualityOf[$GetOne, $TRUE, arg1];
$First => RETURN set.QualityOf[$GetOne, $FALSE, $fwd];
$Last => RETURN set.QualityOf[$GetOne, $FALSE, $bwd];
$Next => RETURN set.QualityOf[$Get3, $FFT];
$Prev => RETURN set.QualityOf[$Get3, $TFF];
$Empty => RETURN set.QualityOf[$Size, refOne];
$AddElt => RETURN set.QualityOf[$AddSet, FakeRefSingleton[set.SpaceOf]];
$RemElt => RETURN set.QualityOf[$RemSet, FakeRefSingleton[set.SpaceOf]];
$Erase => RETURN set.QualityOf[$RemoteSet, set.Refify];
ENDCASE => ERROR;
ENDCASE => ERROR;
IF Primitive[set, op, arg1, arg2] THEN RETURN [primitive];
SELECT op FROM
$HasMember => RETURN [QMin[set.QualityOf[$Scan], poorDefault]];
$Scan => {ro: RelOrder ~ ToRO[arg1];
RETURN [IF ro#no AND Primitive[set, $Scan] THEN poorDefault ELSE cant]};
$TheElt => RETURN [goodDefault];
$GetOne => {remove: BOOL ~ ToBool[arg1];
ro: RelOrder ~ ToRO[arg2];
IF remove AND set.MutabilityOf[]#variable THEN RETURN [goodDefault];
RETURN QMin[QMin[goodDefault,
IF ro=no THEN set.QualityOf[$Scan] ELSE set.QualityOf[$GetBounds, FromEB[[min: ro=fwd, max: ro=bwd]]]],
IF remove THEN set.QualityOf[$RemElt] ELSE goodDefault]};
$Get3 => {
fq: ImplQuality ~ set.QualityOf[$Scan, $fwd];
bq: ImplQuality ~ set.QualityOf[$Scan, $bwd];
nq: ImplQuality ~ set.QualityOf[$Scan, $no];
max: ImplQuality ~ QMax[nq, QMax[fq, bq]];
RETURN QMin[
set.QualityOf[$Scan, IF bq=max AND fq<max THEN $bwd ELSE IF fq=max THEN $fwd ELSE $no],
poorDefault]};
$Size => {limit: EINT ~ ToEI[arg1]^;
RETURN QMin[
set.QualityOf[$Scan],
IF limit.Compare[two]<=equal THEN goodDefault ELSE poorDefault]};
$IsDense => {when: When ~ ToWhen[arg1];
IF when=always AND set.MutabilityOf#constant THEN RETURN [poorDefault];
{space: Space ~ set.SpaceOf[];
pureInts: BOOL ~ space = ints;
asInts: BOOL ~ pureInts OR space=basic;
IF set.GoodImpl[$GetBounds] THEN {
bounds: MaybeInterval ~ set.GetBounds[];
IF NOT bounds.found THEN RETURN [goodDefault];
IF bounds.it[min]#noValue AND bounds.it[max]#noValue AND space.SEqual[bounds.it[min], bounds.it[max]] THEN RETURN [goodDefault];
IF asInts AND Primitive[set, $Size] THEN {
WITH bounds.it[min] SELECT FROM
x: IntValue => NULL;
x: NotAValue => IF NOT pureInts THEN GOTO Givup;
ENDCASE => GOTO Givup;
WITH bounds.it[max] SELECT FROM
x: IntValue => NULL;
x: NotAValue => IF NOT pureInts THEN GOTO Givup;
ENDCASE => GOTO Givup;
RETURN [goodDefault];
EXITS Givup => op ← op
};
};
IF NOT pureInts THEN RETURN [poorDefault];
RETURN QMin[poorDefault, QMax[
set.QualityOf[$Scan, $fwd],
set.QualityOf[$Scan, $bwd] ]]}};
$GetBounds => {want: EndBools ~ ToEB[arg1];
IF want=ALL[FALSE] THEN RETURN [goodDefault];
IF ((NOT want[min]) OR Primitive[set, $GetOne, $FALSE, $fwd]) AND ((NOT want[max]) OR Primitive[set, $GetOne, $FALSE, $bwd]) THEN RETURN [goodDefault];
RETURN [IF set.Can[$Scan] THEN poorDefault ELSE cant]};
$Copy => RETURN [cant];
$Insulate => RETURN [goodDefault];
$ValueOf => RETURN [IF set.MutabilityOf#constant THEN QMin[goodDefault, QMin[set.QualityOf[$Copy], set.QualityOf[$Freeze]]] ELSE goodDefault];
$Freeze, $Thaw, $addSet, $RemSet => RETURN [IF set.MutabilityOf#variable THEN goodDefault ELSE cant];
$QuaBiRel => RETURN [goodDefault];
$QuaIntInterval => {
space: Space ~ set.SpaceOf[];
pureInts: BOOL ~ space = ints;
asInts: BOOL ~ pureInts OR space=basic;
IF NOT asInts THEN RETURN [goodDefault];
IF set.GoodImpl[$GetBounds] THEN {
bounds: MaybeInterval ~ set.GetBounds[];
min, max: INT;
IF NOT bounds.found THEN RETURN [goodDefault];
WITH bounds.it[min] SELECT FROM
x: IntValue => min ← x.i;
x: NotAValue => IF pureInts THEN min←INT.FIRST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
WITH bounds.it[max] SELECT FROM
x: IntValue => max ← x.i;
x: NotAValue => IF pureInts THEN max←INT.LAST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
IF min=max OR (max>INT.FIRST AND min=max-1) OR (Primitive[set, $Size] AND set.Size[] = ISub[max, min].Succ) THEN RETURN [goodDefault];
EXITS Givup => op ← op
};
RETURN QMin[set.QualityOf[$Scan], poorDefault]};
$SpaceOf => ERROR;
ENDCASE => ERROR;
};
DefaultHasMember: PROC [set: Set, elt: Value] RETURNS [BOOL] ~ {
space: Space ~ set.SpaceOf[];
Test: PROC [val: Value] RETURNS [BOOL] ~ {RETURN space.SEqual[elt, val]};
RETURN [set.Scan[Test].found]};
Enumerate: PUBLIC PROC [set: Set, Consumer: PROC [Value], ro: RelOrder ← no] ~ {
Test: PROC [val: Value] RETURNS [BOOL] ~ {Consumer[val]; RETURN [FALSE]};
IF set.Scan[Test, ro].found THEN ERROR;
RETURN};
EnumA: PUBLIC PROC [set: Set, Consumer: PROC [REF ANY], ro: RelOrder ← no] ~ {
Test: PROC [val: Value] RETURNS [BOOL] ~ {Consumer[val.VA]; RETURN [FALSE]};
IF set.Scan[Test, ro].found THEN ERROR;
RETURN};
EnumI: PUBLIC PROC [set: Set, Consumer: PROC [INT], ro: RelOrder ← no] ~ {
Test: PROC [val: Value] RETURNS [BOOL] ~ {Consumer[val.VI]; RETURN [FALSE]};
IF set.Scan[Test, ro].found THEN ERROR;
RETURN};
Forked: TYPE ~ REF ForkedPrivate;
ForkedPrivate: TYPE ~ RECORD [
set: ARRAY Which OF Set,
ready: ARRAY Which OF BOOLALL[FALSE],
done: BOOLFALSE,
change: CONDITION ← [timeout: Process.SecondsToTicks[10]],
val: ARRAY Which OF MaybeValue ← ALL[[TRUE, noValue]],
lock: MONITORLOCK ← []
];
InterleavedProduce: PUBLIC PROC [a, b: Set, Consume: InterleavedConsumer, roA, roB: RelOrder ← no] RETURNS [ans: MaybeValue ← noMaybe] ~ {
fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b]]];
GenA: PROC ~ {ForkScan[fkd, a, roA]};
GenB: PROC ~ {ForkScan[fkd, b, roB]};
TestAB: PROC ~ TRUSTED {
Produce: PROC [w: Which] RETURNS [MaybeValue] ~ TRUSTED {
Wait: ENTRY SAFE PROC [lp: LockPtr] RETURNS [MaybeValue] ~ 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};
ParallelScan: PUBLIC PROC [a, b: Set, Test: ParallelTester, roA, roB: RelOrder ← no] RETURNS [pf: ParallelFind ← [FALSE, noMaybe, noMaybe]] ~ {
fkd: Forked ~ NEW [ForkedPrivate ← [set: [a, b] ]];
GenA: PROC ~ {ForkScan[fkd, a, roA]};
GenB: PROC ~ {ForkScan[fkd, b, roB]};
TestAB: PROC ~ TRUSTED {
WaitForReq: ENTRY SAFE PROC [lp: LockPtr] RETURNS [continue: BOOL] ~ CHECKED {
ENABLE UNWIND => NULL;
DO
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, ro: RelOrder] ~ TRUSTED {
Mediate: SAFE PROC [val: Value] RETURNS [pass: BOOLFALSE] ~ 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] ← noMaybe;
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].Scan[Mediate, ro];
Finish[@fkd.lock];
RETURN};
DefaultScan: PUBLIC PROC [set: Set, Test: Tester, ro: RelOrder] RETURNS [MaybeValue] ~ {
rro: RelOrder ~ ReverseRelOrder[ro];
IF ro=no THEN set.Cant[];
IF Primitive[set, $Scan, FromRO[rro]] THEN {
elts: LOVNIL;
Addit: PROC [x: Value] ~ {elts ← CONS[x, elts]};
set.Enumerate[Addit, rro];
FOR elts ← elts, elts.rest WHILE elts#NIL DO IF Test[elts.first] THEN RETURN [[TRUE, elts.first]] ENDLOOP;
RETURN [noMaybe];
}
ELSE IF Primitive[set, $Scan, $no] THEN {
space: Space ~ set.SpaceOf[];
elts: LORANIL;
Addit: PROC [x: Value] ~ {elts ← CONS[NEW [Value ← x], elts]};
Compare: PROC [ref1, ref2: REF ANY] RETURNS [Comparison] ~ {
rv1: REF Value ~ NARROW[ref1];
rv2: REF Value ~ NARROW[ref2];
RETURN space.SCompare[rv1^, rv2^]};
set.Enumerate[Addit, no];
elts ← List.Sort[elts, Compare];
FOR elts ← elts, elts.rest WHILE elts#NIL DO
rv: REF Value ~ NARROW[elts.first];
IF Test[rv^] THEN RETURN [[TRUE, rv^]];
ENDLOOP;
RETURN [noMaybe];
}
ELSE set.Cant[];
};
DefaultTheElt: PROC [set: Set] RETURNS [Value] ~ {
n: NATURAL ← 0;
Test: PROC [val: Value] RETURNS [BOOL] ~ {
IF (n ← n + 1) > 1 THEN set.Complain[notASingleton];
RETURN [FALSE]};
mv: MaybeValue ← set.Scan[Test];
IF n=0 THEN set.Complain[notASingleton];
RETURN [mv.it]};
DefaultGetOne: PUBLIC PROC [set: Set, remove: BOOL, ro: RelOrder] RETURNS [MaybeValue] ~ {
Getit: PROC RETURNS [MaybeValue] ~ {
IF ro=no THEN RETURN set.Scan[AcceptAny, ro]
ELSE {
bounds: MaybeInterval ~ set.GetBounds[want: [min: ro=fwd, max: ro=bwd]];
v: Value ~ IF ro=fwd THEN bounds.it[min] ELSE bounds.it[max];
IF bounds.found THEN RETURN [[TRUE, IF v.kind#no THEN v ELSE set.Cant[]]];
RETURN [noMaybe]}};
IF remove AND set.MutabilityOf[]#variable THEN set.Complain[notVariable];
{mv: MaybeValue ~ Getit[];
IF mv.found AND remove AND NOT set.RemElt[mv.it] THEN ERROR;
RETURN [mv]}};
DefaultGet3: PROC [set: Set, elt: Value, want: TripleBool] RETURNS [TripleMaybeValue] ~ {
fq: ImplQuality ~ set.QualityOf[$Scan, $fwd];
bq: ImplQuality ~ set.QualityOf[$Scan, $bwd];
nq: ImplQuality ~ set.QualityOf[$Scan, $no];
max: ImplQuality ~ QMax[nq, QMax[fq, bq]];
prev, same, next: MaybeValue ← noMaybe;
space: Space ~ set.SpaceOf[];
IF fq=max OR bq=max THEN {
bwd: BOOL ~ bq=max AND fq<max;
take: BOOLFALSE;
Test: PROC [val: Value] RETURNS [pass: BOOLFALSE] ~ {
IF space.SEqual[val, elt] THEN same ← [take ← TRUE, elt]
ELSE IF take THEN pass ← TRUE
ELSE prev ← [TRUE, val];
};
next ← set.Scan[Test, IF bwd THEN bwd ELSE fwd];
IF bwd THEN RETURN [[next, same, prev]];
RETURN [[prev, same, next]]}
ELSE {
foundSame: BOOLFALSE;
Test: PROC [val: Value] RETURNS [pass: BOOLFALSE] ~ {
SELECT space.SCompare[val, elt] FROM
less => IF (NOT prev.found) OR space.SCompare[val, prev.it]=greater THEN prev ← [TRUE, val];
equal => foundSame ← TRUE;
greater => IF (NOT next.found) OR space.SCompare[val, next.it]=less THEN next ← [TRUE, val];
ENDCASE => ERROR;
RETURN};
IF set.Scan[Test, no].found THEN ERROR;
RETURN [[prev, IF foundSame THEN [TRUE, elt] ELSE noMaybe, next]]};
};
DefaultSize: PUBLIC PROC [set: Set, limit: EINT] RETURNS [size: EINT ← zero] ~ {
Pass: PROC [val: Value] RETURNS [pass: BOOL]
~ TRUSTED {pass ← limit.Compare[size ← size.Succ[]] <= equal; RETURN};
[] ← set.Scan[Pass];
RETURN};
DefaultIsDense: PUBLIC PROC [set: Set, when: When] RETURNS [BOOL] ~ {
IF when=always AND set.MutabilityOf#constant THEN RETURN [FALSE];
{space: Space ~ set.SpaceOf[];
pureInts: BOOL ~ space = ints;
asInts: BOOL ~ pureInts OR space=basic;
IF set.GoodImpl[$GetBounds] THEN {
bounds: MaybeInterval ~ set.GetBounds[];
IF NOT bounds.found THEN RETURN [TRUE];
IF bounds.it[min]#noValue AND bounds.it[max]#noValue AND space.SEqual[bounds.it[min], bounds.it[max]] THEN RETURN [TRUE];
IF asInts AND Primitive[set, $Size] THEN {
min, max: INT;
WITH bounds.it[min] SELECT FROM
x: IntValue => min ← x.i;
x: NotAValue => IF pureInts THEN min←INT.FIRST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
WITH bounds.it[max] SELECT FROM
x: IntValue => max ← x.i;
x: NotAValue => IF pureInts THEN max←INT.LAST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
RETURN [set.Size[] = ISub[max, min].Succ];
EXITS Givup => when ← when
};
};
IF NOT asInts THEN RETURN [FALSE];
{fq: ImplQuality ~ set.QualityOf[$Scan, $fwd];
bq: ImplQuality ~ set.QualityOf[$Scan, $bwd];
bwd: BOOL ~ bq > fq;
first: BOOLTRUE;
last: INT ← 0;
Test: PROC [val: Value] RETURNS [pass: BOOL] ~ TRUSTED {
WITH val SELECT FROM
no => ERROR;
a => pass ← TRUE;
i => {pass ← IF first THEN first ← FALSE ELSE IF bwd THEN i+1 # last ELSE i-1 # last; last ← i};
ENDCASE => ERROR};
stopped: BOOL ← set.Scan[Test, IF bwd THEN bwd ELSE fwd].found;
RETURN [NOT stopped]}}};
DefaultGetBounds: PUBLIC PROC [set: Set, want: EndBools] RETURNS [bounds: MaybeInterval ← [TRUE, []]] ~ {
IF want=ALL[FALSE] THEN RETURN;
IF ((NOT want[min]) OR Primitive[set, $GetOne, $FALSE, $fwd]) AND ((NOT want[max]) OR Primitive[set, $GetOne, $FALSE, $bwd]) THEN TRUSTED {
IF want[min] THEN {mv: MaybeValue ~ set.AnElt[fwd];
IF NOT mv.found THEN RETURN [[FALSE, []]];
bounds.it[min] ← mv.it};
IF want[max] THEN {mv: MaybeValue ~ set.AnElt[bwd];
IF NOT mv.found THEN {IF want[min] THEN ERROR ELSE RETURN [[FALSE, []]]};
bounds.it[max] ← mv.it};
RETURN};
{space: Space ~ set.SpaceOf[];
fq: ImplQuality ~ set.QualityOf[$Scan, $fwd];
bq: ImplQuality ~ set.QualityOf[$Scan, $bwd];
nq: ImplQuality ~ set.QualityOf[$Scan, $no];
max: ImplQuality ~ QMax[nq, QMax[fq, bq]];
IF fq=max OR bq=max THEN {
bwd: BOOL ~ fq < bq;
quitEarly: BOOL ~ NOT (IF bwd THEN want[min] ELSE want[max]);
first: BOOLTRUE;
Test: PROC [val: Value] RETURNS [BOOL] ~ TRUSTED {
IF first THEN {first ← FALSE; bounds.it[min] ← val};
bounds.it[max] ← val;
RETURN [quitEarly]};
[] ← set.Scan[Test, IF bwd THEN bwd ELSE fwd];
IF first THEN RETURN [[FALSE, []]];
IF bwd THEN RETURN [[TRUE, [bounds.it[max], bounds.it[min]]]];
RETURN}
ELSE {
first: BOOLTRUE;
Test: PROC [val: Value] RETURNS [BOOL] ~ TRUSTED {
IF first THEN {first ← FALSE; bounds.it ← [val, val]} ELSE {
IF want[min] THEN bounds.it[min] ← space.SMin[bounds.it[min], val];
IF want[max] THEN bounds.it[max] ← space.SMax[bounds.it[max], val]};
RETURN [FALSE]};
IF set.Scan[Test].found THEN ERROR;
IF first THEN RETURN [[FALSE, []]];
RETURN};
}};
DefaultCopy: PROC [set: Set] RETURNS [VarSet] ~ {set.Cant[]};
DefaultValueOf: PROC [set: Set] RETURNS [ConstSet]
~ {IF set.MutabilityOf#constant THEN RETURN set.Copy.Freeze[] ELSE RETURN set.AsConst[]};
DefaultFreeze: PROC [set: Set] RETURNS [ConstSet] ~ {
IF set.MutabilityOf#variable THEN set.Complain[notVariable] ELSE set.Cant[]; ERROR};
DefaultThaw: PROC [set: Set] ~ {
IF set.MutabilityOf#variable THEN set.Complain[notVariable] ELSE set.Cant[]};
NAddElt: PUBLIC PROC [set: Set, elt: Value] RETURNS [new: BOOL]
~ {RETURN set.AddElt[elt]};
DefaultAddSet: PROC [set, other: Set] RETURNS [new: SomeAll ← []] ~ {
IF set.MutabilityOf#variable THEN set.Complain[notVariable] ELSE set.Cant[]};
DefaultRemSet: PROC [set, other: Set] RETURNS [had: SomeAll ← []] ~ {
IF set.MutabilityOf#variable THEN set.Complain[notVariable] ELSE set.Cant[]};
DefaultQuaIntInterval: PUBLIC PROC [set: Set] RETURNS [MaybeIntInterval] ~ {
space: Space ~ set.SpaceOf[];
pureInts: BOOL ~ space = ints;
asInts: BOOL ~ pureInts OR space=basic;
min: INTINT.LAST;
max: INTINT.FIRST;
IF NOT asInts THEN RETURN [[FALSE, []]];
IF set.GoodImpl[$GetBounds] THEN {
bounds: MaybeInterval ~ set.GetBounds[];
IF NOT bounds.found THEN RETURN [[TRUE, anEmptyInterval]];
WITH bounds.it[min] SELECT FROM
x: IntValue => min ← x.i;
x: NotAValue => IF pureInts THEN min←INT.FIRST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
WITH bounds.it[max] SELECT FROM
x: IntValue => max ← x.i;
x: NotAValue => IF pureInts THEN max←INT.LAST ELSE GOTO Givup;
ENDCASE => GOTO Givup;
IF min=max OR (max>INT.FIRST AND min=max-1) OR (Primitive[set, $Size] AND set.Size[] = ISub[max, min].Succ) THEN RETURN [[TRUE, [min, max]]];
EXITS Givup => min ← min
};
{n: EINT ← zero;
Per: PROC [v: Value] RETURNS [BOOL] ~ TRUSTED {
WITH v SELECT FROM
x: IntValue => {min ← MIN[min, x.i]; max ← MAX[max, x.i]; n ← n.Succ};
ENDCASE => RETURN [TRUE];
RETURN [FALSE]};
IF set.Scan[Per].found THEN RETURN [[FALSE, []]];
RETURN [[n = ISub[max, min].Succ, [min, max]]]}};
Equal: PUBLIC PROC [a, b: Set] RETURNS [BOOL] ~ {
RETURN [Compare[a, b] = equal]};
Hash: PUBLIC PROC [set: Set] RETURNS [hash: CARDINAL ← 0] ~ {
space: Space ~ set.SpaceOf[];
Per: PROC [v: Value] RETURNS [BOOL] ~ {
hash ← hash + space.SHash[v];
RETURN [FALSE]};
[] ← set.Scan[Per];
RETURN};
Compare: PUBLIC PROC [a, b: Set] RETURNS [c: Comparison ← equal] ~ {
space: Space ~ a.SpaceOf[];
Test: PROC [a, b: MaybeValue] RETURNS [BOOL] ~ {
IF a.found < b.found THEN {c ← less; RETURN [TRUE]};
IF a.found > b.found THEN {c ← greater; RETURN [TRUE]};
c ← space.SCompare[a.it, b.it];
RETURN [c#equal]};
IF space # b.SpaceOf[] THEN ERROR Cant[a];
[] ← ParallelScan[a, b, Test, fwd, fwd];
RETURN};
CreateSetSpace: PUBLIC PROC [eltSpace: Space] RETURNS [Space] ~ {
RETURN [NEW [SpacePrivate ← [Contains: SetsContains, Equal: SetsEqual, Hash: SetsHash, Compare: SetsCompare, name: Rope.Cat["sets of ", eltSpace.name], data: eltSpace]]]};
QuaSetSpace: PUBLIC PROC [ss: Space] RETURNS [found: BOOL, eltSpace: Space] ~ {
IF ss.Compare = SetsCompare THEN RETURN [TRUE, NARROW[ss.data]];
RETURN [FALSE, NIL]};
SetsContains: PROC [data: REF ANY, v: Value] RETURNS [BOOL] ~ TRUSTED {
es: Space ~ NARROW[data];
RETURN [WITH v SELECT FROM
a => WITH a SELECT FROM
rs: RefSet => rs^.SpaceOf[]=es,
ENDCASE => FALSE,
i => FALSE,
no => ERROR,
ENDCASE => ERROR]};
SetsHash: PROC [data: REF ANY, v: Value] RETURNS [CARDINAL] ~ {
es: Space ~ NARROW[data];
s: RefSet ~ NARROW[v.VA];
IF s^.SpaceOf[]#es THEN ERROR;
RETURN s^.Hash};
SetsEqual: PROC [data: REF ANY, v1, v2: Value] RETURNS [BOOL] ~ {
es: Space ~ NARROW[data];
s1: RefSet ~ NARROW[v1.VA];
s2: RefSet ~ NARROW[v2.VA];
IF s1^.SpaceOf[]#es THEN ERROR;
IF s2^.SpaceOf[]#es THEN ERROR;
RETURN s1^.Equal[s2^]};
SetsCompare: PROC [data: REF ANY, v1, v2: Value] RETURNS [Comparison] ~ {
es: Space ~ NARROW[data];
s1: RefSet ~ NARROW[v1.VA];
s2: RefSet ~ NARROW[v2.VA];
IF s1^.SpaceOf[]#es THEN ERROR;
IF s2^.SpaceOf[]#es THEN ERROR;
RETURN s1^.Compare[s2^]};
AcceptAny: PUBLIC PROC [Value] RETURNS [BOOL] ~ {RETURN [TRUE]};
ToBool: PUBLIC PROC [arg: REF ANY, default: BOOLFALSE] RETURNS [BOOL] ~ {
RETURN [SELECT arg FROM
NIL => default,
$FALSE => FALSE,
$TRUE => TRUE,
ENDCASE => ERROR]};
FromBool: PUBLIC PROC [b: BOOL] RETURNS [ATOM] ~ {
RETURN [IF b THEN $TRUE ELSE $FALSE]};
roAtoms: ARRAY RelOrder OF ATOM ~ [no: $no, fwd: $fwd, bwd: $bwd];
ToRO: PUBLIC PROC [arg: REF ANY, default: RelOrder ← no] RETURNS [RelOrder] ~ {
RETURN [SELECT arg FROM
NIL => default,
$no => no,
$fwd => fwd,
$bwd => bwd,
ENDCASE => ERROR]};
FromRO: PUBLIC PROC [ro: RelOrder] RETURNS [ATOM] ~ {
RETURN [roAtoms[ro]]};
refZero: RefEINT ~ NEW [EINT ← zero];
refOne: RefEINT ~ NEW [EINT ← one];
refTwo: RefEINT ~ NEW [EINT ← two];
refLastEINT: PUBLIC RefEINT ~ NEW [EINT ← lastEINT];
ToEI: PUBLIC PROC [arg: REF ANY, default: RefEINT ← refLastEINT] RETURNS [RefEINT] ~ {
IF arg=NIL THEN RETURN [default];
RETURN [WITH arg SELECT FROM
x: RefEINT => x,
ENDCASE => ERROR]};
FromEI: PUBLIC PROC [i: EINT] RETURNS [RefEINT] ~ {
RETURN [SELECT i FROM
zero => refZero,
one => refOne,
two => refTwo,
lastEINT => refLastEINT,
ENDCASE => NEW [EINT ← i]
]};
ToSet: PUBLIC PROC [arg: REF ANY] RETURNS [RefSet] ~ {
RETURN [WITH arg SELECT FROM
x: RefSet => x,
ENDCASE => ERROR]};
ebCode: ARRAY --min--BOOL OF ARRAY --max--BOOL OF ATOM
~ [[$None, $Max], [$Min, $Both]];
ToEB: PUBLIC PROC [arg: REF ANY, default: EndBools ← ALL[TRUE]] RETURNS [EndBools] ~ {
RETURN [SELECT arg FROM
NIL => default,
$Both => ALL[TRUE],
$Min => [TRUE, FALSE],
$Max => [FALSE, TRUE],
$None => ALL[FALSE],
ENDCASE => ERROR]};
FromEB: PUBLIC PROC [eb: EndBools] RETURNS [ATOM]
~ {RETURN [ebCode[eb[min]][eb[max]]]};
ToInterval: PUBLIC PROC [arg: REF ANY, default: RefInterval ← refFullInterval] RETURNS [RefInterval] ~ {
IF arg=NIL THEN RETURN [default];
RETURN [WITH arg SELECT FROM
x: RefInterval => x,
ENDCASE => ERROR]};
FromInterval: PUBLIC PROC [x: Interval] RETURNS [RefInterval]
~ {RETURN [SELECT x FROM
[] => refFullInterval,
[min: [i[INT.FIRST]], max: [i[INT.LAST]]] => refAllInts,
ENDCASE => NEW [Interval ← x]
]};
ToWhen: PUBLIC PROC [arg: REF ANY, default: When ← always] RETURNS [When] ~ {
RETURN [SELECT arg FROM
NIL => default,
$now => now,
$always => always,
ENDCASE => ERROR]};
UpdateSetClassOther: PUBLIC PROC [class: SetClass, Update: PROC [Atom.PropList] RETURNS [Atom.PropList]] ~ TRUSTED {
WithLock: ENTRY PROC [lp: LockPtr] ~ CHECKED {
ENABLE UNWIND => NULL;
class.other ← Update[class.other];
RETURN};
WithLock[@class.LOCK];
RETURN};
Start: PROC ~ {
Atom.PutProp[prop: kindKey, val: $composite, atom: $Enumerate];
Atom.PutProp[prop: kindKey, val: $composite, atom: $AnElt];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Pop];
Atom.PutProp[prop: kindKey, val: $composite, atom: $First];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Last];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Next];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Prev];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Empty];
Atom.PutProp[prop: kindKey, val: $composite, atom: $AddElt];
Atom.PutProp[prop: kindKey, val: $composite, atom: $RemElt];
Atom.PutProp[prop: kindKey, val: $composite, atom: $Erase];
Atom.PutProp[prop: kindKey, val: $class , atom: $HasMember];
Atom.PutProp[prop: kindKey, val: $classO , atom: $Scan];
Atom.PutProp[prop: kindKey, val: $class , atom: $TheElt];
Atom.PutProp[prop: kindKey, val: $classRO, atom: $GetOne];
Atom.PutProp[prop: kindKey, val: $classW3, atom: $Get3];
Atom.PutProp[prop: kindKey, val: $classL , atom: $Size];
Atom.PutProp[prop: kindKey, val: $classW , atom: $IsDense];
Atom.PutProp[prop: kindKey, val: $classW2, atom: $GetBounds];
Atom.PutProp[prop: kindKey, val: $class , atom: $Copy];
Atom.PutProp[prop: kindKey, val: $class , atom: $Insulate];
Atom.PutProp[prop: kindKey, val: $class , atom: $ValueOf];
Atom.PutProp[prop: kindKey, val: $class , atom: $Freeze];
Atom.PutProp[prop: kindKey, val: $class , atom: $Thaw];
Atom.PutProp[prop: kindKey, val: $classS , atom: $AddSet];
Atom.PutProp[prop: kindKey, val: $classS , atom: $RemSet];
Atom.PutProp[prop: kindKey, val: $class , atom: $QuaBiRel];
Atom.PutProp[prop: kindKey, val: $class , atom: $QuaIntInterval];
Atom.PutProp[prop: kindKey, val: $classA , atom: $SpaceOf];
};
Start[];
END.
Primitive: TypePrimitive,
HasMember: TypeHasMember,
Scan: TypeScan,
TheElt: TypeTheElt,
GetOne: TypeGetOne,
Get3: TypeGet3,
Size: TypeSize,
IsDense: TypeIsDense,
GetBounds: TypeGetBounds,
Copy: TypeCopy,
Insulate: IF mut=variable THEN TypeInsulate ELSE NIL,
ValueOf: IF mut#constant THEN TypeValueOf ELSE NIL,
Freeze: IF mut=variable THEN TypeFreeze ELSE NIL,
Thaw: IF mut=variable THEN TypeThaw ELSE NIL,
AddSet: IF mut=variable THEN TypeAddSet ELSE NIL,
RemSet: IF mut=variable THEN TypeRemSet ELSE NIL,
QuaBiRel: TypeQuaBiRel,
QuaIntInterval: TypeQuaIntInterval,
SpaceOf: TypeSpaceOf,