[Cyan]<CedarChest7.0>SetsAndStuff>CollectionsImpl.Mesa!3

CollectionsImpl.Mesa

Last tweaked by Mike Spreitzer on October 19, 1987 1:48:51 pm PDT

DIRECTORY Atom, Basics, Collections, IntFunctions, PairCollections, List, Process, Rope, RopeHash;

CollectionsImpl: CEDAR MONITOR

LOCKS par USING par: Parallel

IMPORTS Atom, Collections, IntFunctions, PairCollections, List, Process, Rope, RopeHash

EXPORTS Collections

BEGIN OPEN IFs:IntFunctions, PCs:PairCollections, Collections;

Error: PUBLIC ERROR [msg: ROPE, args: LOV] = CODE;

Cant: PUBLIC ERROR [coll: Collection] = CODE;

frozen: PUBLIC ROPE ~ BeRope["attempt to change a frozen variable collection %g"];

unfrozen: PUBLIC ROPE ~ BeRope["attempt to access an unfrozen variable collection %g"];

notASingleton: PUBLIC ROPE ~ BeRope["collection %g is not a singleton"];

notVariable: PUBLIC ROPE ~ BeRope["collection %g is not variable"];

writeable: PUBLIC ROPE ~ BeRope["collection %g is not unwriteable"];

notConstant: PUBLIC ROPE ~ BeRope["collection %g is not constant"];

notFound: PUBLIC ROPE ~ BeRope["attempt to use undefined value"];

badColl: PUBLIC Collection ← [NIL, noValue];

Escape: ERROR = CODE;

provisionKey: ATOM ~ $CollectionsImplProvision;

bkwdableKey: ATOM ~ $CollectionsImplAble;

dirableKey: ATOM ~ $PairCollectionsImplDirable;

kindKey: ATOM ~ $CollectionsImplKind;

Cons: PUBLIC PROC [class: CollectionClass, data: REF ANY] RETURNS [Collection] ~ {

RETURN [[class, data]]};

CreateClass: PUBLIC PROC

[cp: CollectionClassPrivate, bkwdable: BB ← [TRUE, FALSE], dirable: BoolPair ← [TRUE, TRUE]]

RETURNS [class: CollectionClass] ~ {

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

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

provs ← List.PutAssoc[op, IF def THEN $Default ELSE $Primitive, provs];

RETURN [def]};

{OPEN cp;

IF Sp[$HasMember, HasMember=NIL] THEN HasMember ← DefaultHasMember;

IF Sp[$Enumerate, Enumerate=NIL] THEN Enumerate ← DefaultEnumerate;

IF Sp[$Scan, Scan=NIL] THEN Scan ← DefaultScan;

IF Sp[$TheElt, TheElt=NIL] THEN TheElt ← DefaultTheElt;

IF Sp[$Extremum, Extremum=NIL] THEN Extremum ← DefaultExtremum;

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

IF Sp[$Size, Size=NIL] THEN Size ← DefaultSize;

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

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

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

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

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

IF Sp[$AddColl, AddColl=NIL] THEN AddColl ← DefaultAddColl;

IF Sp[$RemoveColl, RemoveColl=NIL] THEN RemoveColl ← DefaultRemoveColl;

IF Sp[$QuaPairColl, QuaPairColl=NIL] THEN QuaPairColl ← DefaultQuaPairColl;

IF Sp[$QuaIntFn, QuaIntFn=NIL] THEN QuaIntFn ← DefaultQuaIntFn;

IF Sp[$SpaceOf, SpaceOf=NIL] THEN SpaceOf ← DontKnowSpace;

IF Sp[$OrderingOf, OrderingOf=NIL] THEN OrderingOf ← IF orderStyle=value THEN BeOrderedBySpace ELSE BeUnordered;

};

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

cp.other ← List.PutAssoc[bkwdableKey, NEW [BB ← bkwdable], cp.other];

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

class ← NEW [CollectionClassPrivate ← cp];

};

Primitive: PROC [coll: Collection, op: ATOM, args: ArgList ← NIL] RETURNS [BOOL] ~ {

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

SELECT kind FROM

$class, $classB, $classBR, $classD => NULL;

ENDCASE => ERROR;

IF coll.class.Primitive#NIL THEN SELECT coll.class.Primitive[coll, op, args] FROM

yes => RETURN [TRUE];

no => RETURN [FALSE];

pass => NULL;

ENDCASE => ERROR;

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

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

RETURN [SELECT prov FROM

$Default => FALSE,

$Primitive => SELECT kind FROM

$class => TRUE,

$classD => (NARROW[List.Assoc[dirableKey, coll.class.other], REF BoolPair])[GetDir[args, 1]],

$classB => (NARROW[List.Assoc[bkwdableKey, coll.class.other], REF BB])[GetBool[args, 1]],

$classBR => (coll.MutabilityOf[]#variable AND GetBool[args, 2]) OR (NARROW[List.Assoc[bkwdableKey, coll.class.other], REF BB])[GetBool[args, 1]],

ENDCASE => ERROR,

ENDCASE => ERROR];

}};

