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
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--;
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
ANY ←
NIL]
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 BOOL ← ALL[FALSE],
done: BOOL ← FALSE,
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:
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] ← 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: LOV ← NIL;
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: LORA ← NIL;
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: BOOL ← FALSE;
Test:
PROC [val: Value]
RETURNS [pass:
BOOL ←
FALSE] ~ {
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: BOOL ← FALSE;
Test:
PROC [val: Value]
RETURNS [pass:
BOOL ←
FALSE] ~ {
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: BOOL ← TRUE;
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: BOOL ← TRUE;
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: BOOL ← TRUE;
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: INT ← INT.LAST;
max: INT ← INT.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:
BOOL ←
FALSE]
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,