<> <> 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; 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; DO 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]; DO 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.