QualityOf: PUBLIC PROC [coll: Collection, op: ATOM, args: ArgList ← NIL] RETURNS [ImplQuality] ~ {

SELECT Atom.GetProp[atom: op, prop: kindKey] FROM

$class, $classB, $classBR, $classD => NULL;

$composite => SELECT op FROM

$First => RETURN QualityOf[coll, $Extremum, LIST[$FALSE, $FALSE]];

$Last => RETURN QualityOf[coll, $Extremum, LIST[$TRUE, $FALSE]];

$Pop => RETURN QualityOf[coll, $Extremum, LIST[FromBool[GetBool[args, 1]], $TRUE]];

$Next => RETURN QMin[QualityOf[coll, $Get3], goodDefault];

$Prev => RETURN QMin[QualityOf[coll, $Get3], goodDefault];

$AddElt => RETURN QualityOf[coll, $AddColl];

$RemoveElt => RETURN QualityOf[coll, $RemoveColl];

$Erase => RETURN QualityOf[coll, $RemoveColl];

$IsPairColl => RETURN QualityOf[coll, $QuaPairColl];

$AsPairColl => RETURN QualityOf[coll, $QuaPairColl];

$IsIntFn => RETURN QualityOf[coll, $QuaIntFn, args];

$AsIntFn => RETURN QualityOf[coll, $QuaIntFn, args];

ENDCASE => ERROR;

IF Primitive[coll, op, args] THEN RETURN [primitive];

RETURN [SELECT op FROM

$HasMember => QMin[poorDefault, QMin[QualityOf[coll, $SpaceOf], QualityOf[coll, $Scan, LIST[$FALSE]]]],

$Enumerate, $Scan => IF Primitive[coll, $Enumerate, args] OR Primitive[coll, $Scan, args] THEN goodDefault ELSE IF (Primitive[coll, $Enumerate, LIST[FromBool[NOT GetBool[args, 1]]]] OR Primitive[coll, $Scan, LIST[FromBool[NOT GetBool[args, 1]]]]) THEN poorDefault ELSE cant,

$TheElt => QMin[goodDefault, QualityOf[coll, $Extremum]],

$Extremum => QMin[IF coll.QualityOf[$Scan, args] >= goodDefault THEN goodDefault ELSE poorDefault, IF GetBool[args, 2] THEN coll.QualityOf[$RemoveElt] ELSE goodDefault],

$Get3 => IF QualityOf[coll, $SpaceOf]=cant THEN cant ELSE QMin[poorDefault, QMax[QualityOf[coll, $Scan, LIST[$TRUE]], QualityOf[coll, $Scan, LIST[$FALSE]]]],

$Size => QMin[QualityOf[coll, $Scan], poorDefault],

$Copy => cant,

$Insulate => goodDefault,

$ValueOf => IF coll.class.mutability=constant THEN goodDefault ELSE QMin[poorDefault, QMin[QualityOf[coll, $Copy], QualityOf[coll, $Freeze]]],

$Freeze, $Thaw => IF coll.MutabilityOf=variable THEN cant ELSE ERROR,

$AddColl, $RemoveColl => IF coll.MutabilityOf=variable THEN cant ELSE goodDefault,

$QuaPairColl => goodDefault,

$QuaIntFn => goodDefault,

$SpaceOf => cant,

$OrderingOf => QMin[goodDefault, IF coll.OrderStyleOf=value THEN QualityOf[coll, $SpaceOf] ELSE primitive],

ENDCASE => ERROR];

};

DefaultHasMember: PROC [coll: Collection, elt: Value] RETURNS [has: BOOL] ~ {

space: Space ~ coll.SpaceOf[];

Test: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {

IF space.SpaceEqual[elt, val] THEN pass ← has ← TRUE;

};

IF space=NIL THEN Cant[coll];

has ← FALSE;

[] ← coll.Scan[Test];

RETURN};

DefaultEnumerate: PUBLIC PROC [coll: Collection, Consumer: PROC [elt: Value], bkwd: BOOL] ~ {

IF Primitive[coll, $Scan, LIST[FromBool[bkwd]]] THEN {

Pass: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {Consumer[val]};

[] ← coll.Scan[Pass, bkwd];

bkwd ← bkwd;

}

ELSE IF NOT (Primitive[coll, $Enumerate, LIST[FromBool[NOT bkwd]]] OR Primitive[coll, $Scan, LIST[FromBool[NOT bkwd]]]) THEN Cant[coll]

ELSE {

elts: LOV ← NIL;

Addit: PROC [x: Value] ~ {elts ← CONS[coll.PreserveValue[x], elts]};

coll.Enumerate[Addit, NOT bkwd];

FOR elts ← elts, elts.rest WHILE elts # NIL DO Consumer[elts.first] ENDLOOP;

elts ← elts;

};

RETURN};

DefaultScan: PUBLIC PROC [coll: Collection, Test: Tester, bkwd: BOOL] RETURNS [mv: MaybeValue ← noMaybe] ~ {

IF Primitive[coll, $Enumerate, LIST[FromBool[bkwd]]] THEN {

Pass: PROC [val: Value] ~ {

IF Test[val] THEN {mv ← [TRUE, coll.PreserveValue[val]]; Escape};

};

coll.Enumerate[Pass, bkwd !Escape => CONTINUE];

}

ELSE IF NOT (Primitive[coll, $Enumerate, LIST[FromBool[NOT bkwd]]] OR Primitive[coll, $Scan, LIST[FromBool[NOT bkwd]]]) THEN Cant[coll]

ELSE {

elts: LOV ← NIL;

Addit: PROC [x: Value] ~ {elts ← CONS[coll.PreserveValue[x], elts]};

coll.Enumerate[Addit, NOT bkwd];

FOR elts ← elts, elts.rest WHILE elts # NIL DO IF Test[elts.first] THEN RETURN [[TRUE, elts.first]] ENDLOOP;

};

RETURN};

DefaultTheElt: PROC [coll: Collection] RETURNS [v: Value] ~ {

SELECT coll.Size[2] FROM

1 => {

mv: MaybeValue ~ coll.First[];

IF mv.found THEN RETURN [mv.val] ELSE ERROR;

};

ENDCASE => NULL;

Error[notASingleton, LIST[coll.Refify]];

};

DefaultExtremum: PUBLIC PROC [coll: Collection, bkwd, remove: BOOL] RETURNS [mv: MaybeValue] ~ {

Easy: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {pass ← TRUE};

Hard: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {mv ← [TRUE, coll.PreserveValue[val]]};

IF coll.QualityOf[$Scan, LIST[FromBool[bkwd]]] >= goodDefault THEN mv ← coll.Scan[Easy, bkwd]

ELSE [] ← coll.Scan[Hard, NOT bkwd];

IF mv.found AND remove THEN IF NOT coll.RemoveElt[mv.val, IF bkwd THEN last ELSE first] THEN ERROR;

RETURN};

DefaultGet3: PROC [coll: Collection, elt: Value] RETURNS [prev, same, next: MaybeValue] ~ {

fq: ImplQuality ~ coll.QualityOf[$Scan, LIST[$FALSE]];

bq: ImplQuality ~ coll.QualityOf[$Scan, LIST[$TRUE]];

bkwd: BOOL ~ bq > fq;

take: BOOL ← FALSE;

space: Space ~ coll.SpaceOf[];

Pass: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {

IF space.SpaceEqual[val, elt] THEN same ← [take ← TRUE, elt]

ELSE IF take THEN pass ← TRUE

ELSE prev ← [TRUE, val];

};

IF space=NIL THEN Cant[coll];

prev ← same ← noMaybe;

next ← coll.Scan[Pass, bkwd];

IF bkwd THEN RETURN [next, same, prev];

RETURN};

DefaultSize: PROC [coll: Collection, limit: LNAT ← LNAT.LAST] RETURNS [size: LNAT] ~ {

Pass: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {pass ← limit <= (size ← size+1)};

size ← 0;

[] ← coll.Scan[Pass];

RETURN};

DefaultCopy: PROC [coll: Collection] RETURNS [VarColl] ~ {Cant[coll]};

DefaultInsulate: PROC [coll: Collection] RETURNS [UWColl] ~ {

RETURN [AsUW[IF coll.class.mutability#variable THEN coll ELSE

[insulatorClasses

[coll.class.mayDuplicate]

[coll.class.orderStyle],

coll.Refify]]]};

DefaultValueOf: PROC [coll: Collection] RETURNS [ConstColl] ~ {IF coll.class.mutability#constant THEN RETURN coll.Copy.Freeze[] ELSE RETURN AsConst[coll]};

DefaultFreeze: PROC [coll: Collection] RETURNS [const: ConstColl] ~ {IF coll.MutabilityOf#variable THEN Complain[coll, notVariable] ELSE Cant[coll]};

DefaultThaw: PROC [coll: Collection] ~ {IF coll.MutabilityOf#variable THEN Complain[coll, notVariable] ELSE Cant[coll]};

DefaultAddColl: PROC [coll, other: Collection, where: Where] RETURNS [someNew, allNew: BOOL] ~ {IF coll.MutabilityOf#variable THEN Complain[coll, notVariable] ELSE Cant[coll]};

DefaultRemoveColl: PROC [coll, other: Collection, style: RemoveStyle] RETURNS [hadSome, hadAll: BOOL] ~ {IF coll.MutabilityOf#variable THEN Complain[coll, notVariable] ELSE Cant[coll]};

NAddElt: PUBLIC PROC [coll: Collection, elt: Value, where: Where ← []] RETURNS [new: BOOL] ~ {

[new, new] ← coll.class.AddColl[coll, CreateSingleton[elt, coll.SpaceOf], where]};

SpaceBeRefs: PUBLIC PROC [coll: Collection] RETURNS [Space] ~ {RETURN [refs]};

DontKnowSpace: PUBLIC PROC [coll: Collection] RETURNS [Space] ~ {RETURN [NIL]};

SpaceBeRopesWithCase: PUBLIC PROC [coll: Collection] RETURNS [Space] ~ {RETURN [ropes[TRUE]]};

SpaceBeRopesWithoutCase: PUBLIC PROC [coll: Collection] RETURNS [Space] ~ {RETURN [ropes[FALSE]]};

SpaceBeRopes: PUBLIC ARRAY BOOL OF PROC [coll: Collection] RETURNS [Space] ~ [FALSE: SpaceBeRopesWithoutCase, TRUE: SpaceBeRopesWithCase];

BeUnordered: PUBLIC PROC [coll: Collection] RETURNS [Ordering] ~ {RETURN [unordered]};

BeOrderedBySpace: PUBLIC PROC [coll: Collection] RETURNS [Ordering] ~ {

space: Space ~ coll.SpaceOf;

IF space=NIL THEN RETURN [unordered];

RETURN [[space.Compare, space.data]];

};

SpaceOrdering: PUBLIC PROC [space: Space] RETURNS [Ordering] ~ {

RETURN [[space.Compare, space.data]]};

ReverseOrdering: PUBLIC PROC [o: Ordering] RETURNS [ro: Ordering] ~ {

RETURN [[CompareReversal, NEW [Ordering ← o]]];

};

CompareReversal: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison] ~ {

o: REF Ordering ~ NARROW[data];

RETURN o.Compare[o.data, elt2, elt1]};

ComposeOrderings: PUBLIC PROC [mso, lso: Ordering] RETURNS [Ordering] ~ {

co: ComposedOrdering ~ NEW [ComposedOrderingPrivate ← [mso, lso]];

RETURN [[ComposedCompare, co]]};

ComposedOrdering: TYPE ~ REF ComposedOrderingPrivate;

ComposedOrderingPrivate: TYPE ~ RECORD [mso, lso: Ordering];

ComposedCompare: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [c: Basics.Comparison] ~ {

co: ComposedOrdering ~ NARROW[data];

IF (c ← co.mso.Compare[co.mso.data, elt1, elt2])#equal THEN RETURN;

RETURN co.lso.Compare[co.lso.data, elt1, elt2]};

ParallelScan: PUBLIC PROC [a, b: Collection, Test: ParallelTester, bkwd: BOOL ← FALSE] RETURNS [pf: ParallelFind] ~ TRUSTED {

par: Parallel ~ NEW [ParallelPrivate ← [coll: [a, b] ]];

pa: PROCESS ~ FORK Par[par, a, bkwd];

pb: PROCESS ~ FORK Par[par, b, bkwd];

WaitForReq: ENTRY SAFE PROC [par: Parallel] RETURNS [continue: BOOL] ~ TRUSTED {

ENABLE UNWIND => NULL;

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

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

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

ENDLOOP;

};

Satisfy: ENTRY SAFE PROC [par: Parallel] ~ TRUSTED {

ENABLE UNWIND => NULL;

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

BROADCAST par.change;

RETURN};

pf ← [FALSE, noMaybe, noMaybe];

IF NOT WaitForReq[par] THEN EXIT;

IF (par.pass ← Test[par.val[a], par.val[b]]) THEN pf ← [TRUE, par.val[a], par.val[b]];

Satisfy[par];

IF par.pass THEN EXIT;

ENDLOOP;

JOIN pa;

JOIN pb;

RETURN};

Which: TYPE ~ {a, b};

Parallel: TYPE ~ REF ParallelPrivate;

ParallelPrivate: TYPE ~ MONITORED RECORD [

coll: ARRAY Which OF Collection,

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

pass: BOOL ← FALSE,

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

val: ARRAY Which OF MaybeValue ← ALL[[TRUE, noValue]]

];

Par: PROC [par: Parallel, which: Which, bkwd: BOOL] ~ {

Mediate: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {

WithLock: ENTRY PROC [par: Parallel] ~ {

ENABLE UNWIND => NULL;

par.val[which].val ← val;

par.ready[which] ← TRUE;

BROADCAST par.change;

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

pass ← par.pass;

RETURN};

WithLock[par];

RETURN};

Finish: ENTRY PROC [par: Parallel] ~ {

ENABLE UNWIND => NULL;

par.val[which].found ← FALSE;

par.ready[which] ← TRUE;

BROADCAST par.change;

RETURN};

[] ← par.coll[which].Scan[Mediate, bkwd];

Finish[par];

RETURN};

refColls: PUBLIC Space ~ NEW [SpacePrivate ← [

Equal: RefCollsEqual,

Hash: HashRefColl,

Compare: CompareRefColls,

other: List.PutAssoc[$Name, "ref Coll", NIL]

]];

RefCollsEqual: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [BOOL] ~ {

pc1: REF Collection ~ NARROW[elt1];

pc2: REF Collection ~ NARROW[elt2];

RETURN [pc1^.Equal[pc2^]]};

HashRefColl: PROC [data: REF ANY, elt: Value] RETURNS [CARDINAL] ~ {

pc: REF Collection ~ NARROW[elt];

RETURN pc^.Hash[]};

CompareRefColls: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison] ~ {

pc1: REF Collection ~ NARROW[elt1];

pc2: REF Collection ~ NARROW[elt2];

RETURN [pc1^.Compare[pc2^]]};

Equal: PUBLIC PROC [a, b: Collection] RETURNS [BOOL] ~ {

mayDup: BOOL ~ a.MayDuplicate[];

space: Space ~ a.SpaceOf[];

IF mayDup # b.MayDuplicate THEN ERROR Cant[a];

IF space # b.SpaceOf[] THEN ERROR Cant[a];

IF space=NIL THEN ERROR Cant[a];

IF mayDup THEN {

Test: PROC [a, b: MaybeValue] RETURNS [pass: BOOL ← FALSE] ~ {

IF a.found#b.found THEN RETURN [TRUE];

IF NOT a.found THEN ERROR;

pass ← NOT space.SpaceEqual[a.val, b.val];

RETURN};

RETURN [NOT ParallelScan[a, b, Test].found];

}

ELSE IF a.Can[$Enumerate] AND b.Can[$Enumerate] THEN {

Try: PROC [a, b: Collection] RETURNS [BOOL] ~ {

Test: PROC [val: Value] RETURNS [pass: BOOL] ~ {

pass ← NOT b.HasMember[val];

RETURN};

RETURN [NOT a.Scan[Test].found];

};

RETURN [Try[a, b] AND Try[b, a]];

}

ELSE ERROR Cant[a];

};

Hash: PUBLIC PROC [coll: Collection] RETURNS [hash: CARDINAL] ~ {

space: Space ~ coll.SpaceOf[];

Per: PROC [val: Value] RETURNS [pass: BOOL ← FALSE] ~ {

hash ← hash + space.SpaceHash[val];

RETURN};

hash ← 0;

IF space=NIL OR space.Hash=CantHash THEN Cant[coll];

[] ← coll.Scan[Per];

RETURN};

Compare: PUBLIC PROC [a, b: Collection] RETURNS [c: Basics.Comparison] ~ {

mayDup: BOOL ~ a.MayDuplicate[];

space: Space ~ a.SpaceOf[];

orderStyle: OrderStyle ~ a.OrderStyleOf;

IF mayDup # b.MayDuplicate THEN ERROR Cant[a];

IF space # b.SpaceOf[] THEN ERROR Cant[a];

IF space=NIL OR space.Compare=CantCompare THEN ERROR Cant[a];

IF orderStyle # b.OrderStyleOf[] THEN ERROR Cant[a];

IF mayDup OR orderStyle#none THEN {

Test: PROC [a, b: MaybeValue] RETURNS [pass: BOOL ← FALSE] ~ {

IF a.found#b.found THEN {

c ← IF a.found THEN greater ELSE less;

RETURN [TRUE]};

IF NOT a.found THEN ERROR;

c ← space.SpaceCompare[a.val, b.val];

pass ← c#equal;

RETURN};

c ← equal;

[] ← ParallelScan[a, b, Test];

RETURN};

ERROR Cant[a];

};

InsulatorClasses: TYPE ~ ARRAY --mayDuplicate--BOOL OF ARRAY OrderStyle OF CollectionClass;

insulatorClasses: REF InsulatorClasses ~ NEW[InsulatorClasses];

InsulatePrimitive: PROC [coll: Collection, op: ATOM, args: ArgList] RETURNS [PrimitiveAnswer] ~ {

subj: Collection ~ DeRef[coll.data];

IF Primitive[subj, op, args] THEN RETURN [yes];

SELECT op FROM

$Insulate, $Freeze, $Thaw, $AddColl, $RemoveColl => RETURN [yes];

ENDCASE => RETURN [no];

};

InsulateHasMember: PROC [coll: Collection, elt: Value] RETURNS [BOOL] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.HasMember[elt]};

InsulateScan: PROC [coll: Collection, Test: Tester, bkwd: BOOL] RETURNS [MaybeValue] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.Scan[Test, bkwd]};

InsulateTheElt: PROC [coll: Collection] RETURNS [Value] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.TheElt[]};

InsulateExtremum: PROC [coll: Collection, bkwd, remove: BOOL] RETURNS [MaybeValue] ~ {

subj: Collection ~ DeRef[coll.data];

IF remove THEN coll.Complain[notVariable];

RETURN subj.class.Extremum[subj, bkwd, FALSE]};

InsulateGet3: PROC [coll: Collection, elt: Value] RETURNS [prev, same, next: MaybeValue] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.Get3[elt]};

InsulateSize: PROC [coll: Collection, limit: LNAT ← LNAT.LAST] RETURNS [LNAT] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.Size[limit]};

InsulateCopy: PROC [coll: Collection] RETURNS [VarColl] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.Copy[]};

InsulateValueOf: PROC [coll: Collection] RETURNS [ConstColl] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.ValueOf[]};

InsulateQuaPairColl: PROC [coll: Collection] RETURNS [mv: MaybeValue] ~ {

subj: Collection ~ DeRef[coll.data];

IF NOT (mv ← subj.QuaPairColl[]).found THEN RETURN;

RETURN [[TRUE, PCs.DeRef[mv.val].Insulate.Refify]]};

InsulateQuaIntFn: PROC [coll: Collection, dir: Direction] RETURNS [mv: MaybeValue] ~ {

subj: Collection ~ DeRef[coll.data];

IF NOT (mv ← subj.QuaIntFn[dir]).found THEN RETURN;

RETURN [[TRUE, IFs.DeRef[mv.val].Insulate.Refify]]};

InsulateSpaceOf: PROC [coll: Collection] RETURNS [Space] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.SpaceOf[]};

InsulateOrderingOf: PROC [coll: Collection] RETURNS [Ordering] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.OrderingOf[]};

InsulatePreserveValue: PROC [coll: Collection, val: Value] RETURNS [Value] ~ {

subj: Collection ~ DeRef[coll.data];

RETURN subj.PreserveValue[val]};

emptyClass: CollectionClass ~ CreateClass[[

HasMember: EmptyHasMember,

Scan: ScanEmpty,

Size: EmptySize,

mayDuplicate: FALSE,

mutability: constant], [TRUE, TRUE]];

EmptyHasMember: PROC [coll: Collection, elt: Value] RETURNS [BOOL]

~ {RETURN [FALSE]};

ScanEmpty: PROC [coll: Collection, Test: Tester, bkwd: BOOL] RETURNS [MaybeValue]

~ {RETURN [noMaybe]};

EmptySize: PROC [coll: Collection, limit: LNAT ← LNAT.LAST] RETURNS [LNAT]

~ {RETURN [0]};

emptySet: PUBLIC ConstSet ~ AsConst[[emptyClass, NIL]];

NCreateSingleton: PUBLIC PROC [elt: Value, space: Space] RETURNS [ConstSet]

~ {RETURN [[[[GetSingletonClass[space], elt]]]]};

MakeSingletonClass: PROC [space: Space] RETURNS [class: CollectionClass] ~ {

class ← CreateClass[[

HasMember: SingletonHasMember,

Enumerate: EnumerateSingleton,

TheElt: TheSingletonElt,

Extremum: SingletonExtremum,

Size: SingletonSize,

SpaceOf: IF space#NIL THEN SpaceOfSingleton ELSE NIL,

mayDuplicate: FALSE,

mutability: constant,

data: space], [TRUE, TRUE]];

};

singletonClass: CollectionClass ~ MakeSingletonClass[NIL];

classKey: ATOM ~ $CollectionsImplSingletonClass;

GetSingletonClass: PUBLIC PROC [space:Space] RETURNS [class:CollectionClass] ~ {

IF space=NIL THEN RETURN [singletonClass];

class ← NARROW[List.Assoc[key: classKey, aList: space.other]];

IF class=NIL THEN space.other ← List.PutAssoc[classKey, class ← MakeSingletonClass[space], space.other];

RETURN};

SingletonHasMember: PROC [coll: Collection, elt: Value] RETURNS [BOOL] ~ {

space: Space ~ NARROW[coll.class.data];

IF space=NIL THEN Cant[coll];

RETURN space.SpaceEqual[elt, coll.data];

};

EnumerateSingleton: PROC [coll: Collection, Consumer: PROC [elt: Value], bkwd: BOOL] ~ {

Consumer[coll.data];

};

TheSingletonElt: PROC [coll: Collection] RETURNS [Value] ~ {RETURN [coll.data]};

SingletonExtremum: PROC [coll: Collection, bkwd, remove: BOOL] RETURNS [MaybeValue] ~ {

IF remove THEN coll.Complain[notVariable];

RETURN [[TRUE, coll.data]]};

SingletonSize: PROC [coll: Collection, limit: LNAT ← LNAT.LAST] RETURNS [LNAT]

~ {RETURN [1]};

SpaceOfSingleton: PROC [coll: Collection] RETURNS [Space]

~ {RETURN [NARROW[coll.class.data]]};

CreateEnumerator: PUBLIC PROC [e: EnumerateClosure, mayDuplicate: BOOL ← TRUE, orderStyle: OrderStyle ← none, mutability: UnwriteableMutability ← readonly] RETURNS [Enumerator] ~ {

ec: REF EnumerateClosure ~ NEW [EnumerateClosure ← e];

RETURN [[

enumClasses[mayDuplicate][orderStyle][mutability],

ec]];

};

EnumClasses: TYPE ~ ARRAY --mayDuplicate--BOOL OF ARRAY OrderStyle OF ARRAY UnwriteableMutability OF CollectionClass;

enumClasses: REF EnumClasses ~ NEW[EnumClasses];

EnumerateEnumerator: PROC [coll: Collection, Consumer: PROC [elt: Value], bkwd: BOOL] ~ {

IF bkwd THEN {DefaultEnumerate[coll, Consumer, bkwd]; RETURN};

{ec: REF EnumerateClosure ~ NARROW[coll.data];

ec.Enumerate[Consumer, ec.data];

RETURN}};

SpaceOfEnumerator: PROC [coll: Collection] RETURNS [Space] ~ {

ec: REF EnumerateClosure ~ NARROW[coll.data];

RETURN [ec.space]};

PreserveEnumeratedValue: PROC [coll: Collection, val: Value] RETURNS [Value] ~ {

ec: REF EnumerateClosure ~ NARROW[coll.data];

RETURN [IF ec.Preserve=NIL THEN val ELSE ec.Preserve[val, ec.data]]};

filterClasses: PUBLIC ARRAY UnwriteableMutability OF CollectionClass ~ [

readonly: CreateClass[[

HasMember: FilterHasMember,

SpaceOf: SpaceOfFilter,

mutability: readonly]],

constant: CreateClass[[

HasMember: FilterHasMember,

SpaceOf: SpaceOfFilter,

mutability: constant]]];

FilterHasMember: PROC [coll: Collection, elt: Value] RETURNS [BOOL] ~ {

rfc: REF FilterClosure ~ NARROW[coll.data];

RETURN rfc.Test[elt, rfc.data]};

SpaceOfFilter: PROC [coll: Collection] RETURNS [Space] ~ {

rfc: REF FilterClosure ~ NARROW[coll.data];

RETURN [rfc.space]};

HaveAll: PROC [val: Value, data: REF ANY ← NIL] RETURNS [BOOL]

~ {RETURN[TRUE]};

passAll: PUBLIC ConstFilter ~ CreateFilter[[HaveAll], constant].AsConst;

noValue: PUBLIC NoValue ~ NEW [NoValuePrivate];

noMaybe: PUBLIC MaybeValue ~ [FALSE, noValue];

GetBool: PUBLIC PROC [args: ArgList, i: NAT, default: BOOL ← FALSE] RETURNS [BOOL] ~ {

IF i<1 THEN ERROR;

WHILE i>1 AND args#NIL DO args ← args.rest; i ← i - 1 ENDLOOP;

RETURN [IF args=NIL THEN default ELSE SELECT args.first FROM

$FALSE => FALSE,

$TRUE => TRUE,

ENDCASE => ERROR]};

GetDir: PUBLIC PROC [args: ArgList, i: NAT, default: Direction ← leftToRight] RETURNS [Direction] ~ {

IF i<1 THEN ERROR;

WHILE i>1 AND args#NIL DO args ← args.rest; i ← i - 1 ENDLOOP;

RETURN [IF args=NIL THEN default ELSE SELECT args.first FROM

$leftToRight => leftToRight,

$rightToLeft => rightToLeft,

ENDCASE => ERROR]};

FromBool: PUBLIC PROC [x: BOOL] RETURNS [ATOM]

~ {RETURN [IF x THEN $TRUE ELSE $FALSE]};

FromDir: PUBLIC PROC [x: Direction] RETURNS [ATOM]

~ {RETURN [IF x=leftToRight THEN $leftToRight ELSE $rightToLeft]};

refs: PUBLIC Space ~ NEW [SpacePrivate ← [

other: List.PutAssoc[$Name, "refs", NIL]

]];

refInts: PUBLIC Space ~ NEW [SpacePrivate ← [

Equal: IntsEqual,

Hash: HashInt,

Compare: CompareInts,

other: List.PutAssoc[$Name, "ints", NIL]

]];

IntsEqual: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [BOOL] ~ {

ri1: REF INT ~ NARROW[elt1];

ri2: REF INT ~ NARROW[elt2];

RETURN [ri1^ = ri2^]};

HashInt: PROC [data: REF ANY, elt: Value] RETURNS [CARDINAL] ~ {

ri: REF INT ~ NARROW[elt];

RETURN HashIntI[ri^]};

CompareInts: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison] ~ {

ri1: REF INT ~ NARROW[elt1];

ri2: REF INT ~ NARROW[elt2];

RETURN [CompareIntI[ri1^, ri2^]]};

ropes: PUBLIC ARRAY --case matters--BOOL OF Space ~ [

TRUE: NEW [SpacePrivate ← [

Equal: RopesEqual,

Hash: HashRope,

Compare: CompareRopes,

other: List.PutAssoc[$Name, "ropes with case", NIL],

data: NEW [BOOL ← TRUE]]],

FALSE: NEW [SpacePrivate ← [

Equal: RopesEqual,

Hash: HashRope,

Compare: CompareRopes,

other: List.PutAssoc[$Name, "ropes without case", NIL],

data: NEW [BOOL ← FALSE]]]

];

RopesEqual: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [BOOL] ~ {

case: REF BOOL ~ NARROW[data];

r1: ROPE ~ NARROW[elt1];

r2: ROPE ~ NARROW[elt2];

RETURN r1.Equal[r2, case^];

};

HashRope: PROC [data: REF ANY, elt: Value] RETURNS [CARDINAL] ~ {

case: REF BOOL ~ NARROW[data];

r: ROPE ~ NARROW[elt];

RETURN RopeHash.FromRope[r, case^];

};

CompareRopes: PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison] ~ {

case: REF BOOL ~ NARROW[data];

r1: ROPE ~ NARROW[elt1];

r2: ROPE ~ NARROW[elt2];

RETURN r1.Compare[r2, case^];

};

CantHash: PUBLIC HashProc ~ {ERROR--this proc is not to be called, it's just an exceptional value (NIL's taken up indicating address hashing)--};

CantCompare: PUBLIC CompareProc ~ {ERROR--this proc is not to be called, it's just an exceptional value (NIL's taken up indicating address comparison)--};

EqualAddresses: PUBLIC PROC [data: REF ANY, elt1, elt2: Value] RETURNS [BOOL]

~ {RETURN [elt1=elt2]};

HashAddress: PUBLIC PROC [data: REF ANY, elt: Value] RETURNS [CARDINAL]

~ {RETURN [HashRefI[elt]]};

CompareAddresses: PUBLIC PROC [data: REF ANY, elt1, elt2: Value] RETURNS [Basics.Comparison]

~ {RETURN [CompareRefI[elt1, elt2]]};

BeRope: PROC [r: ROPE] RETURNS [ROPE] ~ INLINE {RETURN[r]};

Start: PROC ~ {

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

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

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

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

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

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

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

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

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

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

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

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

Atom.PutProp[prop: kindKey, val: $class , atom: $HasMember];

Atom.PutProp[prop: kindKey, val: $classB , atom: $Enumerate];

Atom.PutProp[prop: kindKey, val: $classB , atom: $Scan];

Atom.PutProp[prop: kindKey, val: $class , atom: $TheElt];

Atom.PutProp[prop: kindKey, val: $classBR, atom: $Extremum];

Atom.PutProp[prop: kindKey, val: $class , atom: $Get3];

Atom.PutProp[prop: kindKey, val: $class , atom: $Size];

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: $class , atom: $AddColl];

Atom.PutProp[prop: kindKey, val: $class , atom: $RemoveColl];

Atom.PutProp[prop: kindKey, val: $class , atom: $QuaPairColl];

Atom.PutProp[prop: kindKey, val: $classD , atom: $QuaIntFn];

Atom.PutProp[prop: kindKey, val: $class , atom: $SpaceOf];

Atom.PutProp[prop: kindKey, val: $class , atom: $OrderingOf];

FOR mayDuplicate: BOOL IN BOOL DO FOR orderStyle: OrderStyle IN OrderStyle DO

insulatorClasses[mayDuplicate][orderStyle] ← CreateClass[[

Primitive: InsulatePrimitive,

HasMember: InsulateHasMember,

Scan: InsulateScan,

TheElt: InsulateTheElt,

Extremum: InsulateExtremum,

Get3: InsulateGet3,

Size: InsulateSize,

Copy: InsulateCopy,

ValueOf: InsulateValueOf,

QuaPairColl: InsulateQuaPairColl,

QuaIntFn: InsulateQuaIntFn,

SpaceOf: InsulateSpaceOf,

OrderingOf: InsulateOrderingOf,

PreserveValue: InsulatePreserveValue,

mayDuplicate: mayDuplicate,

orderStyle: orderStyle,

mutability: readonly]];

FOR m: UnwriteableMutability IN UnwriteableMutability DO

enumClasses[mayDuplicate][orderStyle][m] ← CreateClass[[

Enumerate: EnumerateEnumerator,

SpaceOf: SpaceOfEnumerator,

PreserveValue: PreserveEnumeratedValue,

mayDuplicate: mayDuplicate,

orderStyle: orderStyle,

mutability: m], [TRUE, FALSE]];

ENDLOOP;

ENDLOOP ENDLOOP;

};

Start[];

END.