'From Objectworks for Smalltalk-80(tm), Version 2.5 of 29 July 1989 on 10 April 1999 at 6:41:07 pm'! ((CxxSystemOrganization tree childNamed: 'top') ~= nil) ifTrue: [ (CxxSystemOrganization tree childNamed: 'top') destroyFiles]! Heaper subclass: #Abraham instanceVariableNames: ' myHash {UInt32} myToken {Int32 NOCOPY} myInfo {FlockInfo NOCOPY}' classVariableNames: ' DismantleStatistics {IdentityDictionary smalltalk of: Category and: IntegerVar} TheTokenSource {TokenSource} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (Abraham getOrMakeCxxClassDescription) friends: 'friend class SnarfPacker; friend class TestPacker; friend class FakePacker; friend class SnarfRecord; friend class SnarfHandler; friend void unlockFunctionAvoidingDestroy (Abraham *); friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED.LOCKED; add: #DEFERRED; add: #COPY; yourself)! !Abraham methodsFor: 'protected: destruction'! {void} becomeStub "Replace the shepherd in memory with a type compatible stub instance that shares the same hash and flockInfo." "NOTE: Should this ensure that the flock is not dirty?" "Each subclass of Abraham will have an implementation of the form: new (this) MyStubClass()' or: 'this->changeClassToThatOf(ProtoStubClass)'" [| theHash {UInt32} info {FlockInfo} theCategory {Category} | theHash _ myHash. info _ myInfo. theCategory _ self getCategory. (ShepherdStub new.Become: self) create: theHash with: info with: theCategory] smalltalkOnly. [self unimplemented] translateOnly! {void NOFAULT NOLOCK} destruct "Called when an object is leaving RAM. Additional behavior for subclasses of Abraham: Tell the snarfPacker that I am leaving RAM and should be removed from its tables." myInfo ~~ NULL ifTrue: [CurrentPacker fluidGet dropFlock: myToken]. super destruct! {void} dismantle "Disconnect me from the universe and throw me off the disk. For GC safety, we keep a strongptr to ourself -- is this still necessary?" | spt {Abraham} packer {DiskManager} | spt _ self. [| pos {Category} | pos _ self getCategory. DismantleStatistics at: pos put: (DismantleStatistics at: pos ifAbsent: [0]) + 1] smalltalkOnly. "Tell the disk the flock is dismantled." packer _ CurrentPacker fluidGet. packer dismantleFlock: myInfo. packer flockTable at: myToken store: NULL. myInfo ~~ NULL ifTrue: [packer dropFlock: myToken].! ! !Abraham methodsFor: 'protected: disk'! {void} diskUpdate "The receiver has changed and so must eventually be rewritten to disk." myInfo == NULL ifTrue: ["Before a newShepherd." CurrentPacker fluidGet storeAlmostNewShepherd: self] ifFalse: [CurrentPacker fluidGet diskUpdate: myInfo]! {void NOFAULT} forget "Record on disk that there are no more persistent pointers to the receiver. When the in core pointers go away, the receiver can be dismantled from disk. That will happen eventually." CurrentPacker fluidGet forgetFlock: myInfo! {void NOFAULT} newShepherd "The receiver has just been created. Put it on disk." CurrentPacker fluidGet storeNewFlock: self! {void NOFAULT} remember "Record that there are now persistent pointers to the receiver." CurrentPacker fluidGet rememberFlock: myInfo! ! !Abraham methodsFor: 'destruction'! {void} destroy "Tell the packer I want to go away. It will mark me as forgotten and actually dismantle me when it next exits a consistent block. This avoids Jackpotting when destroying a tree of objects." "[myToken < CurrentPacker fluidGet flockTable count ifTrue: [CurrentPacker fluidGet flockTable at: myToken store: NULL]] smalltalkOnly." CurrentPacker fluidGet destroyFlock: myInfo! ! !Abraham methodsFor: 'testing'! {UInt32 NOFAULT} actualHashForEqual ^myHash! {UInt32} contentsHash "A hash of the contents of this flock" ^self getCategory hashForEqual! {BooleanVar NOFAULT} isEqual: other {Heaper} ^self == other! {BooleanVar} isPurgeable "Return false only if the object cannot be flushed to disk. This will probably only be false for Stamps and the like that contain session level pointers." ^true! {BooleanVar NOFAULT} isShepherd "This should be replaced with an isKindOf: that first checks to see if you're asking about Abraham, and then otherwise possible faults." self hack. ^true! {BooleanVar NOFAULT} isStub "Distinguish between stubs and shepherds." ^false! {BooleanVar} isUnlocked "All manually generated subclasses are locked. Automatically defined unlocked classes will reimplement this." ^false! ! !Abraham methodsFor: 'accessing'! {FlockInfo NOFAULT} fetchInfo "Return the object that describes the state of this flock wrt disk." "This should be made protected." ^myInfo! {void NOFAULT} flockInfo: info {FlockInfo} "Set the object that knows where this flock is on disk. Change it when the object moves." | flocks {WeakPtrArray} | [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. myInfo _ info. (info token ~~ myToken and: [myToken ~~ nil]) ifTrue: [Abraham returnToken: myToken]. myToken _ myInfo token. "Register when a flockInfo has been assigned." flocks _ CurrentPacker fluidGet flockTable. myToken ~~ nil ifTrue: [myToken >= flocks count ifTrue: ["Grow if necessary." CurrentPacker fluidGet flockTable: ((flocks copyGrow: myToken) cast: WeakPtrArray). flocks destroy. flocks _ CurrentPacker fluidGet flockTable]] ifFalse: [[self halt] smalltalkOnly]. flocks at: myToken store: self. myInfo registerInfo! {FlockInfo NOFAULT} getInfo "Return the object that describes the state of this flock wrt disk." myInfo == NULL ifTrue: [Heaper BLAST: #MustBeInitialized]. [(myInfo class == DeletedHeaper) ifTrue: [self error: 'info was deleted']] smalltalkOnly. ^myInfo! {Category NOFAULT} getShepherdStubCategory "Return the category of stubs used for the receiver. Shepherd Patriarch classes reimplement this to use more specific Stub types." [^ShepherdStub] smalltalkOnly. ' BLAST(SHEPHERD_HAS_NO_STUB_DEFINED); return NULL;' translateOnly! {Int32 NOFAULT} token "Return the object that describes the state of this flock wrt disk." myToken == nil ifTrue: [[self halt] smalltalkOnly. myToken _ TheTokenSource takeToken ]. ^myToken! ! !Abraham methodsFor: 'protected: create'! create "New Shepherds must be stored to disk." super create. myHash _ CurrentPacker fluidGet nextHashForEqual. "Start out remembered, changing to forgotten. They also start out as if they were on disk (newShepherd must be called to make it so. This prevents intermediate diskUpdates from forcing a new object to disk before creation is finished." self restartAbraham! create.ShepFlag: ignored {ShepFlag var unused} with: hash {UInt32} with: info {FlockInfo} "This is the root of the automatically generated constructors for creating Stubs." super create. myHash _ hash. [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. self restartAbraham. info ~~ NULL ifTrue: [self flockInfo: info]! {INLINE} create: hash {UInt32} "This is for shepherds that are becoming from another shepherd." super create. self thingToDo. "Change my callers to use Abraham::Abraham(UInt32,APTR(FlockInfo)). The flockInfo should be restored at the Abraham level instead of below. This also more likely causes the type checker to catch inappropriate become-constructor use" myHash _ hash. self restartAbraham! ! !Abraham methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartAbraham: trans {Rcvr unused default: NULL} myToken _ TheTokenSource takeToken. myToken == nil ifTrue: [self halt] smalltalkOnly. myInfo _ NULL.! ! !Abraham methodsFor: 'smalltalk: only'! create: hash {UInt32} with: info {FlockInfo} "This is for ShepherdStubs that use the hash and forgetFlag from the object for which they are stubbing." super create. myHash _ hash. [info class == DeletedHeaper ifTrue: [self halt]] smalltalkOnly. self flockInfo: info.! {BooleanVar} isKindOf: cat {Category} "Optimized for Abraham because xcvrs use it so much." ^cat == Abraham or: [super isKindOf: cat]! {void} restartAbraham self restartAbraham: NULL! ! !Abraham methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHash _ receiver receiveUInt32. self restartAbraham: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myHash.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Abraham class instanceVariableNames: ''! (Abraham getOrMakeCxxClassDescription) friends: 'friend class SnarfPacker; friend class TestPacker; friend class FakePacker; friend class SnarfRecord; friend class SnarfHandler; friend void unlockFunctionAvoidingDestroy (Abraham *); friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED.LOCKED; add: #DEFERRED; add: #COPY; yourself)! !Abraham class methodsFor: 'smalltalk: utilities'! dismantleStatistics ^DismantleStatistics! ! !Abraham class methodsFor: 'smalltalk: cleanup'! cleanupGarbage self linkTimeNonInherited! ! !Abraham class methodsFor: 'smalltalk: initialization'! initTimeNonInherited [DismantleStatistics _ IdentityDictionary new] smalltalkOnly. [self mayBecome: ShepherdStub] smalltalkOnly. TheTokenSource _ TokenSource make.! linkTimeNonInherited TheTokenSource _ NULL! staticTimeNonInherited BooleanVar defineFluid: #InsideTransactionFlag with: DiskManager emulsion with: [false].! ! !Abraham class methodsFor: 'global: functions'! {BooleanVar INLINE} isConstructed: obj {Heaper} ^obj ~~ NULL and: [obj getCategory ~~ DeletedHeaper]! {BooleanVar INLINE} isDestructed: obj {Heaper} ^obj == NULL or: [obj getCategory == DeletedHeaper]! ! !Abraham class methodsFor: 'tokens'! {Abraham} fetchShepherd: token {Int32} | table {PtrArray} | table := CurrentPacker fluidGet flockTable. token < table count ifTrue: [^(table fetch: token) cast: Abraham] ifFalse: [^NULL]! {void} returnToken: token {Int32} TheTokenSource returnToken: token! !Abraham subclass: #AgendaItem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! AgendaItem comment: 'A persistent representation of things that still need to be done. Can think of it like a persistent process record. "schedule"ing me ensures that I will be stepped eventually, and repeatedly, until step returns FALSE, even if the process should crash after I am scheduled. Scheduling me so that I am persistent may happen inside some other consistent block, however I will be stepped while outside of any consistent block (The FakePacker doesn''t do this yet). Creating an AgendaItem does not imply that it is scheduled, the client must explicitly schedule it as well. Destroying it *does* ensure that it gets unscheduled, though it is valid & safe to destroy one which isn''t scheduled. NOTE: Right now there are no fairness guarantees (and there may never be), so all AgendaItems must eventually terminate in order for other things (like the ServerLoop) to be guaranteed of eventually executing'! (AgendaItem getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !AgendaItem methodsFor: 'accessing'! {void} forgetYourself "forget is protected. This method exposes it for AgendaItems" self forget! {void} rememberYourself "remember is protected. This method exposes it for AgendaItems" self remember! {void} schedule "Registers me with the top level Agenda, so that I will eventually get stepped. Also causes me to be remembered." [[self step] whileTrue] smalltalkOnly. "for debugging" CurrentPacker fluidGet getInitialFlock getAgenda registerItem: self! {BooleanVar} step "Return FALSE when there's nothing left to do (at which time I should usually be unregistered and destroyed, but see Agenda::step())" self thingToDo. "Change to return {AgendaItem (self or other) | NULL} and rename the message to fetchNextStep or the like. If we do this, we must remember that collapsing items must be just an optimization, because they can be stepped even after returning something else." self subclassResponsibility! {void} unschedule "Unregisters me with the top level Agenda, so that I am no longer scheduled to get stepped. Also causes me to be forgotten." CurrentPacker fluidGet getInitialFlock getAgenda unregisterItem: self! ! !AgendaItem methodsFor: 'protected: creation'! create "Not so special constructor for not becoming this class" super create! create: hash {UInt32} "Special constructor for becoming this class" super create: hash! {void} dismantle DiskManager consistent: 2 with: [self unschedule. super dismantle]! {void} newShepherd "All AgendaItems use explicit deletion semantics." "?????" super newShepherd.! ! !AgendaItem methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !AgendaItem subclass: #Agenda instanceVariableNames: 'myToDoList {MuSet of: AgendaItem}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Agenda comment: 'An AgendaItem composed of other AgendaItems. My stepping action consists of stepping one of my component items. When I exhaust a component item, I unregister and destroy it. Note: The order in which I select a component item is currently unspecified and uncontrolled (depending on "MuSet::stepper()"). Eventually, it may make sense for me to use the Escalator Algorithm to do prioritized scheduling. Empty Agendas are also made as do-nothing AgendaItems. The currently get duely get scheduled, stepped, and unscheduled. A possible optimization would be to avoid scheduling do-nothing AgendaItems.'! (Agenda getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Agenda methodsFor: 'accessing'! {void} registerItem: item {AgendaItem} "By registering the item, we ensure that if we crash and reboot, the item will be eventually and repeatedly stepped until step returns FALSE, provided we are registered up through the Turtle. Do NOT multiply register the same item." DiskManager consistent: 2 with: [myToDoList introduce: item. "Why did we once have a 'bug?' annotation that this introduce needs to preceed the rememberYourself?" item rememberYourself. self diskUpdate]! {BooleanVar} step "'step' one of my component items. If I return FALSE, that means there's nothing currently left to do. However, since more AgendaItems may get registered later, there may later be something more for me to do, so I shouldn't necessarily be destroyed. This creates a composition problem: If an Agenda is stored as an item within another Agenda, then when the outer Agenda is stepped and it in turn steps the inner Agenda, if the inner Agenda returns FALSE, the outer Agenda will destroy it. This is all legal and shouldn't be a problem as long as one is aware of this behavior" | item {AgendaItem | NULL} stomp {Stepper} | "fetch some one item from myToDOList by creating a stepper, fetching with it, and destroying the stepper. If there were no items left return, telling the caller that there is nothing left to do. (We may do this repeatedly...) step the item. if it returned false unregister the item atomically destroy it (nuke it?) return whether there are any more things to do." item _ (stomp _ myToDoList stepper) fetch cast: AgendaItem. stomp destroy. self thingToDo. "The above code is n-squared. It should probably be fixed up during tuning." item == NULL ifTrue: [^false]. item step ifFalse: [self unregisterItem: item. DiskManager consistent: 2 with: [item destroy. self thingToDo. "find out if the consistent block is necessary/appropriate"]]. ^myToDoList isEmpty not! {void} unregisterItem: item {AgendaItem} "An item should be unregistered either when it is done (when 'step' returns FALSE) or when it no longer represents something that needs to be done should we crash and reboot. Unregistering an item which is not registered and already forgotten is legal and has no effect." DiskManager consistent: 2 with: [myToDoList wipe: item. item forgetYourself. self diskUpdate]! ! !Agenda methodsFor: 'creation'! create super create. myToDoList _ MuSet make. self knownBug. "A MuSet may become too big to fit within a snarf. However, GrandHashSets spawn AgendaItems and force propogating consistent block counts up through anything else that uses them." self newShepherd! {void} dismantle myToDoList stepper forEach: [:each {AgendaItem} | self unregisterItem: each. each destroy]. DiskManager consistent: 2 with: [myToDoList destroy. super dismantle]! ! !Agenda methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myToDoList _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myToDoList.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Agenda class instanceVariableNames: ''! (Agenda getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Agenda class methodsFor: 'creation'! make self thingToDo. "see class comment for optimization possibility" DiskManager consistent: 1 with: [^self create]! !AgendaItem subclass: #GrandNodeDoubler instanceVariableNames: 'myNode {GrandNode | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-grantab'! GrandNodeDoubler comment: 'GrandNodeDoubler performs the page splitting required for the extensible GrandHashs in a deferred fashion.'! (GrandNodeDoubler getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeDoubler methodsFor: 'protected: creation'! create: gNode {GrandNode} super create. myNode _ gNode. self newShepherd.! ! !GrandNodeDoubler methodsFor: 'accessing'! {BooleanVar} step myNode ~~ NULL ifTrue: [DiskManager consistent: myNode doubleNodeConsistency + 2 with: [myNode doubleNode. myNode _ NULL. self diskUpdate]]. ^ false! ! !GrandNodeDoubler methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNode _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myNode.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNodeDoubler class instanceVariableNames: ''! (GrandNodeDoubler getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeDoubler class methodsFor: 'creation'! make: gNode {GrandNode} DiskManager consistent: 1 with: [ ^ GrandNodeDoubler create: gNode]! !AgendaItem subclass: #GrandNodeReinserter instanceVariableNames: ' myNode {GrandNode | NULL} myOverflow {GrandOverflow}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-grantab'! GrandNodeReinserter comment: 'GrandNodeReinserter moves the contents of the GrandOverflow structure into the newly doubled GrandNode.'! (GrandNodeReinserter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeReinserter methodsFor: 'protected: creation'! create: gNode {GrandNode} with: gOverflow {GrandOverflow} super create. myNode _ gNode. myOverflow _ gOverflow. myNode addReinserter. self newShepherd.! ! !GrandNodeReinserter methodsFor: 'accessing'! {BooleanVar} step myNode ~~ NULL ifTrue: [DiskManager consistent: myOverflow reinsertEntriesConsistency + 2 with: [myOverflow reinsertEntries: myNode. myNode removeReinserter. myNode _ NULL. self diskUpdate]]. ^ false! ! !GrandNodeReinserter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNode _ receiver receiveHeaper. myOverflow _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myNode. xmtr sendHeaper: myOverflow.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNodeReinserter class instanceVariableNames: ''! (GrandNodeReinserter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNodeReinserter class methodsFor: 'creation'! make: gNode {GrandNode} with: gOverflow {GrandOverflow} DiskManager consistent: 2 with: [ ^ GrandNodeReinserter create: gNode with: gOverflow]! !AgendaItem subclass: #Matcher instanceVariableNames: ' myOrglRoot {OrglRoot | NULL} myFinder {PropFinder} myFossil {RecorderFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Matcher comment: 'This is a one-shot agenda item. When doing a delayed backFollow, after the future is taken care of (by posting recorders in the Sensor Canopy), the past needs to be checked (by walking the HTree northwards filtered by the Bert Canopy). This AgendaItem is a one-shot used to remember to backFollow thru the past. (myOrglRoot == NULL when the shot has been done.)'! (Matcher getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Matcher methodsFor: 'accessing'! {BooleanVar} step | | "If myStamp is NULL We've already shot once. Do nothing. walk the HTree northwards filtered by the Bert Canopy, scheduling RecorderTriggers to record already-existing matching stamps. ('past' part of backfollow) Remember that we're done." myOrglRoot == NULL ifTrue: [^false]. myFossil reanimate: [ :recorder {ResultRecorder} | myOrglRoot delayedFindMatching: myFinder with: myFossil with: recorder]. DiskManager consistent: 1 with: [myOrglRoot _ NULL. self thingToDo. "stop making sure the stamp sticks around" self diskUpdate. ^false]! ! !Matcher methodsFor: 'creation'! create: oroot {OrglRoot} with: finder {PropFinder} with: fossil {RecorderFossil} super create. myOrglRoot _ oroot. self thingToDo. "make sure the stamp sticks around. Do something like what's being done with myFossil>>addItem" myFinder _ finder. myFossil _ fossil. myFossil addItem: self. "bump refcount on myFossil" self newShepherd.! {void} dismantle DiskManager consistent: 3 with: [myFossil removeItem: self. "Unbump refcount on myFossil." self thingToDo. "stop making sure the OrglRoot sticks around. AgendaItems may be aborted by the enclosing algorithm, so can't assume I dropped my reference by stepping." super dismantle]! ! !Matcher methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrglRoot _ receiver receiveHeaper. myFinder _ receiver receiveHeaper. myFossil _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrglRoot. xmtr sendHeaper: myFinder. xmtr sendHeaper: myFossil.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Matcher class instanceVariableNames: ''! (Matcher getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Matcher class methodsFor: 'creation'! make: oroot {OrglRoot} with: finder {PropFinder} with: fossil {RecorderFossil} DiskManager consistent: 2 with: [^self create: oroot with: finder with: fossil]! !AgendaItem subclass: #NorthRecorderChecker instanceVariableNames: ' myEdition {BeEdition} myFinder {PropFinder}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! NorthRecorderChecker comment: 'This is a one-shot agenda item. See comment in SouthRecorderChecker for constraints and relationships to other pieces of the algorithm. Looks for and triggers WorkRecorders lying northward of this Edition up to the next Edition. The Finder should only be carrying around Works.'! (NorthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !NorthRecorderChecker methodsFor: 'accessing'! {BooleanVar} step Ravi knownBug. "if my WorkRecorders have been hoisted they will not be found; there needs to be a way to walk north in the sensor canopy until we pass an edition boundary" myEdition == NULL ifFalse: [Ravi thingToDo. "Make this work" "myEdition sensorCrum fetchNextAfterTriggeringRecorders: myFinder with: NULL." DiskManager consistent: 1 with: [myEdition := NULL. self thingToDo. "stop making sure the edition sticks around" self diskUpdate]]. ^false! ! !NorthRecorderChecker methodsFor: 'create'! create: edition {BeEdition} with: finder {PropFinder} super create. myEdition := edition. myFinder := finder. self newShepherd.! ! !NorthRecorderChecker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEdition _ receiver receiveHeaper. myFinder _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEdition. xmtr sendHeaper: myFinder.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NorthRecorderChecker class instanceVariableNames: ''! (NorthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !NorthRecorderChecker class methodsFor: 'create'! {AgendaItem} make: edition {BeEdition} with: finder {PropFinder} ^self create: edition with: finder! !AgendaItem subclass: #PropChanger instanceVariableNames: 'myCrum {CanopyCrum | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! PropChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (PropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !PropChanger methodsFor: 'protected: accessing'! {CanopyCrum | NULL} fetchCrum ^myCrum! {void} setCrum: aCrum {CanopyCrum | NULL} "Move our placeholding finger to a new crum, updating refcounts accordingly" | | "atomically (though we've probably already gone nuclear) If there is a new crum bump its refcount. If there is an old crum unbump its refcount. Remember the new crum." DiskManager consistent: 3 with: [aCrum ~~ NULL ifTrue: [aCrum addPointer: self]. myCrum ~~ NULL ifTrue: [myCrum removePointer: self]. myCrum := aCrum. self diskUpdate].! ! !PropChanger methodsFor: 'accessing'! {BooleanVar} step "propagate some prop(erty) change one step parentwards, until it gets to a local root or no further propagation in necessary." self subclassResponsibility! ! !PropChanger methodsFor: 'creation'! create: crum {CanopyCrum | NULL} super create. myCrum _ crum. myCrum == NULL ifTrue: [myCrum addPointer: self].! create: crum {CanopyCrum | NULL} with: hash {UInt32} "Special constructor for becoming this class" super create: hash. myCrum _ crum. "I don't 'myCrum addPointer: self' because, in becoming, my old self is presumed to already have pointed at the crum"! {void} dismantle DiskManager consistent: 2 with: [myCrum ~~ NULL ifTrue: [myCrum removePointer: self. myCrum _ NULL]. super dismantle]! ! !PropChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PropChanger class instanceVariableNames: ''! (PropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !PropChanger class methodsFor: 'creation'! {PropChanger} height: crum {CanopyCrum | NULL} DiskManager consistent: 3 with: [^HeightChanger create: crum]! make: crum {CanopyCrum | NULL} DiskManager consistent: 2 with: [^ActualPropChanger create: crum]! ! !PropChanger class methodsFor: 'smalltalk: suspended'! make: crum {CanopyCrum | NULL} with: change {PropChange} self suspended. self thingToDo. " Separate out different things to be propagatated into different PropChanger-like classes." DiskManager consistent: 3 with: [^ActualPropChanger create: crum with: change]! !PropChanger subclass: #ActualPropChanger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! ActualPropChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (ActualPropChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !ActualPropChanger methodsFor: 'creation'! create: crum {CanopyCrum} super create: crum. self newShepherd.! create: crum {CanopyCrum | NULL} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: crum with: hash. self flockInfo: info. self diskUpdate.! ! !ActualPropChanger methodsFor: 'accessing'! {BooleanVar} step | | "If I'm done Stop me before I step again!!. atomically Do one step of property changing. If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [(self fetchCrum changeCanopy) ifTrue: [self setCrum: self fetchCrum fetchParent] ifFalse: [self setCrum: NULL]]. ^self fetchCrum ~~ NULL! ! !ActualPropChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !PropChanger subclass: #HeightChanger instanceVariableNames: 'myChange {PropChange}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! HeightChanger comment: 'Used to propagate some prop(erty) change rootwards in some canopy. Each step propagates it one step parentwards, until it gets to a local root or no further propagation in necessary.'! (HeightChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !HeightChanger methodsFor: 'creation'! create: crum {CanopyCrum} super create: crum. self newShepherd.! create: crum {CanopyCrum | NULL} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: crum with: hash. self flockInfo: info. self diskUpdate.! ! !HeightChanger methodsFor: 'accessing'! {BooleanVar} step | | "If I'm done Stop me before I step again!!. atomically Do one step of height recalculation. If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [self fetchCrum changeHeight ifTrue: [self setCrum: self fetchCrum fetchParent] ifFalse: [self setCrum: NULL]]. ^self fetchCrum ~~ NULL! ! !HeightChanger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myChange _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myChange.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeightChanger class instanceVariableNames: ''! (HeightChanger getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !HeightChanger class methodsFor: 'creation'! make: crum {CanopyCrum} with: change {PropChange unused} self knownBug. "BOGUS" DiskManager consistent: 3 with: [^self create: crum]! !PropChanger subclass: #RecorderHoister instanceVariableNames: 'myCargo {MuSet of: TransclusionFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! RecorderHoister comment: ' NOT.A.TYPE I exist to hoist myCargo (a set of recorder fossils) up the Sensor canopy as far as it needs to go, as well as to propogate the props resulting from the planting of these recorders. When I no longer have any cargo to hoist, I devolve into an ActualPropChanger I assume that RecorderCheckers do their southward walk in a single step, so I can hoist recorders by an algorithm that would occasionally cause a recorder to be missed if RecorderCheckers were incremental.'! (RecorderHoister getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #(MAY.BECOME ActualPropChanger ); add: #CONCRETE; yourself)! !RecorderHoister methodsFor: 'creation'! create: crum {CanopyCrum} with: aSetOfRecorders {MuSet of: RecorderFossil} super create: crum. myCargo _ aSetOfRecorders. self newShepherd.! ! !RecorderHoister methodsFor: 'accessing'! {BooleanVar} step | | "See class comment for a constraint I impose on another class. If I'm done Stop me before I step again!!. atomically Do one step of property changing (and/or height recalculation until that's moved to HeightChanger). If more needs to be done, step rootward. (myCrum is set to NULL if I am the root.) else I'm done. Remember it by setting myCrum to NULL return a flag saying whether I'm done" self thingToDo. "update comment after we move height calculation to HeightChanger>>step" self fetchCrum == NULL ifTrue: [^false]. DiskManager consistent: 3 with: [ | crum {CanopyCrum | NULL} propsChangedFlag {BooleanVar} | crum := self fetchCrum fetchParent. propsChangedFlag := self fetchCrum changeCanopy. "All the updating of myPropJoint that's needed even though I hoist recorders into my parent below, since hoisting cannot change what myPropJoint needs to be." self setCrum: crum. crum == NULL ifTrue: [^false]. myCargo restrictTo: (crum fetchChild1 cast: SensorCrum) recorders; restrictTo: (crum fetchChild2 cast: SensorCrum) recorders. self diskUpdate. myCargo isEmpty ifTrue: [| hash {UInt32} info {FlockInfo} | propsChangedFlag ifFalse: [self setCrum: NULL. ^false]. myCargo destroy. "Normally done by destruct, but here we do it directly because we're about to become something" hash _ self hashForEqual. info _ self fetchInfo. (ActualPropChanger new.Become: self) create: crum with: hash with: info. "the special purpose constructor will not do a 'crum->addPointer(this)' so we don't have to undo it" ^true]. "If we reach this point, we have cargo to hoist." (crum fetchChild1 cast: SensorCrum) removeRecorders: myCargo asImmuSet. (crum fetchChild2 cast: SensorCrum) removeRecorders: myCargo asImmuSet. myCargo wipeAll: (crum cast: SensorCrum) recorders. myCargo isEmpty ifTrue: [propsChangedFlag ifFalse: [self setCrum: NULL]. ^propsChangedFlag] ifFalse: [(crum cast: SensorCrum) installRecorders: myCargo asImmuSet. crum diskUpdate]]. ^true! ! !RecorderHoister methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCargo _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCargo.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderHoister class instanceVariableNames: ''! (RecorderHoister getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #(MAY.BECOME ActualPropChanger ); add: #CONCRETE; yourself)! !RecorderHoister class methodsFor: 'creation'! {AgendaItem} make: crum {CanopyCrum} with: aSetOfRecorders {ScruSet of: RecorderFossil} "Create a RecorderHoister." aSetOfRecorders isEmpty ifTrue: [^Agenda make]. DiskManager consistent: 1 with: [^self create: crum with: aSetOfRecorders asMuSet]! !AgendaItem subclass: #RecorderTrigger instanceVariableNames: ' myFossil {RecorderFossil | NULL} myElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! RecorderTrigger comment: 'This is a one-shot agenda item. Asks myFossil to record myElement. When an answer to a delayed backFollow is found, whether thru a northwards h-walk (filtered by the Bert Canopy) of a southwards o-walk (filtered by the Sensor Canopy), instead of actually recording the answer into the backFollow trail immediately, we shedule a RecorderTrigger to do the job.'! (RecorderTrigger getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !RecorderTrigger methodsFor: 'accessing'! {BooleanVar} step || "If null pointer to myFossil We've already shot once. Do nothing. If myFossil is still in suspension Inform myFossil with myElement Atomically Remove refcount from ourself on myFossil. Remember that we're done." myFossil == NULL ifTrue: [^false]. myFossil isExtinct ifFalse: [myFossil reanimate: [:recorder {ResultRecorder} | recorder record: myElement]]. DiskManager consistent: 2 with: [myFossil removeItem: self. myFossil _ NULL. self thingToDo. "stop making sure the Edition doesn't go away; it needs a refcount or something like it." self diskUpdate. ^false].! ! !RecorderTrigger methodsFor: 'creation'! create: fossil {RecorderFossil} with: element {BeRangeElement} super create. myFossil _ fossil. myFossil addItem: self. myElement _ element. self thingToDo. "make sure the RangeElement doesn't go away" self newShepherd.! {void} dismantle DiskManager consistent: 2 with: [myFossil ~~ NULL ifTrue: [myFossil removeItem: self. myFossil _ NULL]. self thingToDo. "stop making sure the stamp doesn't go away" super dismantle]! ! !RecorderTrigger methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFossil _ receiver receiveHeaper. myElement _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFossil. xmtr sendHeaper: myElement.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderTrigger class instanceVariableNames: ''! (RecorderTrigger getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !RecorderTrigger class methodsFor: 'creation'! make: fossil {RecorderFossil} with: element {BeRangeElement} DiskManager consistent: 2 with: [^self create: fossil with: element]! !AgendaItem subclass: #Sequencer instanceVariableNames: ' myFirst {AgendaItem | NULL} myRest {AgendaItem}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! Sequencer comment: 'An AgendaItem composed of two other AgendaItems. Used for when all of the first needs to be done before any of the second may be done. My stepping action consists of stepping myFirst. When it is exhausted, I destroy it and then start stepping myRest'! (Sequencer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !Sequencer methodsFor: 'protected: creation'! create: first {AgendaItem} with: rest {AgendaItem} super create. myFirst _ first. myRest _ rest. first rememberYourself. rest rememberYourself. self newShepherd.! ! !Sequencer methodsFor: 'accessing'! {BooleanVar} step myFirst == NULL ifTrue: [^myRest step] ifFalse: [myFirst step ifFalse: [DiskManager consistent: 2 with: [myFirst destroy. myFirst _ NULL. self diskUpdate]]. ^true]! ! !Sequencer methodsFor: 'creation'! {void} dismantle DiskManager consistent: 3 with: [myFirst ~~ NULL ifTrue: [myFirst destroy]. myRest destroy. super dismantle]! ! !Sequencer methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFirst _ receiver receiveHeaper. myRest _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFirst. xmtr sendHeaper: myRest.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Sequencer class instanceVariableNames: ''! (Sequencer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !Sequencer class methodsFor: 'creation'! {AgendaItem} make: first {AgendaItem} with: rest {AgendaItem} DiskManager consistent: 3 with: [^self create: first with: rest]! !AgendaItem subclass: #SouthRecorderChecker instanceVariableNames: ' myORoot {OrglRoot | NULL} myFinder {PropFinder} mySCrum {SensorCrum | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-turtle'! SouthRecorderChecker comment: 'This is a one-shot agenda item. When changing the prop(ertie)s of a Stamp, we need to first take care of the future backFollow requests (by updating the Bert Canopy so the filtered HTree walk will find this Stamp) before taking care of the past (the Recorders that were looking for this Stamp in their future). This AgendaItem is to remember to take care of the past (by doing a southwards o-walk filtered by the Sensor Canopy) after the future is properly dealt with. The RecorderHoister assumes that this southward walk is done in a single-step, so it is free to make changes in a way that, if it were interleaved with an incremental southward walk by a RecorderChecker looking for the recorder(s) being hoisted, might cause the hoisted recorder to be missed. This is also used recursively by this very o-walk to schedule a further o-walk on appropriate sub-Stamps. Keeping track of whether persistent objects are garbage-on-disk during AgendaItem processing only remains open for Stamps, except here where it also arises for an OrglRoot. The OrglRoot is itself held by a persistent Stamp, from which it can be easily obtained, so we should probably just hold onto two Stamps instead of a Stamp and an OrglRoot (so I only have to solve the "how to keep it around" problem for Stamps).'! (SouthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SouthRecorderChecker methodsFor: 'creation'! create: oroot {OrglRoot} with: finder {PropFinder} with: scrum {SensorCrum | NULL} super create. myORoot _ oroot. myFinder _ finder. self knownBug. "make sure these objects stick around. mySCrum has add/removePointer already. myStamp and myORoot need something similar. myFinder is one of my sheep and is already OK." mySCrum _ scrum. mySCrum ~~ NULL ifTrue: [mySCrum addPointer: self]. self newShepherd.! {void} dismantle DiskManager consistent: 3 with: [mySCrum ~~ NULL ifTrue: [mySCrum removePointer: self. mySCrum _ NULL]. self thingToDo. "stop making sure these objects stick around" super dismantle]! ! !SouthRecorderChecker methodsFor: 'accessing'! {BooleanVar} step | | "See class comment for a constraint on this method. If empty ORoot We've already shot once. Do nothing. Check for any recorders in the sensor canopy that need to be rung. Remember that we're done." myORoot == NULL ifTrue: [^false]. myORoot checkRecorders: myFinder with: mySCrum. DiskManager consistent: 1 with: [myORoot _ NULL. self thingToDo. "stop making sure these objects stick around" self diskUpdate. ^false]! ! !SouthRecorderChecker methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myORoot _ receiver receiveHeaper. myFinder _ receiver receiveHeaper. mySCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myORoot. xmtr sendHeaper: myFinder. xmtr sendHeaper: mySCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SouthRecorderChecker class instanceVariableNames: ''! (SouthRecorderChecker getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SouthRecorderChecker class methodsFor: 'creation'! make: oroot {OrglRoot} with: finder {PropFinder} with: scrum {SensorCrum | NULL} DiskManager consistent: 2 with: [^self create: oroot with: finder with: scrum]! ! !SouthRecorderChecker class methodsFor: 'smalltalk: passe'! make: oroot {OrglRoot} with: stamp {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! !AgendaItem subclass: #UpdateTransitiveMemberIDs instanceVariableNames: 'myClubs {MuSet of: BeClub}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! UpdateTransitiveMemberIDs comment: 'This carries on the updating of transitive member IDs for the given club.'! (UpdateTransitiveMemberIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveMemberIDs methodsFor: 'accessing'! {BooleanVar} step myClubs isEmpty ifFalse: [DiskManager consistent: 5 with: [| club {BeClub} stomp {Stepper} | club := (stomp := myClubs stepper) fetch cast: BeClub. stomp destroy. club updateTransitiveMemberIDs. myClubs remove: club. self diskUpdate]]. ^ myClubs isEmpty not! ! !UpdateTransitiveMemberIDs methodsFor: 'protected: creation'! create: clubs {MuSet of: BeClub} super create. myClubs := clubs. self newShepherd.! ! !UpdateTransitiveMemberIDs methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myClubs _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myClubs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UpdateTransitiveMemberIDs class instanceVariableNames: ''! (UpdateTransitiveMemberIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveMemberIDs class methodsFor: 'creation'! make: clubs {MuSet of: BeClub} ^ self create: clubs! !AgendaItem subclass: #UpdateTransitiveSuperClubIDs instanceVariableNames: ' myClubs {MuSet of: BeClub | NULL} myGrandMap {BeGrandMap}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! UpdateTransitiveSuperClubIDs comment: 'This carries on the updating of transitive superclass IDs for the given club.'! (UpdateTransitiveSuperClubIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveSuperClubIDs methodsFor: 'accessing'! {BooleanVar} step myClubs isEmpty ifFalse: [DiskManager consistent: 2 with: [| club {BeClub} stomp {Stepper} | club := (stomp := myClubs stepper) fetch cast: BeClub. stomp destroy. CurrentGrandMap fluidBind: myGrandMap during: [club updateTransitiveSuperClubIDs]. myClubs remove: club. self diskUpdate]]. ^ myClubs isEmpty not! ! !UpdateTransitiveSuperClubIDs methodsFor: 'protected: creation'! create: clubs {MuSet of: BeClub} with: grandMap {BeGrandMap} super create. myClubs := clubs. myGrandMap := grandMap. self newShepherd.! ! !UpdateTransitiveSuperClubIDs methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myClubs _ receiver receiveHeaper. myGrandMap _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myClubs. xmtr sendHeaper: myGrandMap.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UpdateTransitiveSuperClubIDs class instanceVariableNames: ''! (UpdateTransitiveSuperClubIDs getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !UpdateTransitiveSuperClubIDs class methodsFor: 'creation'! make: clubs {MuSet of: BeClub} with: grandMap {BeGrandMap} ^ self create: clubs with: grandMap! !Abraham subclass: #BeGrandMap instanceVariableNames: ' myIdentifier {Sequence} myGlobalIDSpace {IDSpace} myLocalIDSpaceCounter {Counter} myGlobalIDFilterSpace {FilterSpace of: IDSpace} myEndorsementSpace {CrossSpace} myEndorsementFilterSpace {FilterSpace of: CrossSpace} myIDHolders {MuTable of: ID with: IDHolder} myIDCounters {MuTable of: (Tuple of: Sequence with: IntegerPos) with: Counter} myRangeElements {MuTable of: ID with: BeRangeElement} myRangeElementIDs {MuTable of: (HeaperAsPosition of: BeRangeElement) with: IDRegion | ID} myEnt {Ent} myEmptyClubID {ID} myPublicClubID {ID} myAdminClubID {ID} myArchiveClubID {ID} myAccessClubID {ID} myClubDirectoryID {ID} myGateLockSmithEdition {BeEdition} myWrapperEndorsements {ImmuTable of: Sequence with: CrossRegion} myEndorsementFlags {PtrArray of: Tuple | CrossRegion} myPurgeable {BooleanVar NOCOPY} myGrants {BeEdition of: Club} myAcceptingConnectionsFlag {BooleanVar NOCOPY}' classVariableNames: 'BackendCount {IntegerVar smalltalk} ' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeGrandMap comment: 'Rewrite notes 3/7/92 ravi - we had decided to have myRangeElementIDs be a GrandSetTable, but for now its just a Table onto IDRegions, since that is what we have implemented right now'! (BeGrandMap getOrMakeCxxClassDescription) friends: 'friend class BackendBootMaker; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeGrandMap methodsFor: 'private: booting'! {void} clubConsistencyCheck "Check that the BeClub structure matches the Editions underneath them" Ravi thingToDo! {void} coldBoot | emptyDesc {FeEdition} emptyClub {BeClub} publicDesc {FeEdition} publicClub {BeClub} adminClub {BeClub} archiveClub {BeClub} clubNames {BeEdition} endorsements {MuTable of: Sequence and: CrossRegion} number {IntegerVar} iDSpace {IDSpace} endorseTokenWorks {BeEdition} | "set up the initial set of Clubs" myEmptyClubID := ID make: NULL with: NULL with: -1. myPublicClubID := ID make: NULL with: NULL with: -2. self thingToDo. "ensure that the following IDs are deterministic" myAdminClubID := myGlobalIDSpace newID. myArchiveClubID := myGlobalIDSpace newID. myAccessClubID := myGlobalIDSpace newID. "figure out the IDs of the Wrapper endorsement Works" endorsements := MuTable make: SequenceSpace make. number := -3. FeWrapperSpec knownWrappers stepper forEach: [ :name {Sequence} | | iD {ID} | Ravi thingToDo. "put something more descriptive here" iD := ID make: NULL with: NULL with: number. number := number - 1. endorsements at: name introduce: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myArchiveClubID asRegion with: iD asRegion) cast: PtrArray))]. myWrapperEndorsements := endorsements asImmuTable. "set up the special flag bits used by the canopy" myEndorsementFlags := PtrArray nulls: 5+10. myEndorsementFlags at: UInt32Zero store: ((endorsements get: (Sequence string: 'Text')) cast: XnRegion) theOne. myEndorsementFlags at: 1 store: ((endorsements get: (Sequence string: 'HyperLink')) cast: XnRegion) theOne. myEndorsementFlags at: 2 store: ((endorsements get: (Sequence string: 'HyperRef')) cast: XnRegion) theOne. myEndorsementFlags at: 3 store: ((endorsements get: (Sequence string: 'SingleRef')) cast: XnRegion) theOne. myEndorsementFlags at: 4 store: ((endorsements get: (Sequence string: 'MultiRef')) cast: XnRegion) theOne. "generate some IDs to use as endorsement tokens" 5 almostTo: myEndorsementFlags count do: [ :i {Int32} | myEndorsementFlags at: i store: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myGlobalIDSpace fullRegion with: myGlobalIDSpace newID asRegion) cast: PtrArray))]. CanopyCrum useEndorsementFlags: myEndorsementFlags. CurrentAuthor fluidSet: myEmptyClubID. InitialReadClub fluidSet: myPublicClubID. InitialEditClub fluidSet: myEmptyClubID. InitialOwner fluidSet: myEmptyClubID. InitialSponsor fluidSet: myEmptyClubID. Dean knownBug. "Who sponsors clubs?" emptyDesc := (self carrier: (self newEmptyEdition: SequenceSpace make)) makeFe cast: FeEdition. emptyClub := self newClub: emptyDesc with: myEmptyClubID. emptyClub setEditClub: NULL. publicDesc := (self carrier: (self newEditionWith: (Sequence string: 'ClubDescription:LockSmith') with: (self carrier: (self newDataEdition: (UInt8Array string: 'boo') with: (IntegerRegion make: IntegerVarZero with: 3) with: IntegerSpace make getAscending)))) makeFe cast: FeEdition. publicClub := self newClub: publicDesc with: myPublicClubID. publicClub setEditClub: NULL. emptyClub sponsor: (myPublicClubID asRegion cast: IDRegion). publicClub sponsor: (myPublicClubID asRegion cast: IDRegion). InitialSponsor fluidSet: myPublicClubID. InitialReadClub fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. InitialOwner fluidSet: myAdminClubID. self thingToDo. "This should probably still be the Null Club." adminClub := self newClub: publicDesc with: myAdminClubID. InitialReadClub fluidSet: myArchiveClubID. InitialEditClub fluidSet: myArchiveClubID. InitialOwner fluidSet: myArchiveClubID. archiveClub := self newClub: publicDesc with: myArchiveClubID. CurrentKeyMaster fluidSet: (FeKeyMaster make: self publicClubID). InitialReadClub fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. iDSpace := IDSpace unique. self newClub: ((self carrier: (self newEditionWith: (Sequence string: 'ClubDescription:Membership') with: (self carrier: (((self newEditionWith: iDSpace newID with: (self carrier: publicClub)) with: iDSpace newID with: (self carrier: adminClub)) with: iDSpace newID with: (self carrier: archiveClub))))) makeFe cast: FeEdition) with: myAccessClubID. InitialReadClub fluidSet: myPublicClubID. InitialSponsor fluidSet: myAdminClubID. InitialEditClub fluidSet: myAdminClubID. clubNames := (((self newEditionWith: (Sequence string: 'System Admin') with: (self carrier: adminClub)) combine: (self newEditionWith: (Sequence string: 'System Archive') with: (self carrier: archiveClub))) combine: (self newEditionWith: (Sequence string: 'Universal Null') with: (self carrier: emptyClub))) combine: (self newEditionWith: (Sequence string: 'Universal Public') with: (self carrier: publicClub)). myClubDirectoryID := self assignID: (self newWork: (FeEdition on: clubNames)). "actually create the Wrapper description Works" endorsements stepper forPositions: [ :name {Sequence} :end {CrossRegion} | Ravi thingToDo. "put something more descriptive in the Work" self at: (((end theOne cast: Tuple) coordinate: 1) cast: ID) tryIntroduce: (self newWork: (FeEdition on: (self newDataEdition: name integers with: (IntegerRegion make: IntegerVarZero with: name integers count) with: IntegerSpace make ascending)))]. "actually create the endorsement token Works" iDSpace := IDSpace unique. endorseTokenWorks := self newEmptyEdition: iDSpace. 5 almostTo: myEndorsementFlags count do: [ :i {Int32} | | work {BeWork} | work := self newWork: emptyDesc. "contents don't matter" self at: (((((myEndorsementFlags get: i) cast: CrossRegion) projection: 1) cast: IDRegion) theOne cast: ID) tryIntroduce: work. endorseTokenWorks := endorseTokenWorks with: iDSpace newID with: (self carrier: work)]. "attach & endorse them so they can be found" InitialReadClub fluidBind: myAdminClubID during: [InitialEditClub fluidBind: NULL during: [ | edition {BeEdition} | edition := (self newEditionWith: (Sequence string: 'Universal Public') with: (self carrier: publicClub)) with: (Sequence string: 'Fast Tokens') with: (self carrier: endorseTokenWorks). self newWork: (FeEdition on: edition). edition endorse: (myEndorsementSpace crossOfRegions: ((PrimSpec pointer arrayWithTwo: myEmptyClubID asRegion with: myEmptyClubID asRegion) cast: PtrArray))]]. myGateLockSmithEdition := self newDataEdition: (UInt8Array string: 'wall') with: (IntegerRegion make: IntegerVarZero with: 4) with: IntegerSpace make ascending. myGrants := self newEditionWithAll: myGlobalIDSpace fullRegion with: (self carrier: adminClub). InitialOwner fluidSet: (NULL basicCast: ID). InitialSponsor fluidSet: (NULL basicCast: ID). InitialReadClub fluidSet: myEmptyClubID. InitialEditClub fluidSet: (NULL basicCast: ID). CurrentAuthor fluidSet: (NULL basicCast: ID). CurrentKeyMaster fluidSet: (NULL basicCast: FeKeyMaster).! ! !BeGrandMap methodsFor: 'private: create'! create: identifier {Sequence} super create. DiskManager consistent: [ | counter {Counter} | self newShepherd. "newShepherd must be first in GrandMap so that it is the boot object." myPurgeable := false. "The GrandMap cannot be purged until it is explicitly allowed." myEnt := Ent make. myIdentifier := identifier. "The counters table must be setup before we try to make any IDSpaces" myIDCounters := MuTable make: (CrossSpace make: SequenceSpace make with: IntegerSpace make). counter := Counter make: 1 with: 20. myGlobalIDSpace := IDSpace make: NULL with: -1 with: counter. myIDCounters at: (Tuple two: Sequence zero with: -1 integer) introduce: counter. myLocalIDSpaceCounter := Counter make: 1 with: 256. myGlobalIDFilterSpace := FilterSpace make: (myGlobalIDSpace cast: CoordinateSpace). myEndorsementSpace := CrossSpace make: ((PrimSpec pointer arrayWithTwo: myGlobalIDSpace with: myGlobalIDSpace) cast: PtrArray). myEndorsementFilterSpace := FilterSpace make: (myEndorsementSpace cast: CoordinateSpace). myRangeElements := GrandHashTable make: myGlobalIDSpace. myIDHolders := GrandHashTable make: myGlobalIDSpace. myRangeElementIDs := GrandHashTable make: HeaperSpace make. self hack. "how does this connect" CurrentGrandMap fluidBind: self during: [self coldBoot]. self remember]. CurrentGrandMap fluidBind: self during: [self clubConsistencyCheck]. myPurgeable _ false. myAcceptingConnectionsFlag _ true.! ! !BeGrandMap methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartBeGrandMap: rcvr {Rcvr unused} myPurgeable _ false. myAcceptingConnectionsFlag _ true. CanopyCrum useEndorsementFlags: myEndorsementFlags! ! !BeGrandMap methodsFor: 'purging'! {void} bePurgeable "Allow the GrandMap to be purged. The GrandMap should NOT be used after this is called." myPurgeable := true.! {BooleanVar} isPurgeable "The Grandmap never gets purged unless explicitly allowed by calling bePurgeable." ^ myPurgeable! ! !BeGrandMap methodsFor: 'testing'! {UInt32} contentsHash ^(((((super contentsHash bitXor: myIdentifier hashForEqual) bitXor: myLocalIDSpaceCounter hashForEqual) bitXor: myEnt hashForEqual) bitXor: myEmptyClubID hashForEqual) bitXor: myPublicClubID hashForEqual) bitXor: myAdminClubID hashForEqual! ! !BeGrandMap methodsFor: 'accessing'! {void} acceptConnections: open {BooleanVar} "See FeAdminer" myAcceptingConnectionsFlag := open! {ID} assignID: value {BeRangeElement} "Remember the two way association between value and its new ID." | iD {ID} | Ravi knownBug. "what if the ID has already been assigned by the grantee?" iD _ self newID. (self at: iD tryIntroduce: value) ifFalse: [Heaper BLAST: #IDAlreadyUsed]. ^iD! {BooleanVar} at: iD {ID} tryIntroduce: value {BeRangeElement} "Remember the two way association between value and the supplied ID." (myRangeElements includesKey: iD) ifTrue: [^false]. self hack. "The number below comes frojm my memory of how big a GrandMap assign can be." DiskManager consistent: 6 with: [| hap {HeaperAsPosition} already {IDRegion | NULL} | self thingToDo. "Decide about multiple IDs" hap := HeaperAsPosition make: value. already := (myRangeElementIDs fetch: hap) cast: IDRegion. already == NULL ifTrue: [myRangeElementIDs at: hap introduce: iD asRegion] ifFalse: [(value isKindOf: BeClub) ifTrue: [Heaper BLAST: #ClubMustHaveUniqueID]. myRangeElementIDs at: hap replace: (already with: iD)]. myRangeElements at: iD introduce: value]. ^true! {ID} clubDirectoryID ^myClubDirectoryID! {FilterSpace} endorsementFilterSpace ^myEndorsementFilterSpace! {CrossSpace} endorsementSpace ^myEndorsementSpace! {BeRangeElement | NULL} fetch: iD {ID} "The actual BeRangeElement at that ID, or NULL if there is none" ^(myRangeElements fetch: iD) cast: BeRangeElement! {BeClub | NULL} fetchClub: iD {ID | NULL} "If there is a club at the given ID, return it." iD == NULL ifTrue: [^NULL]. (self get: iD) cast: BeClub into: [:club | ^club] others: []. ^NULL! {FeEdition} gateLockSmithEdition ^FeEdition on: (myGateLockSmithEdition)! {BeRangeElement} get: iD {ID} "The actual BeRangeElement at that ID, or blast if there is none" ^(myRangeElements get: iD) cast: BeRangeElement! {BeClub} getClub: iD {ID} "Get a BeClub from the GrandMap." ^(self get: iD) cast: BeClub! {FeRangeElement} getFe: iD {ID} "Get what is at the the given ID as a front end object; blast if there is nothing there" self knownBug. "This doesn't supply a label for Editions." ^(self get: iD) makeFe: NULL! {Counter} getOrMakeIDCounter: backend {Sequence | NULL} with: number {IntegerVar} "Get a canonical Counter for an IDSpace, or make a new one" | result {Counter} theBackend {Sequence} | backend ~~ NULL ifTrue: [theBackend := backend] ifFalse: [number < IntegerVarZero ifTrue: [theBackend := Sequence zero] ifFalse: [theBackend := self identifier]]. result := (myIDCounters fetch: (Tuple two: theBackend with: number integer)) cast: Counter. result == NULL ifTrue: [self thingToDo. "figure out good batching" result := Counter make: 1 with: 20. myIDCounters at: (Tuple two: theBackend with: number integer) introduce: result]. ^result! {BeIDHolder} getOrMakeIDHolder: iD {ID} "If there is already an IDHolder for the ID then return it, otherwise make one" | result {BeIDHolder} | result := (myIDHolders fetch: iD) cast: BeIDHolder. result == NULL ifTrue: ["Make one and remember it for canonicalization" CurrentPacker fluidGet consistent: 666 with: [result := BeIDHolder make: iD. myIDHolders at: iD introduce: result]]. ^result! {FilterSpace} globalIDFilterSpace "The FilterSpace on global IDSpace" ^myGlobalIDFilterSpace! {IDSpace} globalIDSpace "The global IDSpace" ^myGlobalIDSpace! {void} grant: clubID {ID} with: globalIDs {IDRegion} "See FeAdminer" | newGrants {BeEdition} | newGrants := myGrants replace: (self newEditionWithAll: globalIDs with: (self carrier: (self getClub: clubID))). DiskManager consistent: 1 with: [myGrants := newGrants. self diskUpdate]! {ID} grantAt: iD {ID} "Who has been granted authority to assign that ID" ^self iDOf: (myGrants get: iD) getOrMakeBe! {TableStepper of: ID and: IDRegion} grants: clubIDs {IDRegion | NULL} with: globalIDs {IDRegion | NULL} "See FeAdminer" | theEdition {BeEdition} | globalIDs == NULL ifTrue: [theEdition := myGrants] ifFalse: [theEdition := myGrants copy: globalIDs]. ^GrantStepper make: theEdition with: clubIDs! {Sequence} identifier ^myIdentifier! {ID} iDOf: value {BeRangeElement} "Find the ID of a BeRangeElement. Blast if there is no ID or if there is more than one" | result {IDRegion | NULL} | result := (myRangeElementIDs fetch: (HeaperAsPosition make: value)) cast: IDRegion. result == NULL ifTrue: [Heaper BLAST: #DoesNotHaveAnID]. result count == 1 ifFalse: [Heaper BLAST: #HasMultipleIDs]. ^result theOne cast: ID! {IDRegion} iDsOf: value {BeRangeElement} "Find the IDs of a BeRangeElement, whether there are none, one, or several" | result {IDRegion | NULL} | result := (myRangeElementIDs fetch: (HeaperAsPosition make: value)) cast: IDRegion. result == NULL ifTrue: [^myGlobalIDSpace emptyRegion cast: IDRegion]. ^result! {BooleanVar} isAcceptingConnections "See FeAdminer" ^myAcceptingConnectionsFlag! {ID} newID ^myGlobalIDSpace newID! {IDSpace} newIDSpace "Make a new globally unique IDSpace" ^IDSpace make: self identifier with: myLocalIDSpaceCounter increment! {ID} placeOwnerID: iD {ID} "The ID of the Club which owns whatever is at the given ID" | value {BeRangeElement} | value := self fetch: iD. value ~~ NULL ifTrue: [^value owner]. Ravi shouldImplement "Figure out who owns PlaceHolders". ^NULL "fodder"! {void} setGateLockSmithEdition: edition {FeEdition} (FeLockSmith spec certify: edition) ifFalse: [Heaper BLAST: #MustBeValidLockSmith]. myGateLockSmithEdition := edition beEdition.! {ScruTable of: Sequence with: CrossRegion} wrapperEndorsements "A mapping from wrapper names to endorsements" Ravi thingToDo."Figure out if there is a better way to do this" ^myWrapperEndorsements! ! !BeGrandMap methodsFor: 'making editions'! {BeEdition} newDataEdition: values {PrimDataArray} with: keys {XnRegion} with: ordering {OrderSpec} "Creates an Edition mapping from a Region of keys to the values in an array. The ordering specifies the correspondance between the keys and the indices in the array. The Region must have the same count as the array. You must give an owner for the newly created DataHolders." | result {OrglRoot} offset {IntegerVar} remainder {XnRegion} | keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [values count <= Ent tableSegmentMaxSize DOTasLong ifTrue: [^BeEdition make: (OrglRoot makeData: keys with: ordering with: values)]. result _ OrglRoot make.CoordinateSpace: ordering coordinateSpace. offset _ Int32Zero. remainder _ keys. [offset < values count] whileTrue: [| count {Int32} oroot {OrglRoot} array {PrimDataArray} region {XnRegion} | count _ Ent tableSegmentMaxSize DOTasLong min: values count - offset DOTasLong . array _ (values copy: count with: offset DOTasLong) cast: PrimDataArray. region _ remainder chooseMany: count with: ordering. oroot _ OrglRoot makeData: ((IntegerMapping make: offset negated) ofAll: region) with: ordering with: array. result _ result combine: (oroot transformedBy: (IntegerMapping make: offset)). remainder _ remainder minus: region. offset _ offset + count]. ^BeEdition make: result]]! {BeEdition} newEditionWith: key {Position} with: value {BeCarrier} "A single key-value mapping" [HistoryCrum] USES. Dean hack. "What should the bertCrum be?" CurrentTrace fluidBind: value rangeElement hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: value rangeElement bertCrum during: [| region {XnRegion} | region _ key asRegion. ^BeEdition make: (ActualOrglRoot make: (Loaf make.Region: region with: value) with: region)]]! {BeEdition} newEditionWithAll: keys {XnRegion} with: value {BeCarrier} "A single key-value mapping" Dean hack. "What should the bertCrum be?" keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. CurrentTrace fluidBind: value rangeElement hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: value rangeElement bertCrum during: [^BeEdition make: (ActualOrglRoot make: (Loaf make.Region: keys with: value) with: keys)]]! {BeEdition} newEmptyEdition: cs {CoordinateSpace} "Create an empty Edition. This should really be canonicalized." CurrentTrace fluidBind: myEnt newTrace during: [ CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 4 with: [ ^BeEdition make: (OrglRoot make.CoordinateSpace: cs)]]]! {BeEdition} newPlaceHolders: region {XnRegion} "Make an Edition with a region full of unique PlaceHolders" Ravi thingToDo. "rename to newPlaceHolders" region isEmpty ifTrue: [^self newEmptyEdition: region coordinateSpace]. CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (OrglRoot make.XnRegion: region)]]! {BeEdition} newValueEdition: values {PtrArray of: FeRangeElement} with: keys {XnRegion} with: ordering {OrderSpec} "Creates an Edition mapping from a Region of keys to the values in an array. The ordering specifies the correspondance between the keys and the indices in the array. The Region must have the same count as the array." "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" | trace {TracePosition} crum {CanopyCrum} rangeElement {BeRangeElement} | keys count ~~ values count ifTrue: [Heaper BLAST: #CountMismatch]. keys isEmpty ifTrue: [^self newEmptyEdition: keys coordinateSpace]. (values fetch: Int32Zero) notNULL: [:fe {FeRangeElement} | rangeElement _ fe getOrMakeBe] else: [Heaper BLAST: #MustNotHaveNullElements]. trace _ rangeElement hCrum hCut. crum _ rangeElement bertCrum. 1 almostTo: values count do: [:i {Int32} | (values fetch: i) notNULL: [:fe {FeRangeElement} | rangeElement _ fe getOrMakeBe] else: [Heaper BLAST: #MustNotHaveNullElements]. "Neither of these should need a consistent block." trace _ trace newSuccessorAfter: rangeElement hCrum hCut. crum _ crum computeJoin: rangeElement bertCrum]. CurrentTrace fluidBind: trace during: [CurrentBertCrum fluidBind: (crum cast: BertCrum) during: [ ^BeEdition make: (OrglRoot make: keys with: ordering with: values)]]! ! !BeGrandMap methodsFor: 'making other things'! {BeCarrier} carrier: element {BeRangeElement} "Return a carrier that has the rangeElement with a new Label if appropriate." (element isKindOf: BeEdition) ifTrue: [^BeCarrier make: self newLabel with: element] ifFalse: [^BeCarrier make: element]! {BeClub} newClub: desc {FeEdition} with: iD {ID default: NULL} "Make a new Club assigned to either iD or a generated ID id iD is NULL." | result {BeClub} | CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [result := BeClub make: desc]]. DiskManager consistent: [iD == NULL ifTrue: [self assignID: result] ifFalse: [(self at: iD tryIntroduce: result) ifFalse: [Heaper BLAST: #IllegalID]]. "If we allow multiple IDs for clubs, we'll have to do this in the grandMap." result updateTransitiveMemberIDs. result updateTransitiveSuperClubIDs]. ^result! {BeDataHolder} newDataHolder: value {PrimValue} "Make a new DataHolder with the given contents." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 1 with: [ ^BeDataHolder create: value]]]! {BeIDHolder} newIDHolder: iD {ID} "Make a new IDHolder for the given ID. Uses an existing one if it exists." | result {BeIDHolder} | result := (myIDHolders fetch: iD) cast: BeIDHolder. result == NULL ifTrue: [DiskManager consistent: [CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [result := BeIDHolder make: iD. myIDHolders at: iD introduce: result]]]]. ^result! {BeLabel} newLabel "Make a new label." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [ DiskManager consistent: 1 with: [^BeLabel create]]]! {BePlaceHolder} newPlaceHolder "Make a new PlaceHolder." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [DiskManager consistent: 3 with: [^BePlaceHolder create]]]! {BeWork} newWork: contents {FeEdition} "Make a new Work (without an ID) with the given contents. Everything else comes from the fluid environment." CurrentTrace fluidBind: myEnt newTrace during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeWork make: contents]]! ! !BeGrandMap methodsFor: 'clubs'! {ID} accessClubID ^myAccessClubID! {ID} adminClubID ^myAdminClubID! {ID} archiveClubID ^myArchiveClubID! {ID} emptyClubID ^myEmptyClubID! {ID} publicClubID ^myPublicClubID! ! !BeGrandMap methodsFor: 'smalltalk: defaults'! {BeClub} newClub: desc {FeEdition} ^self newClub: desc with: NULL! ! !BeGrandMap methodsFor: 'smalltalk: passe'! {FeRangeElement} getOrMakeFe: iD {ID} "Get what is at the the given ID as a front end object; if there is nothing there, then make the appropriate PlaceHolder" | result {BeRangeElement} | result := self fetch: iD. self knownBug. "This doesn't supply a label for Editions." result ~~ NULL ifTrue: [^result makeFe: NULL] ifFalse: [^FePlaceHolder grand: iD]! {IDSpace} iDSpace: identifier {Sequence} "Recreate an old IDSpace from externally stored numbers" self passe "IDSpace::import"! ! !BeGrandMap methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myIdentifier _ receiver receiveHeaper. myGlobalIDSpace _ receiver receiveHeaper. myLocalIDSpaceCounter _ receiver receiveHeaper. myGlobalIDFilterSpace _ receiver receiveHeaper. myEndorsementSpace _ receiver receiveHeaper. myEndorsementFilterSpace _ receiver receiveHeaper. myIDHolders _ receiver receiveHeaper. myIDCounters _ receiver receiveHeaper. myRangeElements _ receiver receiveHeaper. myRangeElementIDs _ receiver receiveHeaper. myEnt _ receiver receiveHeaper. myEmptyClubID _ receiver receiveHeaper. myPublicClubID _ receiver receiveHeaper. myAdminClubID _ receiver receiveHeaper. myArchiveClubID _ receiver receiveHeaper. myAccessClubID _ receiver receiveHeaper. myClubDirectoryID _ receiver receiveHeaper. myGateLockSmithEdition _ receiver receiveHeaper. myWrapperEndorsements _ receiver receiveHeaper. myEndorsementFlags _ receiver receiveHeaper. myGrants _ receiver receiveHeaper. self restartBeGrandMap: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myIdentifier. xmtr sendHeaper: myGlobalIDSpace. xmtr sendHeaper: myLocalIDSpaceCounter. xmtr sendHeaper: myGlobalIDFilterSpace. xmtr sendHeaper: myEndorsementSpace. xmtr sendHeaper: myEndorsementFilterSpace. xmtr sendHeaper: myIDHolders. xmtr sendHeaper: myIDCounters. xmtr sendHeaper: myRangeElements. xmtr sendHeaper: myRangeElementIDs. xmtr sendHeaper: myEnt. xmtr sendHeaper: myEmptyClubID. xmtr sendHeaper: myPublicClubID. xmtr sendHeaper: myAdminClubID. xmtr sendHeaper: myArchiveClubID. xmtr sendHeaper: myAccessClubID. xmtr sendHeaper: myClubDirectoryID. xmtr sendHeaper: myGateLockSmithEdition. xmtr sendHeaper: myWrapperEndorsements. xmtr sendHeaper: myEndorsementFlags. xmtr sendHeaper: myGrants.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeGrandMap class instanceVariableNames: ''! (BeGrandMap getOrMakeCxxClassDescription) friends: 'friend class BackendBootMaker; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeGrandMap class methodsFor: 'private: pseudo constructors'! make ^self create: (Sequence two: 666 with: 42)! ! !BeGrandMap class methodsFor: 'smalltalk: init'! staticTimeNonInherited BeGrandMap defineFluid: #CurrentGrandMap with: DiskManager emulsion with: [NULL]! ! !BeGrandMap class methodsFor: 'global: time'! {IntegerVar} xuTime "Seconds since the beginning of time" self knownBug. 'return 3;' translateOnly. [^Time xuTime] smalltalkOnly! !Abraham subclass: #BeRangeElement instanceVariableNames: ' myHCrum {HUpperCrum} mySensorCrum {SensorCrum} myOwner {ID} myFeRangeElements {PrimSet NOCOPY | NULL of: FeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeRangeElement comment: 'This is the actual representation on disk; the Fe versions of these classes hide the actual representation.ó'! (BeRangeElement getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !BeRangeElement methodsFor: 'accessing'! {void} addFeRangeElement: element {FeRangeElement} "Add a new session level pointer" myFeRangeElements == NULL ifTrue: [myFeRangeElements := PrimSet weak]. myFeRangeElements introduce: element! {BooleanVar} isPurgeable ^myFeRangeElements == NULL or: [myFeRangeElements isEmpty]! {FeRangeElement} makeFe: label {BeLabel | NULL} "Make a front end object (session level) for this backend object. If the receiver is an Edition, there had better be a label." self subclassResponsibility! {BooleanVar} makeIdentical: other {BeRangeElement unused} "Change the identity of this object to that of the other. Only placeHolders implement it at the moment, so the default is to reject the operation (return false)." ^false! {ID} owner "The Club who has ownership" ^myOwner! {void} removeFeRangeElement: element {FeRangeElement} "Remove a session level pointer" (myFeRangeElements == NULL or: [(myFeRangeElements hasMember: element) not]) ifTrue: [Heaper BLAST: #NeverAddedFeRangeElement]. myFeRangeElements wipe: element. myFeRangeElements isEmpty ifTrue: [myFeRangeElements destroy. myFeRangeElements := NULL]! {void} setOwner: club {ID} "Change the Club who has ownership" DiskManager consistent: 1 with: [myOwner := club. self diskUpdate]! ! !BeRangeElement methodsFor: 'be accessing'! {void} addOParent: oparent {Loaf} "add oparent to the set of upward pointers. Editions may also have to propagate BertCrum change downward." DiskManager insistent: 5 with: [myHCrum isEmpty ifTrue: [self remember]. myHCrum addOParent: oparent. self diskUpdate]! {BooleanVar} anyPasses: finder {PropFinder} ^myHCrum anyPasses: finder! {BertCrum} bertCrum ^ myHCrum bertCrum! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "does nothing. Overrides do something."! {UInt32} contentsHash ^((super contentsHash bitXor: myHCrum hashForEqual) bitXor: mySensorCrum hashForEqual) bitXor: myOwner hashForEqual! {void} delayedStoreBackfollow: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myHCrum delayedStoreBackfollow: finder with: fossil with: recorder with: hCrumCache! {PrimSet of: FeRangeElement} feRangeElements myFeRangeElements == NULL ifTrue: [^PrimSet make] ifFalse: [^myFeRangeElements]! {HistoryCrum} hCrum ^myHCrum! {BooleanVar} inTrace: trace {TracePosition} "Return true if the receiver can backfollow to trace." ^myHCrum inTrace: trace! {Mapping} mappingTo: trace {TracePosition} with: mapping {Mapping} "return a mapping from my data to corresponding stuff in the given trace" ^myHCrum mappingTo: trace with: mapping! {void} removeOParent: oparent {OPart} "remove oparent from the set of upward pointers." myHCrum removeOParent: oparent. self diskUpdate. "myHCrum isEmpty ifTrue: [""Now we get into the risky part of deletion. myHCrum canForget iff all the downward pointers to it are gone."" self destroy]"! {SensorCrum} sensorCrum ^mySensorCrum! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !BeRangeElement methodsFor: 'protected:'! create super create. myOwner _ InitialOwner fluidGet. myHCrum _ HUpperCrum make. mySensorCrum _ SensorCrum make. myFeRangeElements _ NULL! create: sensorCrum {SensorCrum} super create. myOwner _ InitialOwner fluidGet. myHCrum _ HUpperCrum make. mySensorCrum _ sensorCrum. myFeRangeElements _ NULL! {void} dismantle DiskManager consistent: 2 with: [(Heaper isConstructed: mySensorCrum) ifTrue: [mySensorCrum removePointer: self]. ((Heaper isConstructed: myHCrum) and: [Heaper isConstructed: myHCrum bertCrum]) ifTrue: [myHCrum bertCrum removePointer: myHCrum]. myHCrum _ NULL. super dismantle]! ! !BeRangeElement methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartRE: rcvr {Rcvr unused} myFeRangeElements _ NULL! ! !BeRangeElement methodsFor: 'smalltalk:'! inspect "Sensor leftShiftDown" true ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 5 @ 10)]! ! !BeRangeElement methodsFor: 'comparing'! {BeEdition} works: permissions {IDRegion} with: endorsementsFilter {Filter} with: flags {Int32} "See comment in FeRangeElement" MarkM shouldImplement. ^NULL "fodder"! ! !BeRangeElement methodsFor: 'smalltalk: passe'! {BooleanVar} becomeOther: other {BeRangeElement} self passe "makeIdentical"! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedStoreBackfollow: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {void} storeBackfollow: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! ! !BeRangeElement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper. mySensorCrum _ receiver receiveHeaper. myOwner _ receiver receiveHeaper. self restartRE: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum. xmtr sendHeaper: mySensorCrum. xmtr sendHeaper: myOwner.! !BeRangeElement subclass: #BeDataHolder instanceVariableNames: 'myValue {PrimValue}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeDataHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeDataHolder methodsFor: 'accessing'! {FeRangeElement} makeFe: label {BeLabel | NULL} "Return me wrapped with a session level DataHolder." ^FeDataHolder on: self! {PrimValue} value ^myValue! ! !BeDataHolder methodsFor: 'create'! create: value {PrimValue} super create. myValue := value. self newShepherd! ! !BeDataHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myValue _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myValue.! !BeRangeElement subclass: #BeEdition instanceVariableNames: ' myOrglRoot {OrglRoot} myWorks {MuSet of: BeWork} myOwnProp {BertProp} myProp {BertProp} myDetectors {(PrimSet NOCOPY of: FeFillRangeDetector) | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeEdition getOrMakeCxxClassDescription) friends: 'friend class Matcher; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeEdition methodsFor: 'operations'! {BeEdition} combine: other {BeEdition} "An Edition with the contents of both Editions; where they share keys, they must have the same RangeElement." other isEmpty ifTrue: [^self]. self isEmpty ifTrue: [^other]. "Eventually trace coordinates should be delayed." [HistoryCrum] USES. [TracePosition] USES. [Ent] USES. CurrentTrace fluidBind: (self hCrum hCut newSuccessorAfter: other hCrum hCut) during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot combine: other orglRoot)]]! {BeEdition} copy: keys {XnRegion} "A new Edition with the domain restricted to the given set of keys." CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot copy: keys)]]! {BeEdition} replace: other {BeEdition} "An Edition with the contents of both Editions; where they share keys, use the contents of the other Edition. Equivalent to this->copy (other->domain ()->complement ())->combine (other)" self thingToDo. "This should be implemented directly." ^(self copy: other domain complement) combine: other! {BeEdition} transformedBy: mapping {Mapping} "An Edition with the keys transformed according to the given Mapping. Where the Mapping takes several keys in the domain to a single key in the range, this Edition must have the same RangeElement at all the domain keys." | resultRoot {OrglRoot} domain {XnRegion} | mapping cast: Dsp into: [:dsp | dsp isIdentity ifTrue: [^self]. CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: (myOrglRoot transformedBy: dsp)]]] others: ["The rest of the method"]. CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [domain _ myOrglRoot simpleDomain. resultRoot _ OrglRoot make.CoordinateSpace: mapping rangeSpace. mapping simpleMappings stepper forEach: [:simple {Mapping} | | common {XnRegion} | common _ domain intersect: simple domain. common isEmpty ifFalse: [ | dsp {Dsp} | (dsp _ simple fetchDsp) ~~ NULL ifTrue: [resultRoot _ resultRoot combine: ((myOrglRoot copy: common) transformedBy: dsp)] ifFalse: [self unimplemented]]]. ^BeEdition make: resultRoot]]! {BeEdition} with: key {Position} with: value {BeCarrier} "A new Edition with a RangeElement at a specified key. The old value, if there is one, is superceded. Equivalent to this->replace (theServer ()->makeEditionWith (key, value))" ^self replace: (CurrentGrandMap fluidGet newEditionWith: key with: value)! {BeEdition} withAll: keys {XnRegion} with: value {BeCarrier} "A new Edition with a RangeElement at a specified set of keys. The old values, if there are any, are superceded. Equivalent to this->replace (theServer ()->makeEditionWithAll (keys, value))" ^self replace: (CurrentGrandMap fluidGet newEditionWithAll: keys with: value)! {BeEdition} without: key {Position} "A new Edition without any RangeElement at a specified key. The old value, if there is one, is removed. Equivalent to this->copy (key->asRegion ()->complement ())" ^self copy: key asRegion complement! {BeEdition} withoutAll: keys {XnRegion} "A new Edition without any RangeElements at the specified keys. The old values, if there are any, are removed. Equivalent to this->copy (keys->complement ())" ^self copy: keys complement! ! !BeEdition methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "The space from which the keys of this Edition are taken. Equivalent to this->domain ()->coordinateSpace ()" ^myOrglRoot coordinateSpace! {IntegerVar} count "The number of keys in this Edition. Blasts if infinite. Equivalent to this->domain ()->count ()" ^myOrglRoot count! {XnRegion} domain "All the keys in this Edition. May be infinite, or empty." ^myOrglRoot domain! {FeRangeElement | NULL} fetch: key {Position} "Create a front end representation for what is at the given key." ^myOrglRoot fetch: key with: self! {FeRangeElement} get: key {Position} "The value at the given key, or blast if there is no such key (i.e. if !! this->domain ()->hasMember (key))." | result {FeRangeElement | NULL} | result _ self fetch: key. result == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^result! {BooleanVar} includesKey: key {Position} "Whether the given key is in the Edition. Equivalent to this->domain ()->hasMember (key)" ^(myOrglRoot fetch: key with: self) ~~ NULL! {BooleanVar} isEmpty "Whether there are any keys in this Edition. Equivalent to this->domain ()->isEmpty ()" ^myOrglRoot isEmpty! {BooleanVar} isFinite "Whether there is a finite number of keys in this Edition. Equivalent to this->domain ()->isFinite ()" ^myOrglRoot simpleDomain isFinite or: [myOrglRoot domain isFinite]! {BooleanVar} isPurgeable ^super isPurgeable and: [myDetectors == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeEdition on: self with: (FeLabel on: label)! {IDRegion} rangeOwners: positions {XnRegion default: NULL} "The owners of all the RangeElements in the given Region, or in the entire Edition if no Region is specified." ^(myOrglRoot rangeOwners: positions) cast: IDRegion! {(Stepper of: Bundle) CLIENT} retrieve: region {XnRegion default: NULL} with: order {OrderSpec default: NULL} with: flags {Int32 default: Int32Zero} "Essential. This is the fundamental retrieval operation. Return a stepper of bundles. Each bundle is an association between a region in the domain and the range elements associated with that region. Where the region is associated with data, for instance, the bundle contains a PrimArray of the data elements. If no Region is given, then reads out the whole thing." | theRegion {XnRegion} theOrder {OrderSpec} result {Accumulator} | self thingToDo. "The above comment is horribly insufficient." self thingToDo. "This desperately needs to splay the region." region == NULL ifTrue: [theRegion _ myOrglRoot simpleDomain] ifFalse: [theRegion _ region]. theRegion isEmpty ifTrue: [^Stepper emptyStepper]. order == NULL ifTrue: [theOrder := theRegion coordinateSpace getAscending] ifFalse: [theOrder := order]. "generate everything at once to avoid problems with the data structures changing as the client steps" result := Accumulator ptrArray. (myOrglRoot bundleStepper: theRegion with: theOrder) forEach: [:bundle {Heaper} | result step: bundle]. ^TableStepper ascending: (result value cast: PtrArray)! {FeRangeElement} theOne "If this Edition has a single key, then the value at that key; if not, blasts. Equivalent to this->get (this->domain ()->theOne ())" ^self get: self domain theOne! {CrossRegion} visibleEndorsements "All of the endorsements on this Edition and all Works which the CurrentKeyMaster can read." | result {XnRegion} | result := myOwnProp endorsements. myWorks stepper forEach: [ :work {BeWork} | (work canBeReadBy: CurrentKeyMaster fluidGet) ifTrue: [result := result unionWith: work endorsements]]. ^result cast: CrossRegion! ! !BeEdition methodsFor: 'props'! {void} endorse: endorsements {CrossRegion} "Adds to the endorsements on this Edition. The set of endorsements must be a finite number of (club ID, token ID) pairs." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 8 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (endorsements unionWith: myProp endorsements))]! {CrossRegion} endorsements "All of the endorsements on this Edition." ^myOwnProp endorsements cast: CrossRegion! {BertProp} prop ^myProp! {void} propChange: change {PropChange} with: nw {Prop} | old {Prop} | old _ myOwnProp. (change areEqualProps: old with: nw) not ifTrue: [DiskManager consistent: 6 with: [myOwnProp _ (change changed: old with: nw) cast: BertProp. self diskUpdate. self propChanged: change with: old with: nw]]! {void} propChanged: change {PropChange} with: old {Prop} with: nw {Prop} with: oldFinder {PropFinder default: NULL} "update props" | newProp {Prop} | "Attempt to apply the change directly to the current set of properties. If that removes some property look at all the berts to see if we get it from somewhere else. (BIG and not currently log.) If the new properties are different than the old ones we must change, so remember the current props In a consistent block change the props on the stamp change leaf of bert canopy and create an AgendaItem to propagate the chage through bert canopy fetch a finder to look for recorders rung by this change in props See if permissions decrease: If so, recorders can't be rung. Don't bother with sensor canopy, just schedule bert canopy propagation. If not make an AgendaItem to check for recorders in the sensor canopy make and schedule a Sequencer to do the bert then the sensor canopy AgendaItems." newProp _ change changed: myProp with: myOwnProp. newProp _ change with: newProp with: nw. (change areEqualProps: newProp with: (change with: newProp with: old)) not ifTrue: [myWorks stepper forEach: [:work {BeWork} | self thingToDo. "Make it log." newProp _ change with: newProp with: work localProp]]. (change areEqualProps: myProp with: newProp) ifFalse: [| before {BertProp} finder {PropFinder} changer {AgendaItem} checker {AgendaItem} | before _ myProp. DiskManager consistent: 9 with: [myProp _ (newProp cast: BertProp). self diskUpdate. changer _ myOrglRoot propChanger: change. finder _ change fetchFinder: before with: myProp with: self with: oldFinder. finder == NULL ifTrue: [changer schedule] ifFalse: [checker _ SouthRecorderChecker make: myOrglRoot with: finder with: (myOrglRoot sensorCrum fetchParent cast: SensorCrum). oldFinder == NULL ifTrue: [(Sequencer make: changer with: checker) schedule] ifFalse: [ | workChecker {AgendaItem} | workChecker := NorthRecorderChecker make: self with: finder. "the sequence of workChecker vs checker doesn't matter" (Sequencer make: changer with: (Sequencer make: workChecker with: checker)) schedule]]]]! {void} retract: endorsements {CrossRegion} "Removes endorsements from this Edition. Ignores all endorsements which you could have removed, but which don't happen to be there right now." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 4 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (myOwnProp endorsements minus: endorsements))]! {CrossRegion} totalEndorsements "All of the endorsements on this Edition and all Works directly on it" | result {XnRegion} | result := myOwnProp endorsements. myWorks stepper forEach: [ :work {BeWork} | result := result unionWith: work endorsements]. ^result cast: CrossRegion! ! !BeEdition methodsFor: 'becoming'! {void} addDetector: detect {FeFillRangeDetector} "Add a detector which will be triggered with a FeEdition when a PlaceHolder becomes a non-PlaceHolder" myDetectors == NULL ifTrue: [myDetectors := PrimSet weak: 7 with: (BeEditionDetectorExecutor make: self). self propChange: PropChange detectorWaitingChange with: BertProp detectorWaitingProp]. myDetectors introduce: detect. myOrglRoot triggerDetector: detect.! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." ^myOrglRoot ownerAt: key! {void} removeDetector: detect {FeFillRangeDetector} "Remove a previously added detector" (Heaper isDestructed: myDetectors) ifTrue: [^VOID]. myDetectors == NULL ifTrue: [Heaper BLAST: #NeverAddedDetector]. Ravi knownBug. "if we're in GC, we may be dealing with a partially unconstructed web of objects" myDetectors remove: detect. myDetectors isEmpty ifTrue: [myDetectors := NULL. self propChange: PropChange detectorWaitingChange with: BertProp make]! {void} removeLastDetector "Notify the edition that there are no remaining detectors on it." myDetectors := NULL. self propChange: PropChange detectorWaitingChange with: BertProp make! {void} ringDetectors: newIdentities {FeEdition} "Ring all my detectors with the given Edition as an argument" myDetectors ~~ NULL ifTrue: [myDetectors stepper forEach: [ :det {FeFillRangeDetector} | det rangeFilled: newIdentities]]! {BeEdition} setRangeOwners: newOwner {ID} with: region {XnRegion} "Changes the owner of all RangeElements; requires the authority of the current owner. Returns the subset of this Edition whose owners did not get changed because of lack of authority." self knownBug. "Must be a loop in ServerLoop." self thingToDo. "propagate region down through the algorithm?" CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [^BeEdition make: ((myOrglRoot copy: region) setAllOwners: newOwner)]]! {Pair of: BeEdition} tryAllBecome: newIdentities {BeEdition} "Change the identities of the RangeElements of this Edition to those at the same key in the other Edition. The left piece of the result contains those object which are know to not be able to become, because of - lack of ownership authority - different contents - incompatible types - no corresponding new identity The right piece of the result is NULL if there is nothing more that might be done, or else the remainder of the receiver on which we might be able to proceed. This material might fail at a later time because of any of the reasons above; or it might succeed , even though it failed this time because of - synchronization problem - just didn't feel like it This is always required to make progress if it can, although it isn't required to make all the progress that it might. Returns right=NULL when it can't make further progress." Dean shouldImplement. ^NULL "fodder"! ! !BeEdition methodsFor: 'labelling'! {XnRegion} keysLabelled: label {BeLabel} "The keys in this Edition at which there are Editions with the given label." ^myOrglRoot keysLabelled: label! {BeEdition} rebind: key {Position} with: edition {BeEdition} "Replace the Edition at the given key, leaving the Label the same. Equivalent to this->store (key, edition->labelled (CAST(FeEdition,this->get (key))->label ()))" self mightNotImplement. ^NULL "fodder"! ! !BeEdition methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartE: rcvr {Rcvr unused} myDetectors _ NULL! ! !BeEdition methodsFor: 'protected:'! {OrglRoot} orglRoot ^myOrglRoot! ! !BeEdition methodsFor: 'be accessing'! {void} addOParent: oparent {Loaf} "add oparent to the set of upward pointers. Editions may also have to propagate BertCrum change downward." | bCrum {BertCrum} newBCrum {BertCrum} | [HistoryCrum] USES. bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) ifFalse: [myOrglRoot updateBCrumTo: newBCrum]! {BooleanVar} anyPasses: finder {PropFinder} | next {PropFinder} | next := finder findPast: self. ^next isFull or: [super anyPasses: next]! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} | newFinder {PropFinder} | "Get a new finder which remembers to check if recorders will newly find me" newFinder _ finder findPast: self. "replace endorsements with those in the prop" newFinder isEmpty ifFalse: ["keep looking down, with my stamp as the new reference point" self thingToDo. "Use the new finder to check all recorders beneath me, checking whether they record all stamps from me all the way up to the stamp passed in as an argument" Ravi knownBug. "using scrum's parent records things twice" (SouthRecorderChecker make: myOrglRoot with: newFinder with: (scrum fetchParent cast: SensorCrum)) schedule]! {ImmuSet of: BeWork} currentWorks "The Works currently on this Edition" ^myWorks asImmuSet! {BeRangeElement} getOrMakeBe: key {Position} "An actual, non-virtual FE range element at that key. Used by become operation to get something to pass into BeRangeElement::become ()" ^myOrglRoot getBe: key! {void} introduceWork: work {BeWork} "A Work has been newly revised to point at me." DiskManager consistent: [myWorks introduce: work. self diskUpdate. self propChanged: PropChange bertPropChange with: BertProp make with: work prop with: (PropChange bertPropChange fetchFinder: BertProp make with: work prop with: work with: NULL)]. (myWorks count >= 100 and: [(myWorks isKindOf: GrandHashSet) not]) ifTrue: [| newWorks {MuSet} | newWorks _ GrandHashSet make. myWorks stepper forEach: [:b {BeWork} | newWorks store: b]. DiskManager consistent: 1 with: [myWorks _ newWorks. self diskUpdate]].! {void} removeWork: work {BeWork} "The Work is no longer onto this Edition. Remove the backpointer." DiskManager consistent: [myWorks remove: work. self diskUpdate. self propChanged: PropChange bertPropChange with: work prop with: BertProp make]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myOrglRoot updateBCrumTo: newBCrum. ^true]. ^false! ! !BeEdition methodsFor: 'comparing'! {XnRegion} keysOf: value {FeRangeElement} "All of the keys in this Edition at which the given RangeElement can be found. Equivalent to this->sharedRegion (theServer ()->makeEditionWith (some position, value))" [BeGrandMap] USES. ^self sharedRegion: (CurrentGrandMap fluidGet newEditionWith: IntegerPos zero with: value carrier)! {Mapping} mapSharedTo: other {BeEdition} "A Mapping from each of the keys in this Edition to all of the keys in the other Edition which have the same RangeElement." ^myOrglRoot mapSharedTo: other hCrum hCut! {BeEdition} notSharedWith: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of this Edition whose RangeElements are not in the other Edition. Equivalent to this->copy (this->sharedRegion (other, flags)->complement ())" ^self copy: (self sharedRegion: other with: flags) complement! {XnRegion} sharedRegion: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of the keys of this Edition which have RangeElements that are in the other Edition. If both flags are false, then equivalent to this->mapSharedTo (other)->domain () If nestThis, then returns not only keys of RangeElements which are in the other, but also keys of Editions which lead to RangeElements which are in the other. If nestOther, then looks not only for RangeElements which are values of the other Edition, but also those which are values of sub-Editions of the other Edition. (This option will probably not be supported in version 1.0)" flags ~= Int32Zero ifTrue: [self unimplemented]. ^myOrglRoot sharedRegion: other hCrum hCut! {BeEdition} sharedWith: other {BeEdition} with: flags {Int32 default: Int32Zero} "The subset of this Edition whose RangeElements are in the other Edition. If the same RangeElement is in this Edition at several different keys, all keys will be in the result (provided the RangeElement is also in the other Edition). Equivalent to this->copy (this->sharedRegion (other, flags))" ^self copy: (self sharedRegion: other with: flags)! {BeEdition} works: permissions {IDRegion} with: endorsementsFilter {Filter} with: flags {Int32} | result {Accumulator} iDSpace {IDSpace} region {XnRegion} | flags = (FeEdition LOCAL.U.PRESENT.U.ONLY bitOr: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ifFalse: [^super works: permissions with: endorsementsFilter with: flags]. result := Accumulator ptrArray. myWorks stepper forEach: [ :work {BeWork} | (endorsementsFilter match: work endorsements) ifTrue: [result step: (work makeFe: NULL)]]. iDSpace := CurrentGrandMap fluidGet newIDSpace. region := (iDSpace newIDs: ((result value cast: PtrArray) count)). ^(CurrentGrandMap fluidGet newPlaceHolders: region complement) combine:(CurrentGrandMap fluidGet newValueEdition: (result value cast: PtrArray) with: region with: iDSpace ascending)! ! !BeEdition methodsFor: 'creation'! create: root {OrglRoot} super create: root sensorCrum. Dean knownBug. "this should not have the same SensorCrum as my OrglRoot" myOrglRoot _ root. myWorks _ MuSet make. "This should maybe just start out NULL." myOwnProp _ myProp _ BertProp make. myDetectors _ NULL. DiskManager consistent: 5 with: [myOrglRoot introduceEdition: self. self newShepherd]! {void} dismantle DiskManager consistent: "2 with: (need to recalculate for adding propChange)" [self propChange: PropChange bertPropChange with: BertProp make. (Heaper isConstructed: myOrglRoot) ifTrue: [myOrglRoot removeEdition: self]. myOrglRoot _ NULL. super dismantle]! ! !BeEdition methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myOrglRoot << ')'! ! !BeEdition methodsFor: 'transclusions'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} "Attach the TrailBlazer to this Edition, and return the region of partiality it is attached to" ^myOrglRoot attachTrailBlazer: blazer! {void} fossilRelease: oldGrabber {RecorderFossil} MarkM thingToDo. "myGrabbersFossil == NULL ifTrue: [Heaper BLAST: #NotGrabbed] ifFalse: [myGrabbersFossil ~~ oldGrabber ifTrue: [Heaper BLAST: #WhoIsReleasingMe] ifFalse: [DiskManager consistent: 2 with: [myGrabbersFossil := NULL. oldGrabber extinguish: self. self diskUpdate]]]"! {TrailBlazer} getOrMakeTrailBlazer "Get or make a TrailBlazer for recording results into this Edition. Blast if there is already more than one" | result {TrailBlazer} | result := myOrglRoot fetchTrailBlazer. result == NULL ifTrue: [^TrailBlazer make: self]. myOrglRoot checkTrailBlazer: result. ^result! {BeEdition} rangeTranscluders: region {XnRegion | NULL} with: directFilter {Filter} with: indirectFilter {Filter} with: flags {Int32} with: otherTrail {BeEdition | NULL} "See FeEdition" | fossil {RecorderFossil} result {BeEdition} | "Reject all the unimplemented cases. if a trail isn't given make a new one else use it as the result. Make a fossilized recorder snapshotting the current login authority filtered by the endorsementsFilter for recording into the trail Set the transclusions request in motion Return the trail" (flags bitAnd: (FeEdition DIRECT.U.CONTAINERS.U.ONLY bitOr: FeEdition LOCAL.U.PRESENT.U.ONLY) bitInvert) ~~ Int32Zero ifTrue: [self unimplemented]. otherTrail == NULL ifTrue: [result := CurrentGrandMap fluidGet newPlaceHolders: CurrentGrandMap fluidGet newIDSpace fullRegion] ifFalse: [result := otherTrail]. fossil := RecorderFossil transcluders: (flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero with: CurrentKeyMaster fluidFetch loginAuthority with: directFilter with: indirectFilter with: result getOrMakeTrailBlazer. (flags bitAnd: FeEdition LOCAL.U.PRESENT.U.ONLY) ~~ Int32Zero ifTrue: [self scheduleImmediateBackfollow: fossil with: region] ifFalse: [(flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero ifTrue: [self unimplemented]. self scheduleDelayedBackfollow: fossil with: region]. ^result! {BeEdition} rangeWorks: region {XnRegion | NULL} with: filter {Filter} with: flags {Int32} with: otherTrail {BeEdition | NULL} "See FeEdition" | fossil {RecorderFossil} result {BeEdition} | "Reject all the unimplemented cases. if a trail isn't given make a new one else use it as the result. Make a fossilized recorder snapshotting the current login authority filtered by the endorsementsFilter for recording into the trail Set the transclusions request in motion Return the trail" (flags bitAnd: (FeEdition DIRECT.U.CONTAINERS.U.ONLY bitOr: FeEdition LOCAL.U.PRESENT.U.ONLY) bitInvert) ~~ Int32Zero ifTrue: [self unimplemented]. otherTrail == NULL ifTrue: [result := CurrentGrandMap fluidGet newPlaceHolders: CurrentGrandMap fluidGet newIDSpace fullRegion] ifFalse: [result := otherTrail]. fossil := RecorderFossil works: (flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero with: CurrentKeyMaster fluidGet loginAuthority with: filter with: result getOrMakeTrailBlazer. (flags bitAnd: FeEdition LOCAL.U.PRESENT.U.ONLY) ~~ Int32Zero ifTrue: [self scheduleImmediateBackfollow: fossil with: region] ifFalse: [(flags bitAnd: FeEdition DIRECT.U.CONTAINERS.U.ONLY) ~~ Int32Zero ifTrue: [self unimplemented]. self scheduleDelayedBackfollow: fossil with: region]. ^result! {void} scheduleDelayedBackfollow: fossil {RecorderFossil} with: region {XnRegion | NULL} "Walk down orgl's O-tree (onto range elements of interest) planting pointers to a Fossil of BackfollowRecorder in the sensor canopy and collecting agenda items to propagate their endorsement and permission filtering info rootward in the sensor canopy. Create and schedule a structure of AgendaItems to: - First: Do the filtering info propagation. - Second: Find and record any currently matching stamps. This is done in this order so collection of the future part of recorder information is completed before the present part is extracted, keeping significant information from falling through the crack." | rAgents {Agenda} matcher {AgendaItem} oroot {OrglRoot} | "Create an empty Agenda. Do the walk and collect PropChangers in the new Agenda. Reanimate the Fossil long enough to make a Matcher AgendaItem from the filtering information extracted from the Fossil Make and schedule a Sequencer that first runs the Agenda that propagates filtering info, then runs the Matcher." fossil isExtinct ifTrue: [^VOID]. rAgents _ Agenda make. region == NULL ifTrue: [oroot := myOrglRoot] ifFalse: [CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [oroot := myOrglRoot copy: region]]]. oroot storeRecordingAgents: fossil with: rAgents. fossil reanimate: [:recorder {ResultRecorder} | matcher _ Matcher make: oroot with: recorder bertPropFinder with: fossil]. (Sequencer make: rAgents with: matcher) schedule! {void} scheduleImmediateBackfollow: fossil {RecorderFossil} with: region {XnRegion | NULL} "Find and record any currently matching Editions." | oroot {OrglRoot} | MarkM thingToDo. "When we are actually leaving AgendaItems on the queue, make sure that all necessary canopy propagation is done before the Matcher excutes" region == NULL ifTrue: [oroot := myOrglRoot] ifFalse: [CurrentTrace fluidBind: self hCrum hCut newSuccessor during: [CurrentBertCrum fluidBind: BertCrum make during: [oroot := myOrglRoot copy: region]]]. fossil reanimate: [:recorder {ResultRecorder} | (Matcher make: oroot with: recorder bertPropFinder with: fossil) schedule]! ! !BeEdition methodsFor: 'smalltalk: defaults'! {void} propChanged: change {PropChange} with: old {Prop} with: nw {Prop} self propChanged: change with: old with: nw with: NULL! {XnRegion} sharedRegion: other {BeEdition} ^self sharedRegion: other with: 0! ! !BeEdition methodsFor: 'smalltalk: passe'! {MuSet of: FeFillRangeDetector} detectors self passe! {BeRangeElement | NULL} fetchOrMakeBeRangeElement: key {Position} "An actual, non-virtual FE range element at that key. Used by become operation to get something to pass into BeRangeElement::become ()" self passe "no implementation, senders, or polymorphs - /ravi/10/7/92/"! {BeEdition} parcelAt: key {Position} self passe! {BeEdition} parcels self passe! {BeEdition PROXY} reorganize: oldRegion {XnRegion | NULL} with: oldOrder {OrderSpec | NULL} with: newRegion {XnRegion | NULL} with: newOrder {OrderSpec | NULL} "Rearrange the keys of this Edition to lie in the given region, with the given ordering. Equivalent to server->makeEdition (this->asArray (oldRegion, oldOrder), newRegion, newOrder, NULL), except that it doesn't require everything to be in the same zone (and is of course more efficient)." self unimplemented! {void} scheduleDelayedBackfollow: fossil {RecorderFossil} self passe! {void} scheduleImmediateBackfollow: fossil {RecorderFossil} self passe! {BeEdition} setAllOwners: newOwner {ID} self passe! {BeEdition} setAllOwners: newOwner {ID} with: region {XnRegion} self passe "setRangeOwners"! {void} unendorse: endorsements {CrossRegion} self passe "retract"! {void} wait: sensor {XnSensor} self passe! ! !BeEdition methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrglRoot _ receiver receiveHeaper. myWorks _ receiver receiveHeaper. myOwnProp _ receiver receiveHeaper. myProp _ receiver receiveHeaper. self restartE: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrglRoot. xmtr sendHeaper: myWorks. xmtr sendHeaper: myOwnProp. xmtr sendHeaper: myProp.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeEdition class instanceVariableNames: ''! (BeEdition getOrMakeCxxClassDescription) friends: 'friend class Matcher; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeEdition class methodsFor: 'creation'! make: oroot {OrglRoot} DiskManager consistent: 5 with: [^self create: oroot]! !BeRangeElement subclass: #BeIDHolder instanceVariableNames: 'myID {ID}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeIDHolder methodsFor: 'accessing'! {ID} iD ^myID! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeIDHolder on: self! ! !BeIDHolder methodsFor: 'protected: dismantle'! {void} dismantle "Does this need to clear the GrandMap table?" self unimplemented! ! !BeIDHolder methodsFor: 'protected: creation'! create: iD {ID} super create. myID _ iD. self newShepherd! ! !BeIDHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myID _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myID.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeIDHolder class instanceVariableNames: ''! (BeIDHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeIDHolder class methodsFor: 'creation'! make: iD {ID} ^ self create: iD! !BeRangeElement subclass: #BeLabel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeLabel getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeLabel methodsFor: 'accessing'! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeLabel on: self! ! !BeLabel methodsFor: 'creation'! create super create. self newShepherd. self hack. "Labels don't know when they're pointed to as labels instead of range elements, so just remember them." self remember! ! !BeLabel methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BeRangeElement subclass: #BePlaceHolder instanceVariableNames: ' myTrailBlazer {TrailBlazer | NULL} myDetectors {PrimSet NOCOPY | NULL of: FeFillDetector}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BePlaceHolder getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BePlaceHolder methodsFor: 'accessing'! {void} addDetector: detector {FeFillDetector} myDetectors == NULL ifTrue: [myDetectors := PrimSet weak: 7 with: (FillDetectorExecutor make: self)]. myDetectors store: detector! {BooleanVar} isPurgeable ^super isPurgeable and: [myDetectors == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FePlaceHolder on: self! {BooleanVar} makeIdentical: other {BeRangeElement} "Change the identity of this object to that of the other." "Make all my persistent oParents point at the other guy. make all the session level FeRangeElements point at the other guy." | oParents {ScruSet of: OPart} | oParents _ self hCrum oParents. self knownBug. "if there are several oParents then a given Detector may be rung more than once" DiskManager consistent: -1 with: [oParents stepper forEach: [:loaf {Loaf} | (loaf cast: RegionLoaf) forwardTo: other]]. self feRangeElements stepper forEach: [:elem {FePlaceHolder} | (elem cast: FeActualPlaceHolder) forwardTo: other]. myDetectors ~~ NULL ifTrue: [ | fe {FeRangeElement} | other cast: BeEdition into: [ :ed | fe := ed makeFe: CurrentGrandMap fluidGet newLabel] others: [fe := other makeFe: NULL]. myDetectors stepper forEach: [ :det {FeFillDetector} | det filled: fe]]. ^false "fodder"! {void} removeDetector: detector {FeFillDetector} (Heaper isDestructed: myDetectors) ifTrue: [^VOID]. myDetectors == NULL ifTrue: [Heaper BLAST: #NotInSet]. myDetectors remove: detector. myDetectors isEmpty ifTrue: [myDetectors := NULL].! {void} removeLastDetector myDetectors := NULL! ! !BePlaceHolder methodsFor: 'creation'! create super create: SensorCrum partial. myTrailBlazer := NULL. myDetectors := NULL. self newShepherd! create: blazer {TrailBlazer | NULL} super create: SensorCrum partial. myTrailBlazer := blazer. blazer ~~ NULL ifTrue: [blazer addReference: self]. myDetectors := NULL. self newShepherd! ! !BePlaceHolder methodsFor: 'backfollow'! {void} attachTrailBlazer: blazer {TrailBlazer} DiskManager consistent: 3 with: [myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer isAlive ifTrue: [Heaper BLAST: #FatalError] ifFalse: [myTrailBlazer removeReference: self]]. myTrailBlazer := blazer. blazer addReference: self. self diskUpdate]! {void} checkTrailBlazer: blazer {TrailBlazer} (myTrailBlazer ~~ NULL and: [myTrailBlazer isEqual: blazer]) ifFalse: [Heaper BLAST: #InvalidTrail]! {TrailBlazer | NULL} fetchTrailBlazer (myTrailBlazer == NULL or: [myTrailBlazer isAlive]) ifTrue: [^myTrailBlazer]. "it was not successfully attached, so clean it up" DiskManager consistent: 2 with: [myTrailBlazer removeReference: self. myTrailBlazer := NULL. self diskUpdate. ^NULL]! ! !BePlaceHolder methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartP: rcvr {Rcvr unused} myDetectors := NULL.! ! !BePlaceHolder methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTrailBlazer _ receiver receiveHeaper. self restartP: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTrailBlazer.! !BeRangeElement subclass: #BeWork instanceVariableNames: ' myEdition {BeEdition} myEditionLabel {BeLabel} myReadClub {ID | NULL} myEditClub {ID | NULL} myOwnProp {BertProp} myHistory {BeEdition | NULL} myHistoryClub {ID | NULL} myRevisionCount {IntegerVar} myRevisionTime {IntegerVar} myReviser {ID} mySponsors {IDRegion} myLockingWork {WeakPtrArray NOCOPY of: FeWork} myRevisionWatchers {PrimSet NOCOPY | NULL of: FeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeWork comment: 'This is the actual representation on disk; the Fe versions of these classes hide the actual representation.ó'! (BeWork getOrMakeCxxClassDescription) friends: '/* friends for class BeWork */ friend class BeWorkLockExecutor;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeWork methodsFor: 'locking'! {BooleanVar} canBeEditedBy: km {FeKeyMaster} "Answer whether the KeyMaster has the authority to edit this work." ^myEditClub ~~ NULL and: [km hasAuthority: myEditClub]! {BooleanVar} canBeReadBy: km {FeKeyMaster} "Return true if the KeyMaster has the authority to read this Work." ^(myReadClub ~~ NULL and: [km hasAuthority: myReadClub]) or: [self canBeEditedBy: km]! {FeWork INLINE | NULL} fetchLockingWork "The Work which has this locked, or NULL if noone does." ^(myLockingWork fetch: Int32Zero) cast: FeWork! {FeWork} makeLockedFeWork "Make a frontend Work on me and lock it if possible." | result {FeWork} ckm {FeKeyMaster} | result := (self makeFe: NULL) cast: FeWork. ckm := CurrentKeyMaster fluidGet. (self fetchLockingWork == NULL and: [self canBeEditedBy: ckm]) ifTrue: [result grab]. ^result! {BooleanVar} tryLock: work {FeWork} "Try to lock with the give FE Work. Return TRUE if successful" | curLock {FeWork} | curLock := self fetchLockingWork. (curLock == NULL or: [curLock isEqual: work]) ifTrue: [myLockingWork at: Int32Zero store: work. ^true] ifFalse: [^false]! {BooleanVar} tryUnlock: work {FeWork} "If the given FE Work is locking, then unlock and return TRUE; else return FALSE with no change in lock state" self fetchLockingWork == work ifTrue: ["Unlock and tell everyone about the change" myLockingWork at: Int32Zero store: NULL. self updateFeStatus. ^true] ifFalse: [^false]! ! !BeWork methodsFor: 'contents'! {void} addRevisionWatcher: work {FeWork} "Tell the FE Work whenever this Work is revised" myRevisionWatchers == NULL ifTrue: [myRevisionWatchers := PrimSet weak: 7 with: (RevisionWatcherExecutor make: self)]. myRevisionWatchers introduce: work! {FeEdition} edition "The current Edition. Note: If this is an unsponsored Work, the Edition might have been discarded, and this operation will blast." self thingToDo. "Cache this" ^FeEdition on: myEdition with: (FeLabel on: myEditionLabel)! {ID} lastRevisionAuthor "The Club who made the last revision" ^myReviser! {IntegerVar} lastRevisionNumber "The sequence number of the last revision of this Work." ^myRevisionCount! {IntegerVar} lastRevisionTime "The time of the last revision of this Work." ^myRevisionTime! {void} recordHistory "Change the current edition and notify anyone who cares about the revision" | gm {BeGrandMap} | myHistoryClub == NULL ifTrue: [^VOID]. gm _ CurrentGrandMap fluidGet. "Bind all these because they not be set." InitialReadClub fluidBind: myHistoryClub during: [InitialEditClub fluidBind: gm emptyClubID during: [InitialOwner fluidBind: self owner during: [InitialSponsor fluidBind: gm emptyClubID during: "Don't sponsor the history." [| legacy {BeWork} | legacy _ gm newWork: self edition. legacy setEditClub: NULL. self thingToDo. "legacy endorse: (CurrentAuthor fluidGet with: #revised)." myHistory _ self revisions with: myRevisionCount integer with: (gm carrier: legacy)]. ]]]! {void} removeLastRevisionWatcher "Inform the work that its last revision watcher is gone." myRevisionWatchers := NULL! {void} removeRevisionWatcher: work {FeWork} "Remove a previously added RevisionWatcher" myRevisionWatchers == NULL ifTrue: [Heaper BLAST: #NeverAddedRevisionWatcher]. myRevisionWatchers remove: work. myRevisionWatchers isEmpty ifTrue: [myRevisionWatchers := NULL].! {void} revise: edition {FeEdition} "Change the current edition and notify anyone who cares about the revision" DiskManager consistent: [self knownBug. "this may not be the right thing to do when not grabbed - it only happens during booting anyway" self fetchLockingWork == NULL ifTrue: [myReviser := CurrentAuthor fluidGet] ifFalse: [myReviser _ self fetchLockingWork getAuthor]. myEdition removeWork: self. myEdition := edition beEdition. myEditionLabel _ edition label getOrMakeBe cast: BeLabel. myEdition introduceWork: self. myRevisionCount _ myRevisionCount + 1. myRevisionTime := BeGrandMap xuTime. "Trigger immediate revisionDetectors" myRevisionWatchers ~~ NULL ifTrue: [myRevisionWatchers stepper forEach: [ :work {FeWork} | work triggerRevisionDetectors: edition with: myReviser with: myRevisionTime with: myRevisionCount]]. "Record result into the trail" myHistoryClub ~~ NULL ifTrue: [self recordHistory]. self diskUpdate]! {BeEdition} revisions "If there isn't already a shared Trail on this Work, create a new one. Return it" myHistory == NULL ifTrue: [DiskManager consistent: [myHistory _ CurrentGrandMap fluidGet newEmptyEdition: IntegerSpace make. self diskUpdate]]. ^myHistory! ! !BeWork methodsFor: 'permissions'! {ID | NULL} fetchEditClub "The edit Club, or NULL if there is none" ^myEditClub! {ID | NULL} fetchHistoryClub "The history Club, or NULL if there is none" ^myHistoryClub! {ID | NULL} fetchReadClub "The read Club, or NULL if there is none" ^myReadClub! {void} setEditClub: club {ID | NULL} "Change the edit Club (or remove it if NULL)." DiskManager consistent: 1 with: [myEditClub := club. self knownBug. "props" self diskUpdate]. self updateFeStatus.! {void} setHistoryClub: club {ID | NULL} "Change the history Club (or remove it if NULL)." DiskManager consistent: [| oldClub {ID | NULL} | oldClub _ myHistoryClub. myHistoryClub := club. self knownBug. "What happens when you change the club." (oldClub == NULL and: [myHistoryClub ~~ NULL]) ifTrue: [self recordHistory]. self diskUpdate].! {void} setReadClub: club {ID | NULL} "Change the read Club (or remove it if NULL)." DiskManager consistent: [myReadClub := club. self knownBug. "props" self diskUpdate]. self updateFeStatus.! ! !BeWork methodsFor: 'props'! {void} endorse: endorsements {CrossRegion} "Adds to the endorsements on this Work. The set of endorsements must be a finite number of (club ID, token ID) pairs. This requires the authority of all of the Clubs used to endorse. The token IDs must not be named IDs." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 8 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (endorsements unionWith: myOwnProp endorsements))]! {CrossRegion} endorsements "All endorsements which have been placed on this Work. The Edition::transclusions () operation will be able to find the current Edition of this Work by filtering for these endorsements; they are also used to filter various other operations which directly return sets of Works." ^myOwnProp endorsements cast: CrossRegion! {BertProp} localProp ^myOwnProp! {BertProp} prop ^myOwnProp! {void} propChange: change {PropChange} with: nw {Prop} | old {Prop} | old _ myOwnProp. (change areEqualProps: old with: nw) not ifTrue: [myOwnProp _ (change changed: old with: nw) cast: BertProp. self diskUpdate. myEdition propChanged: change with: old with: nw with: (change fetchFinder: old with: nw with: self with: NULL)]! {void} retract: endorsements {CrossRegion} "Removes endorsements from this Work. This requires the authority of all of the Clubs whose endorsements are in the list. Ignores all endorsements which you could have removed, but which don't happen to be there right now." endorsements isEmpty ifTrue: [^VOID]. DiskManager consistent: 5 with: [self propChange: PropChange endorsementsChange with: (BertProp endorsementsProp: (myOwnProp endorsements minus: endorsements))]! ! !BeWork methodsFor: 'accessing'! {BooleanVar} isPurgeable ^super isPurgeable and: [self fetchLockingWork == NULL and: [myRevisionWatchers == NULL]]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeWork on: self! {void} sponsor: clubs {IDRegion} "Add new sponsors to the Work, and notify the Clubs" | newClubs {IDRegion} | newClubs := (clubs minus: mySponsors) cast: IDRegion. newClubs isEmpty ifFalse: [DiskManager consistent: newClubs count + 1 with: [newClubs stepper forEach: [ :clubID {ID} | (CurrentGrandMap fluidGet getClub: clubID) addSponsored: self]. mySponsors := (mySponsors unionWith: newClubs) cast: IDRegion. self diskUpdate]]! {IDRegion} sponsors ^mySponsors! {void} unsponsor: clubs {IDRegion} "Remove sponsors from the Work, and notify the Clubs" | lostClubs {IDRegion} | self thingToDo. "Remove unsponsored clubs from the grandmap." self thingToDo. "When Clubs can have multiple IDs, then it might still be in the set" lostClubs := (clubs intersect: mySponsors) cast: IDRegion. lostClubs isEmpty ifFalse: [DiskManager consistent: lostClubs count + 1 with: [lostClubs stepper forEach: [ :clubID {ID} | (CurrentGrandMap fluidGet getClub: clubID) removeSponsored: self]. mySponsors := (mySponsors minus: clubs) cast: IDRegion. self diskUpdate]]! ! !BeWork methodsFor: 'private:'! {void} updateFeStatus "Tell all the FeWorks on this one to update their status" [PrimSet] USES. self feRangeElements stepper forEach: [ :work {FeWork} | work updateStatus]! ! !BeWork methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartWork: rcvr {Rcvr unused} myLockingWork _ WeakPtrArray make: (BeWorkLockExecutor make: self) with: 1. myRevisionWatchers _ NULL! ! !BeWork methodsFor: 'smalltalk: passe'! {void} addSponsors: clubs {IDRegion} self passe "sponsor"! {void} removeSponsors: clubs {IDRegion} self passe! {void} unendorse: endorsements {CrossRegion} self passe! ! !BeWork methodsFor: 'creation'! create: contents {FeEdition} with: isClub {BooleanVar} | permissions {XnRegion} | super create. myEdition := contents beEdition. myEditionLabel _ contents label getOrMakeBe cast: BeLabel. myReadClub := InitialReadClub fluidFetch. myReadClub == NULL ifTrue: [permissions := CurrentGrandMap fluidGet globalIDSpace emptyRegion] ifFalse: [permissions := myReadClub asRegion]. myEditClub := InitialEditClub fluidFetch. myEditClub ~~ NULL ifTrue: [permissions := permissions with: myEditClub]. myOwnProp := BertProp permissionsProp: permissions. myRevisionCount _ IntegerVarZero. myRevisionTime _ Time xuTime. myReviser _ CurrentAuthor fluidGet. myHistory _ NULL. myHistoryClub _ NULL. self knownBug. "Should public shut off sponsorship?" InitialSponsor fluidGet == CurrentGrandMap fluidGet emptyClubID ifTrue: [mySponsors := IDSpace global emptyRegion cast: IDRegion] ifFalse: [mySponsors := InitialSponsor fluidFetch asRegion cast: IDRegion]. self restartWork: NULL. myEdition introduceWork: self. self knownBug. "Is the above all right?" isClub ifFalse: [self finishCreation.]! {void} finishCreation "Gets called once the object is created, to finish up" mySponsors stepper forEach: [ :iD {ID} | (CurrentGrandMap fluidGet getClub: iD) addSponsored: self]. self newShepherd.! ! !BeWork methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << (CurrentGrandMap fluidGet iDsOf: self) << ')'! ! !BeWork methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEdition _ receiver receiveHeaper. myEditionLabel _ receiver receiveHeaper. myReadClub _ receiver receiveHeaper. myEditClub _ receiver receiveHeaper. myOwnProp _ receiver receiveHeaper. myHistory _ receiver receiveHeaper. myHistoryClub _ receiver receiveHeaper. myRevisionCount _ receiver receiveIntegerVar. myRevisionTime _ receiver receiveIntegerVar. myReviser _ receiver receiveHeaper. mySponsors _ receiver receiveHeaper. self restartWork: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEdition. xmtr sendHeaper: myEditionLabel. xmtr sendHeaper: myReadClub. xmtr sendHeaper: myEditClub. xmtr sendHeaper: myOwnProp. xmtr sendHeaper: myHistory. xmtr sendHeaper: myHistoryClub. xmtr sendIntegerVar: myRevisionCount. xmtr sendIntegerVar: myRevisionTime. xmtr sendHeaper: myReviser. xmtr sendHeaper: mySponsors.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeWork class instanceVariableNames: ''! (BeWork getOrMakeCxxClassDescription) friends: '/* friends for class BeWork */ friend class BeWorkLockExecutor;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeWork class methodsFor: 'creation'! make: edition {FeEdition} DiskManager consistent: [^self create: edition with: false]! !BeWork subclass: #BeClub instanceVariableNames: ' mySignatureClub {ID | NULL} myMembers {MuSet of: BeClub} myImmediateSuperClubs {MuSet of: BeClub} mySponsored {MuSet of: BeWork} myWallFlag {BooleanVar} myTransitiveSuperClubIDs {IDRegion} myTransitiveMemberIDs {IDRegion} myKeyMasters {MuSet NOCOPY | NULL of: NuKeyMaster}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! (BeClub getOrMakeCxxClassDescription) friends: '/* friends for class BeClub */ friend class UpdateTransitiveMemberIDs; friend class UpdateTransitiveSuperClubIDs; friend class UpdateClubKeyMasterAuthorities; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeClub methodsFor: 'dependents'! {void} registerKeyMaster: km {FeKeyMaster} "Notify the KeyMaster when the transitive super Clubs of this Club change" myKeyMasters == NULL ifTrue: [myKeyMasters := MuSet make. ActiveClubs fluidGet introduce: self]. myKeyMasters introduce: km! {void} unregisterKeyMaster: km {FeKeyMaster} "Unregister a previously registered KeyMaster" myKeyMasters == NULL ifTrue: [Heaper BLAST: #NeverRegisteredKeyMaster]. myKeyMasters remove: km. myKeyMasters isEmpty ifTrue: [myKeyMasters := NULL. ActiveClubs fluidGet remove: self]! ! !BeClub methodsFor: 'accessing'! {void} addSponsored: work {BeWork} "Add a sponsored Work (sent from the Work)" DiskManager insistent: 1 with: [mySponsored store: work. self diskUpdate]! {ID | NULL} fetchSignatureClub "The Club who can endorse and sponsor with this Club" ^mySignatureClub! {BooleanVar} isPurgeable ^super isPurgeable and: [myKeyMasters == NULL]! {FeRangeElement} makeFe: label {BeLabel | NULL} ^FeClub on: self! {BooleanVar} membershipIncludes: club {BeClub} "Whether the direct membership includes the given Club" ^myMembers hasMember: club! {void} removeSponsored: work {BeWork} "Add a sponsored Work (sent from the Work)" DiskManager insistent: 1 with: [mySponsored wipe: work. self diskUpdate]! {void} setSignatureClub: clubID {ID | NULL} "Change the Club who can endorse and sponsor with this Club" mySignatureClub := clubID! {ImmuSet of: BeWork} sponsored ^mySponsored asImmuSet! {IDRegion} transitiveMemberIDs ^myTransitiveMemberIDs! {IDRegion} transitiveSuperClubIDs ^myTransitiveSuperClubIDs! ! !BeClub methodsFor: 'private: propagating'! {void} updateKeyMasters myKeyMasters ~~ NULL ifTrue: ["notify any KeyMasters who care that my transitive super clubs have changed" myKeyMasters stepper forEach: [ :km {FeKeyMaster} | km updateAuthority]]! ! !BeClub methodsFor: 'private: accessing'! {MuSet of: BeClub} immediateSuperClubs ^ myImmediateSuperClubs! {MuSet of: BeClub} members ^ myMembers! ! !BeClub methodsFor: 'contents'! {void} revise: contents {FeEdition} "Update cached information" | oldMembers {MuSet of: BeClub} oldMembership {FeEdition} newMembership {FeEdition} memberTest {BooleanVar} | (FeClubDescription check: contents) ifFalse: [Heaper BLAST: #MustBeClubDescription]. DiskManager consistent: [oldMembership := (self edition fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. super revise: contents. "Do this first so that permissions will change after the revision" newMembership := (contents fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. "Update cached info if membership changes" (oldMembership == NULL or: [oldMembership isEmpty]) ifTrue: [memberTest _ newMembership == NULL or: [newMembership isEmpty]] ifFalse: [memberTest _ newMembership ~~ NULL and: [newMembership isIdentical: oldMembership]]. memberTest ifFalse: [oldMembers := myMembers. myMembers := MuSet make. newMembership stepper forEach: [ :mem {FeWork} | myMembers introduce: (mem getOrMakeBe cast: BeClub)]. "Update all new members" (myMembers asImmuSet minus: oldMembers) stepper forEach: [ :newMem {BeClub} | newMem addImmediateSuperClub: self]. "Update all lost members" (oldMembers asImmuSet minus: myMembers) stepper forEach: [ :lostMem {BeClub} | lostMem removeImmediateSuperClub: self]. "Update self and all parents with new membership list" self updateTransitiveMemberIDs. self diskUpdate]]! ! !BeClub methodsFor: 'propagating'! {void} addImmediateSuperClub: parent {BeClub} "Add an immediate super Club and update my cached information, and those of my members" myImmediateSuperClubs store: parent. self updateTransitiveSuperClubIDs.! {void} removeImmediateSuperClub: parent {BeClub} "Add an immediate super Club and update my cached information, and those of my members" myImmediateSuperClubs remove: parent. self updateTransitiveSuperClubIDs.! {void} updateTransitiveMemberIDs "Figure out result of changes in membership, then propagate upwards" | result {XnRegion} | result := IDSpace global emptyRegion. myMembers stepper forEach: [ :mem {BeClub} | result := (result unionWith: mem transitiveMemberIDs)]. result := (result with: (CurrentGrandMap fluidGet iDOf: self)). (result isEqual: myTransitiveMemberIDs) ifFalse: [DiskManager insistent: 4 with: [myTransitiveMemberIDs := result cast: IDRegion. self diskUpdate. myImmediateSuperClubs isEmpty ifFalse: [(UpdateTransitiveMemberIDs make: myImmediateSuperClubs copy asMuSet) schedule]]]! {void} updateTransitiveSuperClubIDs "Figure out result of changes in membership, then propagate upwards" | result {XnRegion} | result := IDSpace global emptyRegion. myImmediateSuperClubs stepper forEach: [ :sup {BeClub} | result := (result unionWith: sup transitiveSuperClubIDs)]. result := (result with: (CurrentGrandMap fluidGet iDOf: self)). (result isEqual: myTransitiveSuperClubIDs) ifFalse: [DiskManager insistent: 4 with: [myTransitiveSuperClubIDs := result cast: IDRegion. self diskUpdate. myMembers isEmpty ifFalse: [(UpdateTransitiveSuperClubIDs make: myMembers copy asMuSet with: CurrentGrandMap fluidGet) schedule]]. "notify any KeyMasters who care that my transitive super clubs have changed" myKeyMasters ~~ NULL ifTrue: [myKeyMasters stepper forEach: [ :km {FeKeyMaster} | km updateAuthority]]]! ! !BeClub methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartClub: rcvr {Rcvr} myKeyMasters _ NULL! ! !BeClub methodsFor: 'creation'! create: contents {FeEdition} | membership {FeEdition} | super create: contents with: true. mySignatureClub := InitialOwner fluidGet. myMembers := MuSet make. membership := (contents fetch: (Sequence string: 'ClubDescription:Membership')) cast: FeEdition. membership ~~ NULL ifTrue: [membership stepper forEach: [ :club {FeClub} | myMembers introduce: club beClub]]. myImmediateSuperClubs := MuSet make. mySponsored := MuSet make. self knownBug. "wall flag" myWallFlag := false. myTransitiveSuperClubIDs := IDSpace global emptyRegion cast: IDRegion. myTransitiveMemberIDs := IDSpace global emptyRegion cast: IDRegion. myMembers stepper forEach: [ :mem {BeClub} | myTransitiveMemberIDs := (myTransitiveMemberIDs unionWith: mem transitiveMemberIDs) cast: IDRegion]. self restartClub: NULL. self finishCreation.! ! !BeClub methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySignatureClub _ receiver receiveHeaper. myMembers _ receiver receiveHeaper. myImmediateSuperClubs _ receiver receiveHeaper. mySponsored _ receiver receiveHeaper. myWallFlag _ receiver receiveBooleanVar. myTransitiveSuperClubIDs _ receiver receiveHeaper. myTransitiveMemberIDs _ receiver receiveHeaper. self restartClub: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySignatureClub. xmtr sendHeaper: myMembers. xmtr sendHeaper: myImmediateSuperClubs. xmtr sendHeaper: mySponsored. xmtr sendBooleanVar: myWallFlag. xmtr sendHeaper: myTransitiveSuperClubIDs. xmtr sendHeaper: myTransitiveMemberIDs.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeClub class instanceVariableNames: ''! (BeClub getOrMakeCxxClassDescription) friends: '/* friends for class BeClub */ friend class UpdateTransitiveMemberIDs; friend class UpdateTransitiveSuperClubIDs; friend class UpdateClubKeyMasterAuthorities; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BeClub class methodsFor: 'smalltalk: init'! staticTimeNonInherited BeClub defineFluid: #CurrentOwner with: ServerChunk emulsion with: [NULL]. MuSet defineFluid: #ActiveClubs with: DiskManager emulsion with: [MuSet make]! ! !BeClub class methodsFor: 'creation'! make: contents {FeEdition} DiskManager consistent: [^BeClub create: contents]! !Abraham subclass: #BranchDescription instanceVariableNames: ' lastPosition {UInt32} myLeft {BranchDescription} myRight {BranchDescription} fulltrace {DagWood}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! BranchDescription comment: 'Instances of subclasses describe the different kinds of paths in a traceDag. The three kinds are root (no parent), tree (one parent) and dag (two parent) branches. The dag caching routine chases up the dag finding the max of all paths. The special case of chasing up the hierarchy is probably not worth the code. At the moment, these never go away!!!!!!'! (BranchDescription getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !BranchDescription methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: myLeft hashForEqual) bitXor: myRight hashForEqual) bitXor: fulltrace hashForEqual! {BooleanVar} does: position {UInt32} include: tracePos {TracePosition} | mark {IntegerVar} | [PrimIndexTable] USES. mark _ (fulltrace cacheTracePos: tracePos) fetch: self. ^mark ~~ NULL and: [(Integer IntegerVar: position) <= mark]! ! !BranchDescription methodsFor: 'deferred accessing'! {void} cacheRecur: navCache {PrimIndexTable} "recur toward the root filling in the cache." self subclassResponsibility! ! !BranchDescription methodsFor: 'accessing'! {void} addSuccessorsTo: set {MuSet} "Add the first useable positions for all successor branches to the set." set store: (TracePosition make: self with: 3). myLeft ~~ NULL ifTrue: [myLeft addSuccessorsTo: set]. myRight ~~ NULL ifTrue: [myRight addSuccessorsTo: set]! {ImmuSet} successorsOf: trace {BoundedTrace} | set {MuSet} | set _ fulltrace successorsOf: trace. trace position ~~ lastPosition ifTrue: [set store: (TracePosition make: self with: trace position + 1)]. ^set asImmuSet! ! !BranchDescription methodsFor: 'position making'! {TracePosition} createAfter: trace {BoundedTrace} "Return a new successor to the receiver. The first successor is on the same branch with a higher position. Further successors are allocated in a binary-tree fashion along a new branch." lastPosition == trace position ifTrue: [^self nextPosition] ifFalse: [| branch {BranchDescription} | branch _ BranchDescription make: fulltrace with: trace. fulltrace installBranch: branch after: trace. ^branch nextPosition]! {void} installBranch: branch {BranchDescription} "Install branch as a descendant branch of myself. Walk down the binary tree of branches to find a place to lodge it. This gets called if there was already a branch existing off my root." (branch isEqual: self) ifTrue: [^VOID]. self diskUpdate. myLeft == NULL ifTrue: [myLeft _ branch] ifFalse: [| tmpBr {BranchDescription} | myLeft installBranch: branch. tmpBr _ myLeft. myLeft _ myRight. myRight _ tmpBr]! {void} installBranch: branch {BranchDescription} after: trace {TracePosition} fulltrace installBranch: branch after: trace! {BranchDescription} makeBranch: trace1 {TracePosition} with: trace2 {TracePosition} "Create a dag branch that succeeds both trace1 and trace2." ^BranchDescription make: fulltrace with: trace1 with: trace2! {TracePosition} nextPosition "Return the first available tracePosition on this branch." lastPosition _ lastPosition + 1. self diskUpdate. ^TracePosition make: self with: lastPosition! ! !BranchDescription methodsFor: 'protected: protected create'! create: ft {DagWood} super create. fulltrace _ ft. myLeft _ NULL. myRight _ NULL. lastPosition _ 2! ! !BranchDescription methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self hashForEqual! ! !BranchDescription methodsFor: 'smalltalk: smalltalk passe'! {Boolean} = another {BranchDescription} self passe! {UInt32} ohashForEqual "See the comment for isEqual:." "^myBranchNum * 945737"! {BooleanVar} oisEqual: another {Heaper} "^(another isKindOf: BranchDescription) and: [(another basicCast: BranchDescription) branchNum == myBranchNum]"! ! !BranchDescription methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. lastPosition _ receiver receiveUInt32. myLeft _ receiver receiveHeaper. myRight _ receiver receiveHeaper. fulltrace _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: lastPosition. xmtr sendHeaper: myLeft. xmtr sendHeaper: myRight. xmtr sendHeaper: fulltrace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BranchDescription class instanceVariableNames: ''! (BranchDescription getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !BranchDescription class methodsFor: 'instance creation'! make: fulltrace {DagWood} ^RootBranch create: fulltrace! make: fulltrace {DagWood} with: parent {TracePosition} ^TreeBranch create: fulltrace with: parent! {BranchDescription} make: fulltrace {DagWood} with: parent1 {TracePosition} with: parent2 {TracePosition} ^DagBranch create: fulltrace with: parent1 with: parent2! !BranchDescription subclass: #DagBranch instanceVariableNames: ' parent1 {TracePosition} parent2 {TracePosition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (DagBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DagBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} parent1 cacheIn: navCache. parent2 cacheIn: navCache! ! !DagBranch methodsFor: 'create'! create: ft {DagWood}with: p1 {TracePosition} with: p2 {TracePosition} super create: ft. parent1 _ p1. parent2 _ p2. self newShepherd. self remember! ! !DagBranch methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: parent1 hashForEqual) bitXor: parent2 hashForEqual! ! !DagBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. parent1 _ receiver receiveHeaper. parent2 _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: parent1. xmtr sendHeaper: parent2.! !BranchDescription subclass: #RootBranch instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (RootBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !RootBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} "The recursion ends here."! ! !RootBranch methodsFor: 'create'! create: ft {DagWood} super create: ft. self newShepherd. self remember! ! !RootBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !BranchDescription subclass: #TreeBranch instanceVariableNames: 'parent {TracePosition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! (TreeBranch getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !TreeBranch methodsFor: 'caching'! {void} cacheRecur: navCache {PrimIndexTable} parent cacheIn: navCache! ! !TreeBranch methodsFor: 'create'! create: ft {DagWood} with: p {TracePosition} super create: ft. parent _ p. self newShepherd. self remember! ! !TreeBranch methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: parent hashForEqual! ! !TreeBranch methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. parent _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: parent.! !Abraham subclass: #CanopyCrum instanceVariableNames: ' child1 {CanopyCrum | NULL} child2 {CanopyCrum | NULL} parent {CanopyCrum | NULL} minH {IntegerVar} maxH {IntegerVar} myOwnFlags {UInt32} myFlags {UInt32} myRefCount {IntegerVar}' classVariableNames: ' FlagEndorsements {PtrArray of: Position | XnRegion} OtherClubs {IDRegion} OtherEndorsements {CrossRegion} TheEFlagsCache {Heaper2UInt32Cache} ThePFlagsCache {Heaper2UInt32Cache} ' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! CanopyCrum comment: 'CanopyCrums form binary trees that acrete in a balanced fashion. No rebalancing ever happens. Things are simply added to the tree up to the point thta the tree is balanced, then the height of the tree gets extended at the root. Essentially, when the join of two trees is asked for, if the two trees aren''t already parts of a larger tree, the algorithm attempts to find a place in one tree into which the other tree could completely fit without violating the depth constraint on the tree. It then returns the nearest root that contains both trees. If it can''t put one tree into the other, then it makes a new node that joins the two trees (probably with room to add other stuff deeper down). myRefCount is only the count of Loafs or HCrums that point at the CanopyCrum. It doesn''t include other CanopyCrums. 12/2/92 Ravi PropJoints have been suspended, and their function has been replaced by flag words in the CanopyCrum. Any interesting Club or endorsement gets a bit, and there is a bit for "any other Club" and "any other endorsement". Any criteria not given a bit of their own require an exhaustive search. These flags are widded by ORing up the canopy. When we start using more sophisticated hashing strategies, we will probably need to reanimate PropJoints.'! (CanopyCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !CanopyCrum methodsFor: 'canopy operations'! {CanopyCrum} computeJoin: otherBCrum {CanopyCrum} "Find a canopyCrum that is an anscestor to both the receiver and otherBCrum. otherBCrum is added to the canopy in a pseudo-balanced fashion. This demonstrates the beauty and power of caching in object-oriented systems." | otherPath {MuSet of: CanopyCrum} myRoot {CanopyCrum} otherRoot {CanopyCrum} cache {CanopyCache} | (self isLE: otherBCrum) ifTrue: [^self]. cache _ self canopyCache. otherPath _ cache pathFor: otherBCrum. otherRoot _ cache rootFor: otherBCrum. (otherBCrum isLE: self) ifTrue: [^otherBCrum]. otherPath stepper forEach: [:bCrum {CanopyCrum} | (bCrum isLE: self) ifTrue: [^bCrum]]. myRoot _ cache rootFor: self. myRoot maxHeight > otherRoot maxHeight ifTrue: [^self makeJoin: otherRoot] ifFalse: [^otherBCrum makeJoin: myRoot]! {Pair of: CanopyCrum} expand "split into two if possible, return the two leaves" (child1 ~~ NULL and: [child2 ~~ NULL]) ifTrue: [^Pair make: self with: self]. (child1 == NULL and: [child2 == NULL]) assert: 'Must be both or niether'. DiskManager consistent: 3 with: [(child1 _ self makeNew) setParent: self. (child2 _ self makeNew) setParent: self. self canopyCache updateCache: child1 forParent: self. self canopyCache updateCache: child2 forParent: self. self diskUpdate]. ^Pair make: child1 with: child2! {void} includeCanopy: otherCanopy {CanopyCrum} "Install otherCanopy at or below the receiver. If the otherCanopy fits in a lower branch, put it there. Otherwise, replace the shortest child with a new child that contains the shortest child and otherCanopy." "This should be a friend or private function or something." | | self thingToDo. "Propagate the children's props into their new parent" self thingToDo. "When we have non-props to propagate, do those, too. i.e., height is currently handle by changeCanopy and will be moved out to HeightChanger momentarily." child1 ~~ NULL assert: 'shouldnt get here.'. child1 heightDiff >= otherCanopy maxHeight ifTrue: [child1 includeCanopy: otherCanopy] ifFalse: [child2 heightDiff >= otherCanopy maxHeight ifTrue: [child2 includeCanopy: otherCanopy] ifFalse: [DiskManager consistent: [child1 maxHeight > child2 maxHeight ifTrue: [(child2 _ self makeNewParent: child2 with: otherCanopy) setParent: self] ifFalse: [(child1 _ self makeNewParent: child1 with: otherCanopy) setParent: self]. "Update the cache for the newly installed subTree because of the new tree above it." self canopyCache updateCacheFor: otherCanopy. (Sequencer make: (PropChanger height: self) with: (PropChanger make: self)) schedule]]]! {Boolean} isLE: other {CanopyCrum} "Return true if other is equal to the receiver or an anscestor (through the parent links). Use caches for efficiency." ^(self canopyCache pathFor: other) hasMember: self! ! !CanopyCrum methodsFor: 'canopy accessing'! {void} addPointer: ignored {Heaper unused} "Keep a refcount of diskful pointers to myself for disk space management. (Maybe backpointers later.)" myRefCount _ myRefCount + 1. myRefCount == 1 ifTrue: [self remember]. self diskUpdate! {CanopyCrum} fetchParent ^parent! {UInt32} flags ^myFlags! {IntegerVar} heightDiff ^maxH - minH! {BooleanVar} isLeaf ^child1 == NULL and: [child2 == NULL]! {IntegerVar}maxHeight ^maxH! {IntegerVar}minHeight ^minH! {void} removePointer: ignored {Heaper unused} "Keep a refcount of diskful pointers to myself for disk space management. (Maybe backpointers later.) Forget the object if it goes to zero." self thingToDo. "Is calling destroy a bug?" myRefCount _ myRefCount - 1. MarkM knownBug. "refCunt going to 0 with an outstanding AgendaItem." "(myRefCount == IntegerVar0 and: [parent == NULL]) ifTrue: [self forget; destroy] ifFalse: ["self diskUpdate! {void} setParent: p {CanopyCrum | NULL} (parent == NULL and: [p ~~ NULL]) ifTrue: [self remember]. parent _ p. (myRefCount == IntegerVar0 and: [parent == NULL]) ifTrue: [self destroy] ifFalse: [self diskUpdate]! ! !CanopyCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache self subclassResponsibility! {void} dismantle parent == NULL assert: 'We can only dismantle the canopy from the root on up.'. self thingToDo. "This first needs to remove all of myOwnProps from the canopy." DiskManager consistent: 3 with: [child1 ~~ NULL ifTrue: [child1 setParent: NULL. child1 _ NULL]. child2 ~~ NULL ifTrue: [child2 setParent: NULL. child2 _ NULL]. super dismantle]! {CanopyCrum} fetchChild1 ^child1! {CanopyCrum} fetchChild2 ^child2! {CanopyCrum} makeNew self subclassResponsibility! {UInt32} ownFlags ^myOwnFlags! {void} setOwnFlags: newFlags {UInt32} myOwnFlags _ newFlags.! ! !CanopyCrum methodsFor: 'create'! create: flags {UInt32} "Make a canopyCrum for a root: it has no children." super create. minH _ maxH _ 1. child1 _ child2 _ parent _ NULL. myOwnFlags _ flags. myFlags _ myOwnFlags. myRefCount _ IntegerVar0! create: flags {UInt32} with: first {CanopyCrum} with: second {CanopyCrum} "prop must be empty" super create. "prop isEmpty assert: 'Must be empty'." minH _ maxH _ 1. child1 _ first. child1 setParent: self. child2 _ second. child2 setParent: self. parent _ NULL. myOwnFlags _ flags. myFlags _ (flags bitOr: child1 flags) bitOr: child2 flags. myRefCount _ IntegerVar0! ! !CanopyCrum methodsFor: 'smalltalk: verification'! {CanopyCrum} another "Return another instance of the same class for testing purposes." ^CanopyCrum create! {IntegerVar} refCount ^myRefCount! {CanopyCrum} verify1 "BertCrum create verify1" 50 timesRepeat: [self computeJoin: self another]. ^self! {CanopyCrum} verify2 "BertCrum create verify2." self verifyHeight: 5. self computeJoin: (self another verifyHeight: 3). ^self! {CanopyCrum} verifyHeight: height {IntegerVar} "Create a tree with maxHeight = height and minHeight = 2." "BertCrum create verifyHeight: 4." (2 raisedTo: height - 2) timesRepeat: [self computeJoin: self another]. ^self! ! !CanopyCrum methodsFor: 'smalltalk:'! {Array of: CanopyCrum} childArray ^child1 == NULL ifTrue: [#()] ifFalse: [child2 == NULL ifTrue: [Array with: child1] ifFalse: [Array with: child1 with: child2]]! {Array of: CanopyCrum} children ^child1 == NULL ifTrue: [#()] ifFalse: [child2 == NULL ifTrue: [Array with: child1] ifFalse: [Array with: child1 with: child2]]! displayString ^String streamContents: [:aStream | aStream print: maxH. maxH = minH ifFalse: [aStream nextPut: $-; print: minH]]! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [| cur {CanopyCrum} | cur _ self. [cur fetchParent == NULL] whileFalse: [cur _ cur fetchParent]. cur inspectSubCanopy: self]! inspectSubCanopy: start EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum childArray] gettingImage: [:crum | crum = start ifTrue: [crum displayString asText allBold asDisplayText] ifFalse: [crum displayString asDisplayText]] at: 0 @ 0 vertical: true separation: 5 @ 10)! ! !CanopyCrum methodsFor: 'props'! {AgendaItem} propChanger: change {PropChange unused} with: prop {Prop} "Return an AgendaItem to propagate properties. NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." | | "Atomically Update myOwnFlags but not myFlags (The latter includes the widded stuff) return a PropChanger which at each step will update myPropJoint and move to parent." DiskManager insistent: 3 with: [myOwnFlags _ myOwnFlags bitOr: prop flags. self diskUpdate. ^PropChanger make: self]! ! !CanopyCrum methodsFor: 'testing'! {UInt32} contentsHash "This is only used by the TestPacker, so it includes all persistent state whether or not it is semantically interesting--myRefCount is not semantically interesting." ^(((((((super contentsHash bitXor: child1 hashForEqual) bitXor: child2 hashForEqual) bitXor: parent hashForEqual) bitXor: (IntegerPos integerHash: minH)) bitXor: (IntegerPos integerHash: maxH)) bitXor: myFlags) bitXor: myOwnFlags) bitXor: (IntegerPos integerHash: myRefCount)! ! !CanopyCrum methodsFor: 'protected'! {BooleanVar} changeCanopy "Figure out new props, etc. Return true if any changes may require further propagation" "At least one subclass adds behavior here by overriding and calling 'super changeCanopy:'" | result {BooleanVar} | "If this is a leaf If any of my properties are changed Store the modification of the props. else save current flags recalculate the flags from myOwnFlags and the flags of the children If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [result := myFlags ~= myOwnFlags. myFlags := myOwnFlags] ifFalse: [ | before {UInt32} | before := myFlags. myFlags := (myOwnFlags bitOr: child1 flags) bitOr: child2 flags. result := before ~= myFlags]. result ifTrue: [self diskUpdate]. ^result! {BooleanVar} changeHeight "Figure out new height. Return true if changes may require further propagation" | oldMin {IntegerVar} oldMax {IntegerVar} | "If this is a leaf then it cannot have changed otherwise, recalculate the heights from the heights of the children If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [^false]. oldMin := minH. oldMax := maxH. child1 minHeight > child2 minHeight ifTrue: [minH := child2 minHeight + 1] ifFalse: [minH := child1 minHeight + 1]. child1 maxHeight > child2 maxHeight ifTrue: [maxH := child1 maxHeight + 1] ifFalse: [maxH := child2 maxHeight + 1]. (oldMin ~= minH or: [oldMax ~= maxH]) ifTrue: [self diskUpdate. ^true] ifFalse: [^false]! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} "Make a new crum that contains both first and second. This method just makes a new parent whose properties are empty. My client must bring my properties up to date" self subclassResponsibility! ! !CanopyCrum methodsFor: 'private'! {CanopyCrum} makeJoin: otherCanopy {CanopyCrum} "Install otherCanopy as a subtree in the canopy containing the receiver. Look below the receiver and then in successively higher branches for a branch that has enough height difference to contain otherCanopy." | height {IntegerVar} cur {CanopyCrum} prev {CanopyCrum} | self thingToDo. "Propagate the children's props into their new parent" self thingToDo. "When we have non-props to propagate, do those, too. i.e., height is currently handle by changeCanopy and will be moved out to HeightChanger momentarily." height _ otherCanopy maxHeight. cur _ self. [cur == NULL or: [cur heightDiff >= height]] whileFalse: [prev _ cur. cur _ cur fetchParent]. cur == NULL ifTrue: ["join the trees at the top" cur _ self makeNewParent: prev with: otherCanopy. self canopyCache updateCache: prev forParent: cur. self canopyCache updateCache: otherCanopy forParent: cur.] ifFalse: ["found a branch that can contain otherCanopy. Place it in that branch." cur includeCanopy: otherCanopy]. "Cur now contains the closest parent shared between self and otherCanopy." ^cur! ! !CanopyCrum methodsFor: 'smalltalk: suspended'! {BooleanVar} changeCanopy: change {PropChange unused} "Figure out new height, props, etc. Return true if any changes may require further propagation" "At least one subclass adds behavior here by overriding and calling 'super changeCanopy:'" | result {BooleanVar} | "If this is a leaf If any of my properties are changed Store the modification of the props. else save current flags recalculate the flags from myOwnFlags and the flags of the children if we're changing all properties (kludge for when combining trees) recompute heights (min and max) If anything changed flag that the change must be written to disk return whether anything changed (which requires propagation rootward)" self isLeaf ifTrue: [result := myFlags ~= myOwnFlags. result ifTrue: [myFlags := myOwnFlags]] ifFalse: [ | before {UInt32} | before := myFlags. myFlags := (myOwnFlags bitOr: child1 flags) bitOr: child2 flags. change isFull ifTrue: [ | oldMin {IntegerVar} oldMax {IntegerVar} | self thingToDo. "Need to move height calculation into a different sort of PropChanger that propagates immediately." oldMin := minH. oldMax := maxH. child1 minHeight > child2 minHeight ifTrue: [minH := child2 minHeight + 1] ifFalse: [minH := child1 minHeight + 1]. child1 maxHeight > child2 maxHeight ifTrue: [maxH := child1 maxHeight + 1] ifFalse: [maxH := child2 maxHeight + 1]. result := oldMin ~= minH or: [oldMax ~= maxH]] ifFalse: [result := false]. result := result or: [before ~= myFlags]]. result ifTrue: [self diskUpdate]. ^result! {PropChange} fullChange self subclassResponsibility! {PropJoint} joint "Return the abstracted information necessary to determine whether anything leafward may pass the filtering criteria." ^myPropJoint! ! !CanopyCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. child1 _ receiver receiveHeaper. child2 _ receiver receiveHeaper. parent _ receiver receiveHeaper. minH _ receiver receiveIntegerVar. maxH _ receiver receiveIntegerVar. myOwnFlags _ receiver receiveUInt32. myFlags _ receiver receiveUInt32. myRefCount _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: child1. xmtr sendHeaper: child2. xmtr sendHeaper: parent. xmtr sendIntegerVar: minH. xmtr sendIntegerVar: maxH. xmtr sendUInt32: myOwnFlags. xmtr sendUInt32: myFlags. xmtr sendIntegerVar: myRefCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CanopyCrum class instanceVariableNames: ''! (CanopyCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !CanopyCrum class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: Heaper2UInt32Cache. TheEFlagsCache := Heaper2UInt32Cache make: 50. ThePFlagsCache := Heaper2UInt32Cache make: 50.! linkTimeNonInherited FlagEndorsements := NULL. OtherClubs := NULL. OtherEndorsements := NULL. TheEFlagsCache := NULL. ThePFlagsCache := NULL.! ! !CanopyCrum class methodsFor: 'protected: flags'! {UInt32} endorsementsFlags: endorsements {CrossRegion} "Flag bits corresponding to endorsements" | result {UInt32} f {UInt32} | result := TheEFlagsCache fetch: endorsements. (result ~= UInt32Zero or: [endorsements isEmpty]) ifTrue: [^result]. f := self firstEndorsementsFlag. FlagEndorsements ~~ NULL assert: 'Must be initialized'. UInt32Zero almostTo: FlagEndorsements count do: [ :i {UInt32} | (FlagEndorsements get: i) cast: Position into: [ :p | (endorsements hasMember: p) ifTrue: [result := result bitOr: f]] cast: XnRegion into: [ :r | (endorsements intersects: r) ifTrue: [result := result bitOr: f]]. f := f bitShift: 1]. (endorsements intersects: OtherEndorsements) ifTrue: [result := result bitOr: self otherEndorsementsFlag]. TheEFlagsCache at: endorsements cache: result. ^result! {UInt32} permissionsFlags: permissions {IDRegion} "Flag bits corresponding to permissions" | result {UInt32} | result := ThePFlagsCache fetch: permissions. result ~= UInt32Zero ifTrue: [^result]. [BeGrandMap] USES. (permissions hasMember: CurrentGrandMap fluidGet publicClubID) ifTrue: [result := result bitOr: self publicClubFlag]. OtherClubs == NULL ifTrue: [OtherClubs := CurrentGrandMap fluidGet publicClubID asRegion complement cast: IDRegion]. (permissions intersects: OtherClubs) ifTrue: [result := result bitOr: self otherClubsFlag]. ThePFlagsCache at: permissions cache: result. ^result! ! !CanopyCrum class methodsFor: 'private: flags'! {Int32} endorsementFlagLimit "Max number of special endorsement flags" ^23 "28 bits - 2 for permissions - 1 for all other endorsements - 2 reserved"! {UInt32} firstEndorsementsFlag "Rightmost flag for interesting endorsements" ^16r00000008! {UInt32} otherClubsFlag "The flag for any other Clubs" ^16r00000002! {UInt32} otherEndorsementsFlag "Flag for all uninteresting endorsements" ^16r00000004! {UInt32} publicClubFlag "The flag for the Universal Public Club" ^16r00000001! ! !CanopyCrum class methodsFor: 'flag setup'! {void} useEndorsementFlags: endorsements {PtrArray of: Position | XnRegion} "Use a special flag to look for any of the these endorsements" (FlagEndorsements == NULL or: [FlagEndorsements contentsEqual: endorsements]) ifFalse: [Heaper BLAST: #InvalidRequest]. "Tried to initialize twice" endorsements count > self endorsementFlagLimit ifTrue: [Heaper BLAST: #IndexOutOfBounds]. FlagEndorsements := endorsements copy cast: PtrArray. OtherEndorsements := CurrentGrandMap fluidGet endorsementSpace fullRegion cast: CrossRegion. Int32Zero almostTo: FlagEndorsements count do: [ :i {Int32} | (FlagEndorsements get: i) cast: Position into: [ :p | OtherEndorsements := (OtherEndorsements without: p) cast: CrossRegion] cast: XnRegion into: [ :r | OtherEndorsements := (OtherEndorsements minus: r) cast: CrossRegion]].! !CanopyCrum subclass: #BertCrum instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! BertCrum comment: 'This implementation tracks the endorsement information with a strictly binary tree. The tree gets heuristically balanced upon insertion of new elements in such a way that the ocrums pointing at a particular canopyCrum need not be updated. Therefore we should not bother storing backpointers. I''m doing so currently in case we change algorithms. Deletion may require backpointers to eliminate joins with the deleted crums.'! (BertCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BertCrum methodsFor: 'private: creation'! create "Make a canopyCrum for a root: it has no children." super create: UInt32Zero. self newShepherd! ! !BertCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache "should have one per Ent" ^CurrentBertCanopyCache fluidGet! {CanopyCrum} makeNew ^BertCrum create! ! !BertCrum methodsFor: 'smalltalk:'! {CanopyCrum} another "BertCrum create verify2." ^BertCrum create! inspectHCrums | owners | owners _ self allOwners select: [ :each | each isKindOf: HistoryCrum]. owners isEmpty ifTrue: [Transcript show: 'Nobody'; cr] ifFalse: [owners size = 1 ifTrue: [owners first inspect] ifFalse: [owners inspect]]! inspectMenuArray ^#( ('inspect hcrums' inspectHCrums '') )! printOn: aStream aStream << self getCategory name << '(' << self children size << ')'. "child1 = NULL ifTrue: [aStream << (self flags printStringRadix: 2)] ifFalse: [aStream nextPut: $(; print: child1; nextPut: $,; print: child2; nextPut: $)]"! showOn: oo oo print: self maxHeight. self maxHeight == self minHeight ifFalse: [oo nextPut: $-; print: self minHeight]. oo print: (self flags printStringRadix: 2)! ! !BertCrum methodsFor: 'protected'! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} DiskManager consistent: 3 with: [^BertCrum create: (first cast: BertCrum) with: (second cast: BertCrum)]! ! !BertCrum methodsFor: 'instance creation'! create: first {BertCrum} with: second {BertCrum} "Create a new parent for two BertCrums. My client must bring my properties up to date. This constructor just makes a new parent whose properties are empty" | | "Have the super do the basic creation." super create: UInt32Zero with: first with: second. self newShepherd. self canopyCache updateCache: self fetchChild1 forParent: self. self canopyCache updateCache: self fetchChild2 forParent: self! ! !BertCrum methodsFor: 'smalltalk: suspended'! {PropChange} fullChange ^PropChange bertPropChange! ! !BertCrum methodsFor: 'accessing'! {BooleanVar} isNotPartializable ^(self flags bitAnd: BertCrum isNotPartializableFlag) ~= UInt32Zero! {BooleanVar} isSensorWaiting ^(self flags bitAnd: BertCrum isSensorWaitingFlag) ~= UInt32Zero! ! !BertCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BertCrum class instanceVariableNames: ''! (BertCrum getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !BertCrum class methodsFor: 'smalltalk: initialization'! staticTimeNonInherited CanopyCache defineFluid: #CurrentBertCanopyCache with: DiskManager emulsion with: [CanopyCache make]! ! !BertCrum class methodsFor: 'instance creation'! make DiskManager consistent: 1 with: [ ^BertCrum create]! ! !BertCrum class methodsFor: 'flags'! {UInt32} flagsFor: permissions {IDRegion | NULL} with: endorsements {CrossRegion | NULL} with: isNotPartializable {BooleanVar} with: isSensorWaiting {BooleanVar} "The flag word corresponding to the given props" | result {UInt32} | result := UInt32Zero. permissions ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum permissionsFlags: permissions)]. endorsements ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum endorsementsFlags: endorsements)]. isNotPartializable ifTrue: [result := result bitOr: self isNotPartializableFlag]. isSensorWaiting ifTrue: [result := result bitOr: self isSensorWaitingFlag]. ^result! {UInt32 constFn} isNotPartializableFlag "Flag bit for active Editions" ^16r08000000! {UInt32 constFn} isSensorWaitingFlag "Flag bit for active Editions" ^16r04000000! !CanopyCrum subclass: #SensorCrum instanceVariableNames: 'myBackfollowRecorders {ImmuSet of: RecorderFossil}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! SensorCrum comment: 'This implementation is the same as BertCrums. This will require pointers into the ent to implement delete (for archiving). Canopy reorganization could be achieved by removing several orgls, then re-adding them (archive then restore).'! (SensorCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SensorCrum methodsFor: 'private: creation'! create "Make a canopyCrum for a root: it has no children." super create: UInt32Zero. myBackfollowRecorders _ ImmuSet make. self newShepherd! create: flags {UInt32} "Make a canopyCrum for a root: it has no children." super create: flags. myBackfollowRecorders _ ImmuSet make. self newShepherd! ! !SensorCrum methodsFor: 'smalltalk:'! {CanopyCrum} another "SensorCrum create verify2." ^SensorCrum create! displayString ^String streamContents: [:aStream | aStream print: self maxHeight. self maxHeight == self minHeight ifFalse: [aStream nextPut: $-; print: self minHeight]]! inspectMenuArray ^#( ('inspect oparts' inspectOParts ''))! inspectOParts | owners | owners _ self allOwners select: [ :each | each isKindOf: OPart]. owners isEmpty ifTrue: [Transcript show: 'Nobody'; cr] ifFalse: [owners size = 1 ifTrue: [owners first inspect] ifFalse: [owners inspect]]! {void} printOn: aStream [myBackfollowRecorders == nil ifTrue: [ aStream << self getCategory name << '(nil)'. ^ VOID]] smalltalkOnly. aStream << self getCategory name << '(' << (self flags printStringRadix: 2) << ')'. myBackfollowRecorders isEmpty ifFalse: [aStream << ' *']! ! !SensorCrum methodsFor: 'protected:'! {CanopyCache wimpy} canopyCache "should have one per Ent" ^CurrentSensorCanopyCache fluidGet! {CanopyCrum} makeNew Dean thingToDo. "is this right? I want to preserve the partiality flag when a partial loaf splits /ravi/5/7/92/" self isPartial ifTrue: [^SensorCrum create: SensorCrum isPartialFlag] ifFalse: [^SensorCrum create]! ! !SensorCrum methodsFor: 'accessing'! {PropFinder} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "Set off all recorders that respond to the change either in me or in any of my ancestors up to but not including sCrum (If I am the same as sCrum, skip me as well.) (If sCrum is null, search through all my ancestors to a root of the sensor canopy.) return simplest finder for looking at children" | next {SensorCrum | NULL} | "from self rootward until told to stop (at sCrum or the root) trigger any matching recorders return a simplified finder for examining children." next := self. [next ~~ NULL] whileTrue: [next := next fetchNextAfterTriggeringRecorders: finder with: scrum]. ^finder pass: self! {SensorCrum | NULL} fetchNextAfterTriggeringRecorders: finder {PropFinder} with: sCrum {SensorCrum | NULL} "Set off all recorders in me that respond to the change, if appropriate (If I am the same as sCrum, skip me.) If sCrum is null or not me, return my parent so caller can iterate through my ancestors to sCrum or a root." | | "One step of the leafward walk of the O-plane, triggering recorders: Walk rootward on the sensor canopy, where many steps may correspond to this single leafward step." "If we're the designated sCrum (where this work was already done) return without doing anything. We're done. For each of our recorders if it hasn't gone extinct reanimate it long enough to trigger it, recording stamp if finder matches. Return a pointer to our parent (so caller can iterate this operation rootward)." (sCrum ~~ NULL and: [self isEqual: sCrum]) ifTrue: [^NULL]. myBackfollowRecorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [fossil reanimate: [:recorder {ResultRecorder} | recorder triggerIfMatching: finder with: fossil]]]. ^self fetchParent cast: SensorCrum.! {BooleanVar} isPartial ^(self flags bitAnd: SensorCrum isPartialFlag) ~= UInt32Zero! {ImmuSet of: RecorderFossil} recorders ^myBackfollowRecorders! {AgendaItem} recordingAgent: recorder {RecorderFossil} "NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." | | "If the recorder we're adding isn't already present here pack up the fossil for shipment to the hoister atomically Install the recorder here return a RecorderHoister to propagate the side-effects and anneal the canopy (The RecorderHoister will update myFlags) return an empty agenda (to satisfy our contract)" (myBackfollowRecorders hasMember: recorder) ifFalse: [ | cargo {ImmuSet of: RecorderFossil} | cargo := ImmuSet make with: recorder. DiskManager consistent: 2 with: [self installRecorders: cargo. self diskUpdate. ^RecorderHoister make: self with: cargo]]. ^Agenda make! {void} removeRecorders: recorders {ImmuSet of: RecorderFossil} "Remove recorders because they have migrated rootward. Recalculate myOwnFlags and myFlags." | f {UInt32} | myBackfollowRecorders _ myBackfollowRecorders minus: recorders. self diskUpdate. f := UInt32Zero. myBackfollowRecorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [fossil reanimate: [:recorder {ResultRecorder} | f := f bitOr: recorder sensorProp flags]]]. self setOwnFlags: f. self changeCanopy! ! !SensorCrum methodsFor: 'private:'! {void} installRecorders: recorders {ImmuSet of: RecorderFossil} "Installs the recorders in my set and updates myOwnProp accordingly. The caller has already checked that none of these recorders are already installed here. The caller also handles updating myFlags. The caller also handles all issues of rootward propagation of these changes. The caller also does the 'diskUpdate'. This is a separate method because it's called once by the code that installs a new recorder, and again by the code that recursively hoists recurders up the canopy. add the new recorders to my set for each new recorder if it hasn't gone extinct extract its properties union them into my own" myBackfollowRecorders _ myBackfollowRecorders unionWith: recorders. recorders stepper forEach: [ :fossil {RecorderFossil} | fossil isExtinct ifFalse: [ | prop {Prop} | fossil reanimate: [:recorder {ResultRecorder} | prop := recorder sensorProp]. self setOwnFlags: (self ownFlags bitOr: prop flags)]]! ! !SensorCrum methodsFor: 'protected'! {CanopyCrum} makeNewParent: first {CanopyCrum} with: second {CanopyCrum} DiskManager consistent: 3 with: [^SensorCrum create: (first cast: SensorCrum) with: (second cast: SensorCrum)]! ! !SensorCrum methodsFor: 'smalltalk: passe'! {PropFinder} checkRecorders: stamp {BeEdition} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe "fewer args"! {SensorCrum | NULL} fetchNextAfterTriggeringRecorders: stamp {BeEdition} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe "fewer args"! {void} record: recorder {RecorderFossil} self passe. "equivalent to '(self recordingAgent: recorder) schedule"! {void} triggerRecorders: stamp {Stamp} with: finder {PropFinder} with: sCrum {SensorCrum | NULL} self passe. "Use fetchNextAfterTriggeringRecorders:with:with:"! ! !SensorCrum methodsFor: 'instance creation'! create: first {SensorCrum} with: second {SensorCrum} "Create a new parent for two SensorCrums. This constructor just makes a new parent whose properties are empty. My client must bring my properties up to date." | | "Have the super do the basic creation." super create: UInt32Zero with: first with: second. self newShepherd. myBackfollowRecorders _ ImmuSet make. self canopyCache updateCache: self fetchChild1 forParent: self. self canopyCache updateCache: self fetchChild2 forParent: self! ! !SensorCrum methodsFor: 'smalltalk: suspended'! changeCanopy: f! {PropChange} fullChange ^PropChange sensorPropChange! ! !SensorCrum methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myBackfollowRecorders _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myBackfollowRecorders.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SensorCrum class instanceVariableNames: ''! (SensorCrum getOrMakeCxxClassDescription) friends: 'friend class RecorderHoister; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SensorCrum class methodsFor: 'smalltalk: init'! staticTimeNonInherited CanopyCache defineFluid: #CurrentSensorCanopyCache with: DiskManager emulsion with: [CanopyCache make]! ! !SensorCrum class methodsFor: 'pseudo constructors'! make DiskManager consistent: 2 with: [ ^SensorCrum create]! {SensorCrum} partial DiskManager consistent: 1 with: [ ^SensorCrum create: SensorCrum isPartialFlag]! ! !SensorCrum class methodsFor: 'flags'! {UInt32} flagsFor: permissions {IDRegion | NULL} with: endorsements {CrossRegion | NULL} with: isPartial {BooleanVar} "The flag word corresponding to the given props" | result {UInt32} | result := UInt32Zero. permissions ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum permissionsFlags: permissions)]. endorsements ~~ NULL ifTrue: [result := result bitOr: (CanopyCrum endorsementsFlags: endorsements)]. isPartial ifTrue: [result := result bitOr: self isPartialFlag]. ^result! {UInt32 constFn} isPartialFlag "Flag bit for existence of partiality" ^16r08000000! !Abraham subclass: #Counter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! (Counter getOrMakeCxxClassDescription) friends: 'friend class SimpleTurtle; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Counter methodsFor: 'accessing'! {IntegerVar} count ^self subclassResponsibility! {IntegerVar} decrement ^self subclassResponsibility! {IntegerVar} decrementBy: count {IntegerVar} ^self subclassResponsibility! {IntegerVar} increment ^self subclassResponsibility! {IntegerVar} incrementBy: count {IntegerVar} ^self subclassResponsibility! {void} setCount: count {IntegerVar} self subclassResponsibility! ! !Counter methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self count << ')'! ! !Counter methodsFor: 'protected: creation'! create super create! create: hash {UInt32} super create: hash! ! !Counter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Counter class instanceVariableNames: ''! (Counter getOrMakeCxxClassDescription) friends: 'friend class SimpleTurtle; '; attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Counter class methodsFor: 'pseudo-constructors'! {Counter} fakeCounter: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} ^BatchCounter makeFakeCounter: count with: batchCount with: hash! make ^SingleCounter create.! make: count {IntegerVar} ^SingleCounter create: count! make: count {IntegerVar} with: batchCount {IntegerVar} ^BatchCounter make: count with: batchCount! !Counter subclass: #BatchCounter instanceVariableNames: ' myCount {IntegerVar NOCOPY} myPersistentCount {IntegerVar} myMutex {Sema4 NOCOPY} myBatchCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! BatchCounter comment: 'Instances preallocate a bunch of numbers and record the preallocations to disk. It then increments purely in memory until the preallocated counts are used up. It then preallocates another bunch of numbers. If the system crashes, all numbers between the in-memory count and the on-disk count simply never get used. This reduces the access to disk for shepherd hashes and GrandMap IDs.'! (BatchCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BatchCounter methodsFor: 'accessing'! {IntegerVar} count ^myCount! {IntegerVar} decrement myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - 1. self diskUpdate]]. ^myCount! {IntegerVar} decrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - count. self diskUpdate]]. ^myCount! {IntegerVar} increment myMutex critical: [myCount _ myCount + 1. myCount > myPersistentCount ifTrue: [DiskManager consistent: 1 with: [myPersistentCount _ myCount + myBatchCount. self diskUpdate]]]. ^myCount! {IntegerVar} incrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [myCount _ myCount + count. myCount > myPersistentCount ifTrue: [DiskManager consistent: 1 with: [myPersistentCount _ myCount + myBatchCount. self diskUpdate]]]. ^myCount! {void} setCount: count {IntegerVar} myMutex critical: [DiskManager consistent: 1 with: [myCount _ count. self diskUpdate]]! ! !BatchCounter methodsFor: 'receiver: stubble'! {void RECEIVE.HOOK} restartBatchCounter: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myCount _ myPersistentCount. myMutex _ Sema4 make: 1.! ! !BatchCounter methodsFor: 'protected: create'! create: count {IntegerVar} with: batchCount {IntegerVar} super create. DiskManager consistent: 1 with: [myPersistentCount _ myCount _ count. myBatchCount _ batchCount. self restartBatchCounter: NULL. self newShepherd. self remember]! create: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} super create: hash. myPersistentCount _ myCount _ count. myBatchCount _ batchCount. self restartBatchCounter: NULL.! ! !BatchCounter methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myPersistentCount)! ! !BatchCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPersistentCount _ receiver receiveIntegerVar. myBatchCount _ receiver receiveIntegerVar. self restartBatchCounter: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myPersistentCount. xmtr sendIntegerVar: myBatchCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BatchCounter class instanceVariableNames: ''! (BatchCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BatchCounter class methodsFor: 'pseudo-constructors'! {Counter} make: count {IntegerVar} with: batchCount {IntegerVar} ^self create: count with: batchCount! {Counter} makeFakeCounter: count {IntegerVar} with: batchCount {IntegerVar} with: hash {UInt32} ^self create: count with: batchCount with: hash! !Counter subclass: #SingleCounter instanceVariableNames: ' myCount {IntegerVar} myMutex {Sema4 NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! SingleCounter comment: 'This counter separates a very simple state change into another flock so that big objects like GrandMaps and GrandHashTables don''t ned to flush their entirety to disk. It localizes the state change of a counter.'! (SingleCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SingleCounter methodsFor: 'accessing'! {IntegerVar} count ^myCount! {IntegerVar} decrement myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - 1. self diskUpdate]]. ^myCount! {IntegerVar} decrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount - count. self diskUpdate]]. ^myCount! {IntegerVar} increment myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount + 1. self diskUpdate]]. ^myCount! {IntegerVar} incrementBy: count {IntegerVar} count >= IntegerVarZero ifFalse: [Heaper BLAST: #InvalidRequest]. myMutex critical: [DiskManager consistent: 1 with: [myCount _ myCount + count. self diskUpdate]]. ^myCount! {void} setCount: count {IntegerVar} myMutex critical: [DiskManager consistent: 1 with: [myCount _ count. self diskUpdate]]! ! !SingleCounter methodsFor: 'receiver: restart'! {void RECEIVE.HOOK} restartSingleCounter: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myMutex _ Sema4 make: 1.! ! !SingleCounter methodsFor: 'protected: create'! create super create. myCount _ IntegerVar0. self restartSingleCounter: NULL. self newShepherd. self remember! create: count {IntegerVar} super create. myCount _ count. self restartSingleCounter: NULL. self newShepherd. self remember! ! !SingleCounter methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myCount)! ! !SingleCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCount _ receiver receiveIntegerVar. self restartSingleCounter: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SingleCounter class instanceVariableNames: ''! (SingleCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !SingleCounter class methodsFor: 'pseudo-constructors'! {Counter} make ^self create.! {Counter} make: count {IntegerVar} ^self create: count! !Abraham subclass: #DagWood instanceVariableNames: ' myRoot {TracePosition} myTrunk {MuTable of: TracePosition and: BranchDescription} myCachedPosition {TracePosition NOCOPY} myNavCache {PrimIndexTable NOCOPY}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Traces'! DagWood comment: 'Each dagwood defines a partial ordering of TracePositions. Several implementation variables use longs because they represent the size of an in-core array (which can''t get that large). The variable ''myRoot'' is just for debugging for the moment.'! (DagWood getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !DagWood methodsFor: 'accessing'! {TracePosition} root ^myRoot! {BranchDescription} successorBranchOf: branch {BranchDescription unused} position: position {UInt32 unused} "Return all the successors of the receiver in the trace tree." self unimplemented. ^NULL! {MuSet} successorsOf: trace {TracePosition} "Return the first used positions on all the successors of trace." | prevBranch {BranchDescription} set {MuSet} | set _ MuSet make. prevBranch _ (myTrunk fetch: (HeaperAsPosition make: trace)) cast: BranchDescription. prevBranch ~~ NULL ifTrue: [prevBranch addSuccessorsTo: set]. ^set! ! !DagWood methodsFor: 'branches'! {void} installBranch: branch {BranchDescription} after: anchorTrace {TracePosition} "Lookup the anchorTrace to find the branch hanging off it. If there isn't one, then install branch as that branch. Otherwise walk a balanced walk down the binary tree of branches to find a place to hang the new branch." | prevBranch {BranchDescription} pos {Position} | prevBranch _ (myTrunk fetch: (pos _ HeaperAsPosition make: anchorTrace)) cast: BranchDescription. prevBranch == NULL ifTrue: [myTrunk at: pos introduce: branch] ifFalse: [prevBranch installBranch: branch]! {TracePosition} newPosition "This should really create a new root, but that's harder to draw!!." ^myRoot newSuccessor! ! !DagWood methodsFor: 'caching'! {PrimIndexTable} cacheTracePos: tracePos {TracePosition} "Install the supplied branch and position as the navCache and return it. " (myCachedPosition ~~ NULL and: [tracePos isEqual: myCachedPosition]) ifTrue: [^myNavCache]. myCachedPosition _ tracePos. myNavCache clearAll. tracePos cacheIn: myNavCache. ^myNavCache! ! !DagWood methodsFor: 'smalltalk: inspect'! {void} inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [myRoot inspect]! ! !DagWood methodsFor: 'create'! create super create. myCachedPosition _ NULL. myNavCache _ PrimIndexTable make: 128. myTrunk _ GrandHashTable make: HeaperSpace make. myRoot _ TracePosition make: (BranchDescription make: self) with: 1. "Ensure that no elements get allocated on the root branch." myRoot newSuccessor. self newShepherd. self remember! ! !DagWood methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartDagWood: trans {Rcvr unused default: NULL} "re-initialize the non-persistent part" myCachedPosition _ NULL. myNavCache _ PrimIndexTable make: 128.! ! !DagWood methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRoot hashForEqual! ! !DagWood methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRoot _ receiver receiveHeaper. myTrunk _ receiver receiveHeaper. self restartDagWood: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRoot. xmtr sendHeaper: myTrunk.! !Abraham subclass: #DoublingFlock instanceVariableNames: 'myCount {Int32}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (DoublingFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !DoublingFlock methodsFor: 'accessing'! {Int32} count ^myCount! {void} doDouble DiskManager consistent: 1 with: [myCount _ myCount * 2. self diskUpdate]! ! !DoublingFlock methodsFor: 'hooks:'! {void RECEIVE.HOOK} receiveTestFlock: rcvr {Rcvr} Int32Zero almostTo: myCount do: [:i {Int32} | rcvr receiveInt32 ~~ i ifTrue: [Heaper BLAST: #MustMatch]]! {void SEND.HOOK} sendTestFlock: xmtr {Xmtr} Int32Zero almostTo: myCount do: [:i {Int32} | xmtr sendInt32: i]! ! !DoublingFlock methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self hashForEqual <<', ' << myCount << ')'! ! !DoublingFlock methodsFor: 'creation'! create: hash {UInt32} super create: hash. myCount _ 1. self newShepherd! create: hash {UInt32} with: count {Int32} super create: hash. myCount _ count. self newShepherd! ! !DoublingFlock methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: (IntegerPos integerHash: myCount)! ! !DoublingFlock methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCount _ receiver receiveInt32. self receiveTestFlock: receiver.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: myCount. self sendTestFlock: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DoublingFlock class instanceVariableNames: ''! (DoublingFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !DoublingFlock class methodsFor: 'creation'! make: hash {UInt32} ^self create: hash! make: hash {UInt32} with: count {Int32} ^self create: hash with: count! !Abraham subclass: #Ent instanceVariableNames: ' oroots {MuTable NOCOPY smalltalk of: TracePosition and: OrglRoot} fulltrace {DagWood}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (Ent getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Ent methodsFor: 'orgl creation'! {TracePosition} newTrace ^fulltrace newPosition! ! !Ent methodsFor: 'instance creation'! create super create. [oroots _ MuTable make: HeaperSpace make] smalltalkOnly. fulltrace _ DagWood create. self newShepherd. self remember! ! !Ent methodsFor: 'smalltalk:'! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [self inspectFrom: fulltrace root]! inspectFrom: tracePos | seen trace | seen _ Set new. EntView openOn: (TreeBarnacle new buildOn: (self makeHandleFor: tracePos) gettingChildren: [:handle | trace _ handle tracePos. (seen includes: trace) ifTrue: [OrderedCollection new] ifFalse: [seen add: trace. trace successors asOrderedCollection collect: [:tp | self makeHandleFor: tp]]] gettingImage: [:handle | handle displayString asDisplayText] at: 0 @ 0 vertical: false separation: 10 @ 10)! {void} installORoot: root {OrglRoot} "oroots at: (HeaperAsPosition make: root hCut) store: root"! makeHandleFor: tracePos "These traceHandles are to hold a place in the ent inspection view. They are not used for ent behavior at all!!" ^RootHandle tracePos: tracePos ent: self! {OrglRoot} oRootAt: tpos {TracePosition} ^(oroots fetch: (HeaperAsPosition make: tpos)) cast: OrglRoot! ! !Ent methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: fulltrace hashForEqual! ! !Ent methodsFor: 'smalltalk: passe'! {Pair of: TracePosition and: BertCrum} mapJoin: table {ScruTable of: (ID | ActualOrgl | IObject | PackOBits)} with: gm {BeGrandMap} "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" self passe. " | n {IntegerVar} trace {TracePosition} crum {BertCrum} | [HistoryCrum] USES. n _ IntegerVar0. (table isKindOf: XnWordArray) ifFalse: [table stepper forEach: [ :each {Heaper} | | hroot {HRoot} | hroot _ NULL. (each isKindOf: ID) ifTrue: [hroot _ gm fetchIDHRoot: (each quickCast: ID)] ifFalse: [(each isKindOf: ActualOrgl) ifTrue: [hroot _ (each quickCast: ActualOrgl) stamp fetchHRoot] ifFalse: [(each isKindOf: IObject) ifTrue: [hroot _ (each quickCast: IObject) fetchHRoot]]]. hroot ~~ NULL ifTrue: [ | newtrace {TracePosition} newcrum {BertCrum} | newtrace _ hroot hCrum hCut. newcrum _ hroot hCrum bertCrum. n = IntegerVar0 ifTrue: [trace _ newtrace. crum _ newcrum] ifFalse: [trace _ trace newSuccessorAfter: newtrace. crum _ (crum computeJoin: newcrum) cast: BertCrum]. n _ n + 1]]]. n = IntegerVar0 ifTrue: [^Pair make: fulltrace newPosition with: BertCrum make]. n = 1 ifTrue: [^Pair make: trace newSuccessor with: crum]. ^Pair make: trace with: crum"! {ScruTable of: HRoot} mapTable: table {ScruTable of: (ID | ActualOrgl | IObject | PackOBits)} with: gm {BeGrandMap} "map the elements in the table to just HRoots" self passe. " | result {MuTable} stepper {TableStepper} | self passe. (table isKindOf: XnWordArray) ifTrue: [^ table]. result _ MuTable make: table coordinateSpace. (stepper _ table stepper) forEach: [ :value {Heaper} | DiskManager consistent: 11 with: [result at: stepper key store: (gm getOrMakeHRoot: value)]]. ^ result"! {OrglRoot} newOrglRoot: table {ScruTable of: FeRangeElement} with: gm {BeGrandMap} "compute the join of the existing traces and bert crums in the table" "make new ones if there are none" self passe.! {OrglRoot} newPartialOrglRoot: region {XnRegion} "create a new partial orgl root on a region" self passe. CurrentTrace fluidBind: fulltrace newPosition during: [| newCrum {BertCrum} | newCrum _ BertCrum create. CurrentBertCrum fluidBind: newCrum during: [| newRoot {OrglRoot} | newRoot _ OrglRoot make.Region: region. "oroots at: (HeaperAsPosition make: newRoot hCut) introduce: newRoot." ^newRoot]]! ! !Ent methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. fulltrace _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: fulltrace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Ent class instanceVariableNames: ''! (Ent getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !Ent class methodsFor: 'instance creation'! {Ent} make ^ Ent create! ! !Ent class methodsFor: 'smalltalk: initialization'! staticTimeNonInherited TracePosition defineFluid: #CurrentTrace with: DiskManager emulsion with: [NULL]. BertCrum defineFluid: #CurrentBertCrum with: DiskManager emulsion with: [NULL].! ! !Ent class methodsFor: 'magic numbers'! {IntegerVar INLINE} tableSegmentMaxSize "When we are making an orgl out of a table, we break the table up into pieces which should be no larger than this, so that they each fit into a snarf." ^16384! !Abraham subclass: #GrandDataPage instanceVariableNames: ' myLowHashBits {UInt32} numEntries {Int32} entries {PtrArray of: GrandEntry} overflow {GrandOverflow} myGroup {GrandNode}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandDataPage comment: 'GrandDataPage behaves as a small hash table. Linear hashing and the GrandOverflow structure are used to resolve collisions. The shift argument to the various methods is the number of pages in the parent node to indicate how many low bits of the hash are ignored.'! (GrandDataPage getOrMakeCxxClassDescription) friends: '/* friends for class GrandDataPage */ friend class GrandDataPageStepper; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandDataPage methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} with: shift {Int32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry} | localIndex _ originalIndex _ aHash // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [(aHash == entry hashForEqual) ifTrue: [(entry compare: toMatch) ifTrue: [^entry value]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: [ entry _ NULL "break" ]]. overflow ~~ NULL ifTrue: [ ^ overflow fetch: toMatch with: aHash]. ^NULL! {void} store.Entry: newEntry {GrandEntry} with: shift {Int32} | localIndex {UInt32} originalIndex {UInt32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ newEntry hashForEqual // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [newEntry hashForEqual == entry hashForEqual ifTrue: [(newEntry matches: entry) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 1 with: [entry destroy. entries at: localIndex store: newEntry. self diskUpdate]. ^VOID]]. localIndex _ localIndex + 1 \\ numEntries. localIndex == originalIndex ifTrue: ["This page is now full" overflow == NULL ifTrue: [DiskManager consistent: 4 with: [overflow _ myGroup getOverflow store.Entry: newEntry. self diskUpdate]] ifFalse: [overflow store.Entry: newEntry]. ^VOID]. entry _ (entries fetch: localIndex) cast: GrandEntry]. "Found empty slot." DiskManager consistent: 1 with: [entries at: localIndex store: newEntry. self diskUpdate]! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} with: shift {Int32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ aHash // shift \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [aHash == entry hashForEqual ifTrue: [(entry compare: toMatch) ifTrue: [DiskManager consistent: 2 with: [entry destroy. "Note that this does not delete the contents" entries at: localIndex store: NULL. self repack: shift. self diskUpdate]. ^VOID]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex = originalIndex ifTrue: ["break" entry _ NULL]]. overflow ~~ NULL ifTrue: [overflow wipe: toMatch with: aHash]! ! !GrandDataPage methodsFor: 'protected: creation'! create: nEntries {Int32} with: node {GrandNode} with: lowHashBits {UInt32} super create. myLowHashBits _ lowHashBits. numEntries _ nEntries. entries _ PtrArray nulls: numEntries. myGroup _ node. overflow _ NULL. self newShepherd. self remember! ! !GrandDataPage methodsFor: 'private: private'! {void} repack: shift {Int32} "This repacks the entry table after a wipe to keep the table consistent with" "the linear hash collision resolution technique." | newEntries {PtrArray of: GrandEntry} entry {GrandEntry} preferedIndex {Int32} | newEntries _ PtrArray nulls: numEntries. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entry _ (entries fetch: i) cast: GrandEntry) ~~ NULL ifTrue: [preferedIndex _ entry hashForEqual // shift \\ numEntries. (newEntries fetch: preferedIndex) ~~ NULL ifTrue: [[(newEntries fetch: preferedIndex) ~~ NULL] whileTrue: [preferedIndex _ preferedIndex + 1 \\ numEntries]]. newEntries at: preferedIndex store: entry]]. entries destroy. entries _ newEntries.! ! !GrandDataPage methodsFor: 'node doubling'! {GrandDataPage} makeDouble: newNumPages {Int32} "Create a new page with all entries of current page that have a" "'1' in the new lowest significant bit of the hash." "Retain all '0' entries in this page." | newPage {GrandDataPage} oldEntry {GrandEntry wimpy} oldNumPages {Int32} | DiskManager consistent: 2 with: [oldNumPages _ newNumPages / 2. newPage _ GrandDataPage make: numEntries with: myGroup with: myLowHashBits + oldNumPages. overflow _ NULL. "Reset overflow structure. Old one is held by parent node." Int32Zero almostTo: numEntries do: [:i {Int32} | oldEntry _ (entries fetch: i) cast: GrandEntry. "This test is necessary since page to be doubled may not be full." oldEntry ~~ NULL ifTrue: [(oldEntry hashForEqual // oldNumPages bitAnd: 1) == 1 ifTrue: [newPage store.Entry: oldEntry with: newNumPages. entries at: i store: NULL]]]. "Now let pages sort themselves out." self repack: newNumPages. self diskUpdate]. ^newPage! ! !GrandDataPage methodsFor: 'special'! {IEEEDoubleVar} loadFactor | loadCount {Int32} | loadCount _ Int32Zero. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entries fetch: i) ~~ NULL ifTrue: [ loadCount _ loadCount + 1]]. ^ loadCount asFloat / numEntries asFloat! {UInt32} lowHashBits ^ myLowHashBits! ! !GrandDataPage methodsFor: 'printing'! {void} printOn: aStream {ostream reference} | count {Int32} | aStream << 'GrandDataPage(' << numEntries << ' slots, '. count _ Int32Zero. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entries fetch: i) ~~ NULL ifTrue: [ count _ count + 1 ]]. aStream << count << ' full'. overflow ~~ NULL ifTrue: [ aStream << ' and overflow']. aStream << ')'! ! !GrandDataPage methodsFor: 'protected: destruction'! {void} dismantle DiskManager consistent: 1 + numEntries with: [| entry {Heaper} | entries ~~ NULL ifTrue: [Int32Zero almostTo: numEntries do: [ :i {Int32} | entry _ entries fetch: i. entry ~~ NULL ifTrue: [entry destroy. entries at: i store: NULL]]. entries destroy. entries _ NULL]. super dismantle]! ! !GrandDataPage methodsFor: 'testing'! {UInt32} contentsHash ^((((super contentsHash bitXor: (IntegerPos integerHash: myLowHashBits)) bitXor: (IntegerPos integerHash: numEntries)) bitXor: entries contentsHash) bitXor: overflow hashForEqual) bitXor: myGroup hashForEqual! {BooleanVar} isEmpty UInt32Zero almostTo: numEntries do: [ :i {UInt32} | (entries fetch: i) ~~ NULL ifTrue: [ ^ false ]]. ^ true! ! !GrandDataPage methodsFor: 'private: friendly'! {GrandEntry} entryAt: idx {IntegerVar} ^(entries fetch: idx DOTasLong) cast: GrandEntry! {IntegerVar} entryCount ^ numEntries! ! !GrandDataPage methodsFor: 'private: smalltalk: private'! inspectPieces ^entries asOrderedCollection! ! !GrandDataPage methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLowHashBits _ receiver receiveUInt32. numEntries _ receiver receiveInt32. entries _ receiver receiveHeaper. overflow _ receiver receiveHeaper. myGroup _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendUInt32: myLowHashBits. xmtr sendInt32: numEntries. xmtr sendHeaper: entries. xmtr sendHeaper: overflow. xmtr sendHeaper: myGroup.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandDataPage class instanceVariableNames: ''! (GrandDataPage getOrMakeCxxClassDescription) friends: '/* friends for class GrandDataPage */ friend class GrandDataPageStepper; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandDataPage class methodsFor: 'creation'! make: nEntries {Int32} with: node {GrandNode} with: lowHashBits {UInt32} ^ self create: nEntries with: node with: lowHashBits! !Abraham subclass: #GrandEntry instanceVariableNames: 'objectInternal {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandEntry comment: 'GrandEntries probably want to not be remembered right when they are created, and remembered when they are finally put into their place in the GrandDataPages or GrandOverflows'! (GrandEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !GrandEntry methodsFor: 'accessing'! {Heaper} value objectInternal == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^ objectInternal! ! !GrandEntry methodsFor: 'protected: creation'! create: value {Heaper} with: hash {UInt32} super create: hash. value == NULL ifTrue: [Heaper BLAST: #NullInsertion]. [value == nil ifTrue: [Heaper BLAST: #NullInsertion]] smalltalkOnly. objectInternal _ value.! ! !GrandEntry methodsFor: 'deferred: testing'! {BooleanVar} compare: anObj {Heaper | Position} self subclassResponsibility! {BooleanVar} matches: anEntry {GrandEntry} self subclassResponsibility! ! !GrandEntry methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: (IntegerPos integerHash: self hashForEqual)) bitXor: objectInternal hashForEqual! ! !GrandEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. objectInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: objectInternal.! !GrandEntry subclass: #GrandSetEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandSetEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandSetEntry methodsFor: 'testing'! {BooleanVar} compare: anObj {Heaper | Position} ^ self value isEqual: anObj! {BooleanVar} matches: anEntry {GrandEntry} ^ self value isEqual: anEntry value! ! !GrandSetEntry methodsFor: 'protected: creation'! create: value {Heaper} with: hash {UInt32} super create: value with: hash. self newShepherd. self remember! ! !GrandSetEntry methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandSetEntry(hash=' << self hashForEqual << ', value=' << self value << ')'! ! !GrandSetEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandSetEntry class instanceVariableNames: ''! (GrandSetEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandSetEntry class methodsFor: 'create'! {GrandEntry} make: value {Heaper} with: hash {UInt32} ^ self create: value with: hash! !GrandEntry subclass: #GrandTableEntry instanceVariableNames: 'keyInternal {Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! (GrandTableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandTableEntry methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandTableEntry(hash=' << self hashForEqual << ', key='<< keyInternal << ', value=' << self value << ')'! ! !GrandTableEntry methodsFor: 'accessing'! {Position} key ^ keyInternal! {Position} position ^ keyInternal! ! !GrandTableEntry methodsFor: 'testing'! {BooleanVar} compare: anObj {Heaper | Position} ^ keyInternal isEqual: anObj! {UInt32} contentsHash ^super contentsHash bitXor: keyInternal hashForEqual! {BooleanVar} matches: anEntry {GrandEntry} ^ keyInternal isEqual: (anEntry cast: GrandTableEntry) position! ! !GrandTableEntry methodsFor: 'protected: creation'! create: value {Heaper} with: key {Position} with: hash {UInt32} super create: value with: hash. keyInternal _ key. self newShepherd. self remember! ! !GrandTableEntry methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. keyInternal _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: keyInternal.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandTableEntry class instanceVariableNames: ''! (GrandTableEntry getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !GrandTableEntry class methodsFor: 'create'! {GrandEntry} make: value {Heaper} with: key {Position} with: hash {UInt32} ^ self create: value with: key with: hash! !Abraham subclass: #GrandNode instanceVariableNames: ' primaryPages {PtrArray of: GrandDataPage} numPrimaries {Int32} overflowRoot {GrandOverflow} oldOverflowRoot {GrandOverflow} numReinserters {Int32}' classVariableNames: 'OverflowPageSize {Int32} ' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandNode comment: 'oldOverflowRoot holds onto the overflow tree that was in place when a node doubling starts. It allows an object stored to be found at any time during the doubling.'! (GrandNode getOrMakeCxxClassDescription) friends: '/* friends for class GrandNode */ friend class GrandNodeStepper; friend class GrandNodeDoubler; friend class GrandNodeReinserter; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNode methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} | result {Heaper} | result _ ((primaryPages fetch: aHash \\ numPrimaries) cast: GrandDataPage) fetch: toMatch with: aHash with: numPrimaries. result ~~ NULL ifTrue: [ ^ result ]. oldOverflowRoot ~~ NULL ifTrue: [^oldOverflowRoot fetch: toMatch with: aHash]. ^ NULL! {void} store.Entry: newEntry {GrandEntry} ((primaryPages fetch: newEntry hashForEqual \\ numPrimaries) cast: GrandDataPage) store.Entry: newEntry with: numPrimaries! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} ((primaryPages fetch: aHash \\ numPrimaries) cast: GrandDataPage) wipe: toMatch with: aHash with: numPrimaries. oldOverflowRoot ~~ NULL ifTrue: [oldOverflowRoot wipe: toMatch with: aHash]! ! !GrandNode methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandNode(numPages=' << numPrimaries << ')'! ! !GrandNode methodsFor: 'protected: creation'! create | aPage {GrandDataPage} | super create. overflowRoot _ NULL. oldOverflowRoot _ NULL. numReinserters _ Int32Zero. numPrimaries _ 1. primaryPages _ PtrArray nulls: 1. aPage _ GrandDataPage make: GrandNode primaryPageSize with: self with: UInt32Zero. primaryPages at: Int32Zero store: aPage. self newShepherd. self remember! {void} dismantle DiskManager consistent: 2 + numPrimaries with: [| page {Heaper} | primaryPages ~~ NULL ifTrue: [Int32Zero almostTo: numPrimaries do: [:i {Int32} | page _ (primaryPages fetch: i). page ~~ NULL ifTrue: [page destroy]]. primaryPages destroy]. overflowRoot ~~ NULL ifTrue: [overflowRoot destroy]. oldOverflowRoot ~~ NULL ifTrue: [oldOverflowRoot destroy]. super dismantle]! ! !GrandNode methodsFor: 'node doubling'! {void} addReinserter DiskManager consistent: 1 with: [numReinserters _ numReinserters + 1. self diskUpdate]! {void} doubleNode | newPage {GrandDataPage} newNumPrimaries {Int32} newPrimaries {PtrArray of: GrandDataPage} | DiskManager consistent: self doubleNodeConsistency with: [newNumPrimaries _ numPrimaries * 2. newPrimaries _ PtrArray nulls: newNumPrimaries. Int32Zero almostTo: numPrimaries do: [:i {Int32} | newPage _ ((primaryPages fetch: i) cast: GrandDataPage) makeDouble: newNumPrimaries. newPrimaries at: i store: (primaryPages fetch: i). newPrimaries at: newPage lowHashBits store: newPage]. primaryPages destroy. primaryPages _ newPrimaries. numPrimaries _ newNumPrimaries. "At this point, the structure is consistent, but still doesn't have the full benefit of the node doubling. Inserts will be faster now, but reinsertion of the overflow data is required for fetch to improve." overflowRoot ~~ NULL ifTrue: [oldOverflowRoot ~~ NULL ifTrue: [Heaper BLAST: #FallenBehindInNodeDoubling]. oldOverflowRoot _ overflowRoot. overflowRoot _ NULL. (GrandNodeReinserter make: self with: oldOverflowRoot) schedule]. self diskUpdate].! {IntegerVar} doubleNodeConsistency Eric knownBug. "Sometimes this is off by one in either direction" ^ 2 * numPrimaries + 2! {void} removeReinserter DiskManager consistent: 1 with: [numReinserters _ numReinserters - 1. numReinserters == Int32Zero ifTrue: [oldOverflowRoot destroy. oldOverflowRoot _ NULL]. self diskUpdate]! ! !GrandNode methodsFor: 'private: friendly access'! {GrandDataPage} pageAt: idx {IntegerVar} ^ (primaryPages fetch: idx DOTasLong) cast: GrandDataPage! {IntegerVar} pageCount ^ numPrimaries! ! !GrandNode methodsFor: 'testing'! {UInt32} contentsHash | result {UInt32} | result _ ((super contentsHash bitXor: primaryPages contentsHash) bitXor: (IntegerPos integerHash: numPrimaries)). overflowRoot ~~ NULL ifTrue: [result _ result bitXor: overflowRoot hashForEqual]. oldOverflowRoot ~~ NULL ifTrue: [result _ result bitXor: oldOverflowRoot hashForEqual]. ^ result! {BooleanVar} isEmpty UInt32Zero almostTo: numPrimaries do: [ :i {UInt32} | ((primaryPages fetch: i) cast: GrandDataPage) isEmpty ifFalse: [ ^ false ]]. ^ overflowRoot == NULL and: [oldOverflowRoot == NULL]! ! !GrandNode methodsFor: 'smalltalk: inspection'! inspect EntView make: self! inspectPieces | result | result _ primaryPages asOrderedCollection. overflowRoot ~~ NULL ifTrue: [result add: overflowRoot]. oldOverflowRoot ~~ NULL ifTrue: [result add: oldOverflowRoot]. ^result! ! !GrandNode methodsFor: 'overflow'! {GrandOverflow} fetchOldOverflow ^ oldOverflowRoot! {GrandOverflow} fetchOverflow ^overflowRoot! {GrandOverflow} getOverflow overflowRoot == NULL ifTrue: [DiskManager consistent: 2 with: [overflowRoot _ GrandOverflow create: OverflowPageSize with: 1. self diskUpdate]]. ^overflowRoot! ! !GrandNode methodsFor: 'special'! {IEEEDoubleVar} loadFactor | loadSum {IEEEDoubleVar} | loadSum _ 0.0. Int32Zero almostTo: numPrimaries do: [ :i {Int32} | loadSum _ loadSum + (((primaryPages fetch: i) cast: GrandDataPage) loadFactor)]. ^ loadSum / numPrimaries! ! !GrandNode methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. primaryPages _ receiver receiveHeaper. numPrimaries _ receiver receiveInt32. overflowRoot _ receiver receiveHeaper. oldOverflowRoot _ receiver receiveHeaper. numReinserters _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: primaryPages. xmtr sendInt32: numPrimaries. xmtr sendHeaper: overflowRoot. xmtr sendHeaper: oldOverflowRoot. xmtr sendInt32: numReinserters.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandNode class instanceVariableNames: ''! (GrandNode getOrMakeCxxClassDescription) friends: '/* friends for class GrandNode */ friend class GrandNodeStepper; friend class GrandNodeDoubler; friend class GrandNodeReinserter; '; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandNode class methodsFor: 'smalltalk: smalltalk initialization'! linkTimeNonInherited OverflowPageSize _ 8! ! !GrandNode class methodsFor: 'create'! make ^ self create! ! !GrandNode class methodsFor: 'static functions'! {Int32 INLINE} primaryPageSize ^ 128! !Abraham subclass: #GrandOverflow instanceVariableNames: ' numEntries {Int32} entries {PtrArray of: GrandEntry} children {PtrArray of: GrandOverflow} depth {Int32}' classVariableNames: 'OTreeArity {Int32} ' poolDictionaries: '' category: 'Xanadu-Collection-Grand'! GrandOverflow comment: 'This class has a comment The instance variable depth actually holds the value OTreeArity ^ depth.'! (GrandOverflow getOrMakeCxxClassDescription) friends: '/* friends for class GrandOverflow */ friend class GrandOverflowStepper;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandOverflow methodsFor: 'accessing'! {Heaper} fetch: toMatch {Heaper | Position} with: aHash {UInt32} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry} childIndex {UInt32} | localIndex _ originalIndex _ aHash // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [(aHash == entry hashForEqual) ifTrue: [(entry compare: toMatch) ifTrue: [^ entry value]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: [entry _ NULL "break from loop"]]. childIndex _ aHash // depth \\ OTreeArity. (children fetch: childIndex) ~~ NULL ifTrue: [^ ((children fetch: childIndex) cast: GrandOverflow) fetch: toMatch with: aHash]. ^NULL! {GrandOverflow} store.Entry: newEntry {GrandEntry} | localIndex {Int32} originalIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ newEntry hashForEqual // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [newEntry hashForEqual == entry hashForEqual ifTrue: [(newEntry matches: entry) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 2 with: [entry destroy. entries at: localIndex store: newEntry. self diskUpdate]. ^self]]. localIndex _ localIndex + 1 \\ numEntries. localIndex == originalIndex ifTrue: [| newChild {GrandOverflow} childIndex {UInt32} | "This page is now full. Descend overflow tree further." childIndex _ newEntry hashForEqual // depth \\ OTreeArity. (children fetch: childIndex) == NULL ifTrue: [DiskManager consistent: 2 with: [newChild _ GrandOverflow create: numEntries with: depth * OTreeArity. children at: childIndex store: newChild. self diskUpdate]]. ^((children fetch: childIndex) cast: GrandOverflow) store.Entry: newEntry]. entry _ (entries fetch: localIndex) cast: GrandEntry]. "Found empty slot." DiskManager consistent: 1 with: [entries at: localIndex store: newEntry. self diskUpdate]. ^self! {void} wipe: toMatch {Heaper | Position} with: aHash {UInt32} | localIndex {Int32} originalIndex {Int32} childIndex {Int32} entry {GrandEntry wimpy} | localIndex _ originalIndex _ aHash // depth \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. [entry ~~ NULL] whileTrue: [aHash == entry hashForEqual ifTrue: [(entry compare: toMatch) ifTrue: ["Note that this does not delete the contents" DiskManager consistent: 2 with: [entry destroy. entries at: localIndex store: NULL. self repack. self diskUpdate]. ^ VOID]]. localIndex _ localIndex + 1 \\ numEntries. entry _ (entries fetch: localIndex) cast: GrandEntry. localIndex == originalIndex ifTrue: ["break from loop" entry _ NULL]]. childIndex _ aHash // depth \\ OTreeArity. (children fetch: childIndex) ~~ NULL ifTrue: [((children fetch: childIndex) cast: GrandOverflow) wipe: toMatch with: aHash]! ! !GrandOverflow methodsFor: 'creation'! create: maxEntries {Int32} with: someDepth {UInt32} super create. numEntries _ maxEntries. entries _ PtrArray nulls: numEntries. children _ PtrArray nulls: OTreeArity. depth _ someDepth. self newShepherd. self remember! ! !GrandOverflow methodsFor: 'private:'! {void} repack "This repacks the entry table after a wipe to keep the table consistent with" "the linear hash collision resolution technique." | newEntries {PtrArray of: GrandEntry} entry {GrandEntry} preferedIndex {Int32} | newEntries _ PtrArray nulls: numEntries. Int32Zero almostTo: numEntries do: [ :i {Int32} | (entry _ (entries fetch: i) cast: GrandEntry) ~~ NULL ifTrue: [preferedIndex _ entry hashForEqual // depth \\ numEntries. (newEntries fetch: preferedIndex) ~~ NULL ifTrue: [[(newEntries fetch: preferedIndex) ~~ NULL] whileTrue: [preferedIndex _ preferedIndex + 1 \\ numEntries]]. newEntries at: preferedIndex store: entry]]. entries destroy. entries _ newEntries! ! !GrandOverflow methodsFor: 'node doubling'! {void} reinsertEntries: node {GrandNode} "Recursively insert all overflowed entries into a newly doubled node." | entry {GrandEntry} child {GrandOverflow} | DiskManager consistent: self reinsertEntriesConsistency with: [Int32Zero almostTo: numEntries do: [ :i {Int32} | entry _ (entries fetch: i) cast: GrandEntry. entry ~~ NULL ifTrue: [node store.Entry: entry. entries at: i store: NULL. self diskUpdate]]. Int32Zero almostTo: OTreeArity do: [ :j {Int32} | child _ (children fetch: j) cast: GrandOverflow. child ~~ NULL ifTrue: [(GrandNodeReinserter make: node with: child) schedule]]]! {IntegerVar} reinsertEntriesConsistency ^ 4 * numEntries + OTreeArity + 2! ! !GrandOverflow methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << 'GrandOverflow(depth=' << depth << ')'! ! !GrandOverflow methodsFor: 'protected: creation'! {void} dismantle DiskManager consistent: 1 + numEntries + OTreeArity with: [entries ~~ NULL ifTrue: [Int32Zero almostTo: numEntries do: [ :i {Int32} | | entry {GrandEntry} | entry _ (entries fetch: i) cast: GrandEntry. entry ~~ NULL ifTrue: [entry destroy]]. entries destroy]. children ~~ NULL ifTrue: [Int32Zero almostTo: OTreeArity do: [ :j {Int32} | | child {GrandOverflow} | child _ (children fetch: j) cast: GrandOverflow. child ~~ NULL ifTrue: [child destroy]]. children destroy]. super dismantle]! ! !GrandOverflow methodsFor: 'private: friendly'! {GrandOverflow} childAt: idx {IntegerVar} ^ (children fetch: idx DOTasLong) cast: GrandOverflow! {IntegerVar} childCount ^ OTreeArity! {GrandEntry} entryAt: idx {IntegerVar} ^ (entries fetch: idx DOTasLong) cast: GrandEntry! {IntegerVar} entryCount ^ numEntries! ! !GrandOverflow methodsFor: 'private: smalltalk: private'! inspectPieces ^(entries asOrderedCollection) addAll: children asOrderedCollection; yourself! ! !GrandOverflow methodsFor: 'testing'! {UInt32} contentsHash ^(((super contentsHash bitXor: (IntegerPos integerHash: numEntries)) bitXor: entries contentsHash) bitXor: children contentsHash) bitXor: (IntegerPos integerHash: depth)! ! !GrandOverflow methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. numEntries _ receiver receiveInt32. entries _ receiver receiveHeaper. children _ receiver receiveHeaper. depth _ receiver receiveInt32.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendInt32: numEntries. xmtr sendHeaper: entries. xmtr sendHeaper: children. xmtr sendInt32: depth.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrandOverflow class instanceVariableNames: ''! (GrandOverflow getOrMakeCxxClassDescription) friends: '/* friends for class GrandOverflow */ friend class GrandOverflowStepper;'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !GrandOverflow class methodsFor: 'smalltalk: smalltalk initialization'! linkTimeNonInherited OTreeArity _ 4! !Abraham subclass: #MultiCounter instanceVariableNames: ' myFirst {Counter} mySecond {Counter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-counter'! (MultiCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !MultiCounter methodsFor: 'accessing'! {void} decrementBoth DiskManager consistent: 2 with: [myFirst decrement. mySecond decrement]! {IntegerVar} decrementFirst ^myFirst decrement! {IntegerVar} decrementSecond ^mySecond decrement! {IntegerVar} firstCount ^myFirst count! {void} incrementBoth DiskManager consistent: 2 with: [myFirst increment. mySecond increment]! {IntegerVar} incrementFirst ^myFirst increment! {IntegerVar} incrementSecond ^mySecond increment! {IntegerVar} secondCount ^mySecond count! ! !MultiCounter methodsFor: 'creation'! create super create. myFirst _ Counter make: IntegerVar0. mySecond _ Counter make: IntegerVar0. self newShepherd. self remember! create: first {IntegerVar} super create. myFirst _ Counter make: first. mySecond _ Counter make: IntegerVar0. self newShepherd. self remember! create: first {IntegerVar} with: second {IntegerVar} super create. myFirst _ Counter make: first. mySecond _ Counter make: second. self newShepherd. self remember! ! !MultiCounter methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myFirst count << ', ' << mySecond count << ')'! ! !MultiCounter methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myFirst hashForEqual) bitXor: mySecond hashForEqual! ! !MultiCounter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myFirst _ receiver receiveHeaper. mySecond _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myFirst. xmtr sendHeaper: mySecond.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiCounter class instanceVariableNames: ''! (MultiCounter getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !MultiCounter class methodsFor: 'pseudo constructors '! make ^self create.! make: count {IntegerVar} ^self create: count! !Abraham subclass: #OPart instanceVariableNames: 'mySensorCrum {SensorCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OPart getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !OPart methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} "Attach the TrailBlazer to this Edition, and return the region of partiality it is attached to" self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} "Make sure that everyone below here that might have a TrailBlazer, has the given one" self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer "If there is a TrailBlazer somewhere below this Edition, return one of them" self subclassResponsibility! {HistoryCrum} hCrum self subclassResponsibility! ! !OPart methodsFor: 'accessing'! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: initial! {SensorCrum} sensorCrum ^mySensorCrum! ! !OPart methodsFor: 'protected: delete'! {void} dismantle DiskManager insistent: 2 with: [(Heaper isConstructed: mySensorCrum) ifTrue: [mySensorCrum removePointer: self]. ((Heaper isConstructed: self hCrum) and: [Heaper isConstructed: self hCrum bertCrum]) ifTrue: [self hCrum bertCrum removePointer: self hCrum]. super dismantle]! ! !OPart methodsFor: 'smalltalk:'! hinspect self hCrum inspect! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 5 @ 10)]! inspectCanopy self hCrum bertCrum inspect! inspectMenuArray ^#( ('inspect history' hinspect '') ('bert canopy' inspectCanopy '') ('recorder canopy' inspectRecorderCanopy ''))! inspectRecorderCanopy self sensorCrum inspect! showOn: oo oo << self getCategory name << $( << self hCrum hCut << ', ' << self hCrum asOop << ', ' << self hCrum oParents count << $)! ! !OPart methodsFor: 'protected: create'! create: scrum {SensorCrum | NULL} super create. scrum == NULL ifTrue: [mySensorCrum _ SensorCrum make] ifFalse: [mySensorCrum _ scrum]. mySensorCrum addPointer: self! create: hash {UInt32} with: scrum {SensorCrum | NULL} super create: hash. scrum == NULL ifTrue: [mySensorCrum _ SensorCrum make] ifFalse: [mySensorCrum _ scrum]. mySensorCrum addPointer: self! ! !OPart methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: mySensorCrum hashForEqual! ! !OPart methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OPart methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySensorCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySensorCrum.! !OPart subclass: #Loaf instanceVariableNames: 'myHCrum {HUpperCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (Loaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !Loaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." self thingToDo. "This should softSplay the position up." self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self subclassResponsibility! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Fill an array with my contents" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned, or NULL if it was all assigned." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !Loaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." self subclassResponsibility! {Loaf} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^InnerLoaf make: self with: externalDsp]! {Loaf} unTransformedBy: globalDsp {Dsp} "Return a copy with globalDsp removed from the receiver's dsp." globalDsp isIdentity ifTrue: [^self] ifFalse: [^InnerLoaf make: self with: (globalDsp inverse cast: Dsp)]! ! !Loaf methodsFor: 'splay'! {UInt8} splay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. Full containment cases can be handled generically." (limitRegion isSubsetOf: region) ifTrue: [^2] ifFalse: [(limitRegion intersects: region) ifTrue: [^self actualSplay: region with: limitRegion] ifFalse: [^Int0]]! ! !Loaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Speciall handle the splay cases in which the region partially intersects with limitedRegion. These require rotations and splitting." self subclassResponsibility! ! !Loaf methodsFor: 'backfollow'! {void} addOParent: oParent {OPart} "This should probably take a bertCanopyCrum argument, as well." "add oParent to the set of upward pointers." myHCrum addOParent: oParent. self remember. self diskUpdate! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children" self subclassResponsibility! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "check any recorders that might be triggered by a change in the edition. Walk leafward on O-plane, filtered by sensor canopy, ringing recorders. Not in a consistent block: It spawns unbounded work. " | newFinder {PropFinder} | "Shrink finder to just what may be on this branch of O-tree. If there might be something on this branch Check the children using the simplified finder." newFinder _ self sensorCrum checkRecorders: finder with: scrum. newFinder isEmpty ifFalse: [self checkChildRecorders: newFinder]! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "One step of walk south on the O-tree during the 'now' part of a backfollow." self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {HistoryCrum} hCrum ^myHCrum! {void} removeOParent: oparent {OPart} "remove oparent from the set of upward pointers." myHCrum removeOParent: oparent. myHCrum isEmpty ifTrue: ["Now we get into the risky part of deletion. There are no more upward pointers, so destroy the receiver." self destroy] ifFalse: [self diskUpdate]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} "Go ahead and actually store the recorder in the sensor canopy. However, instead of propogating the props immediately, accumulate all those agenda items into the 'agenda' parameter. This is done instead of scheduling them directly because our client needs to schedule something else following all the prop propogation." self subclassResponsibility! {void} triggerDetector: detect {FeFillRangeDetector} "A Detector has been added to my parent. Walk down and trigger it on all non-partial stuff" self subclassResponsibility! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !Loaf methodsFor: 'protected:'! {FeEdition} asFeEdition "Make a FeEdition out of myself. Used for triggering Detectors" CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: self hCrum bertCrum during: [^FeEdition on: (BeEdition make: (ActualOrglRoot make: self with: self domain))]]! {void} dismantle DiskManager insistent: 2 with: [super dismantle. myHCrum _ NULL]! ! !Loaf methodsFor: 'create'! create: hcrum {HUpperCrum | NULL} with: scrum {SensorCrum | NULL} super create: scrum. hcrum == NULL ifTrue: [myHCrum _ HUpperCrum make] ifFalse: [myHCrum _ hcrum]! create: hash {UInt32} with: hcrum {HUpperCrum | NULL} with: scrum {SensorCrum | NULL} super create: hash with: scrum. hcrum == NULL ifTrue: [myHCrum _ HUpperCrum make] ifFalse: [myHCrum _ hcrum]! ! !Loaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myHCrum hashForEqual! ! !Loaf methodsFor: 'smalltalk: passe'! {void} checkChildRecorders: stamp {BeEdition} with: finder {PropFinder} self passe "fewer args"! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedStoreMatching: finder {PropFinder} with: recorder {RecorderFossil} with: hCrumCache {HashSetCache of: HistoryCrum} self passe "extra argument"! {void} inform: key {Position} with: value {HRoot} with: trace {TracePosition} "inform a piece of partiality" self passe! {void} storeMatching: finder {PropFinder} with: table {MuTable of: ID and: BeEdition} with: hCrumCache {HashSetCache of: HistoryCrum} self passe! {void} wait: sensor {XnSensor} self passe! ! !Loaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Loaf class instanceVariableNames: ''! (Loaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !Loaf class methodsFor: 'create'! {Loaf} make.Region: region {XnRegion} with: element {BeCarrier} DiskManager consistent: 7 with: [^RegionLoaf create: region with: element fetchLabel with: element rangeElement with: NULL]! make.XnRegion: region {XnRegion} DiskManager consistent: 3 with: [^OPartialLoaf create: region with: NULL with: SensorCrum partial]! make: values {PrimDataArray} with: arrangement {Arrangement} DiskManager consistent: 4 with: [| tmp {SharedData} | tmp _ SharedData create: values with: arrangement. ^OVirtualLoaf create: arrangement region with: tmp]! !Loaf subclass: #InnerLoaf instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (InnerLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !InnerLoaf methodsFor: 'create'! create: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: hcrum with: scrum! create: hash {UInt32} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: hash with: hcrum with: scrum! ! !InnerLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Special handle the splay cases in which the region partially intersects with limitedRegion. These require rotations and splitting." self subclassResponsibility! ! !InnerLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self subclassResponsibility! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {Loaf} inPart "This is used by the splay algorithms." self subclassResponsibility! {Loaf} outPart "This is used by the splay algorithms." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned, or NULL if it was all assigned." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !InnerLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Inner loaf: Just forward south to all children." self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} self subclassResponsibility! {void} triggerDetector: detect {FeFillRangeDetector} self subclassResponsibility! ! !InnerLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." self subclassResponsibility! ! !InnerLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !InnerLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InnerLoaf class instanceVariableNames: ''! (InnerLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; yourself)! !InnerLoaf class methodsFor: 'create'! make: newO {Loaf} with: dsp {Dsp} "Make a loaf that transforms the contents of newO." DiskManager consistent: 11 with: [^DspLoaf create: newO with: dsp]! make: newSplit {XnRegion} with: newIn {Loaf} with: newOut {Loaf} "The contents of newIn must be completely contained in newSplit. newOut must be completely outside newSplit. Should this just forward to make:with:with:with:? This should extract shared dsp from newIn and newOut." DiskManager consistent: -1 with: [^SplitLoaf create: newSplit with: newIn with: newOut]! make: newSplit {XnRegion} with: newIn {Loaf} with: newOut {Loaf} with: hcrum {HUpperCrum} "The contents of newIn must be completely contained in newSplit. newOut must be completely outside newSplit" DiskManager consistent: 6 with: [^SplitLoaf create: newSplit with: newIn with: newOut with: hcrum]! !InnerLoaf subclass: #DspLoaf instanceVariableNames: ' myDsp {Dsp} myO {Loaf}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (DspLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DspLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^(myO compare: trace with: (myDsp inverseOfAll: region)) transformedBy: (myDsp inverse cast: Dsp)! {IntegerVar} count ^myO count! {XnRegion} domain ^myDsp ofAll: myO domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." ^myO fetch: (myDsp inverseOf: key) with: edition with: globalKey! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." ^myO fetchBottomAt: (myDsp inverseOf: key)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." keys isEmpty ifFalse: [myO fill: (myDsp inverseOfAll: keys) with: toArrange with: toArray with: (globalDsp compose: myDsp) with: edition]! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." ^myO getBe: (myDsp inverseOf: key)! {Loaf} inPart "This is used by the splay algorithms." ^(myO cast: InnerLoaf) inPart transformedBy: myDsp! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: (initial preCompose: myDsp)! {Loaf} outPart "This is used by the splay algorithms." ^(myO cast: InnerLoaf) outPart transformedBy: myDsp! {XnRegion} rangeOwners: positions {XnRegion | NULL} positions == NULL ifTrue: [^myO rangeOwners: NULL]. positions isEmpty ifTrue: [^IDSpace global emptyRegion] ifFalse: [^myO rangeOwners: (myDsp inverseOfAll: positions)]! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned." ^(myO setAllOwners: owner) transformedBy: myDsp! {XnRegion} usedDomain ^myDsp ofAll: myO usedDomain! ! !DspLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region." | dsp {Dsp} | dsp _ myDsp. ^myO splay: (dsp inverseOfAll: region) with: (dsp inverseOfAll: limitRegion)! ! !DspLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." ^myO bundleStepper: region with: order with: (globalDsp compose: myDsp)! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} "Accumulate dsp downward." ^myO combine: another with: limitRegion with: (globalDsp compose: myDsp)! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myDsp ofAll: (myO keysLabelled: label)! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff that can backfollow to trace." (self hCrum inTrace: trace) ifTrue: [^self domain] ifFalse: [^myDsp ofAll: (myO sharedRegion: trace with: (myDsp inverseOfAll: limitRegion))]! {Loaf} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^myO transformedBy: (externalDsp compose: myDsp)]! {Loaf} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." externalDsp isIdentity ifTrue: [^self] ifFalse: [^myO unTransformedBy: (myDsp minus: externalDsp)]! ! !DspLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << '(' << myDsp << ')'! ! !DspLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums my child." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myO updateBCrumTo: newBCrum]! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^myDsp ofAll: (myO attachTrailBlazer: blazer)! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children" myO checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myO checkTrailBlazer: blazer! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myO delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer ^myO fetchTrailBlazer! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myO storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} self sensorCrum isPartial ifTrue: [myO triggerDetector: detect] ifFalse: [detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myO updateBCrumTo: newBCrum. ^true]. ^false! ! !DspLoaf methodsFor: 'create'! create: loaf {Loaf} with: dsp {Dsp} super create: NULL with: loaf sensorCrum. myO _ loaf. myDsp _ dsp. "Connect the HTrees." self newShepherd. myO addOParent: self.! ! !DspLoaf methodsFor: 'smalltalk:'! crums ^ Array with: myO! {BooleanVar} testChild: child {Loaf} "Return true if child is a child. Used for debugging." ^myO isEqual: child! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^myO hCrum == child! ! !DspLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 3 with: [(Heaper isConstructed: myO) ifTrue: [myO removeOParent: self]. super dismantle]! ! !DspLoaf methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myDsp hashForEqual) bitXor: myO hashForEqual! ! !DspLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !DspLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myDsp _ receiver receiveHeaper. myO _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myDsp. xmtr sendHeaper: myO.! !InnerLoaf subclass: #SplitLoaf instanceVariableNames: ' mySplit {XnRegion} myIn {Loaf} myOut {Loaf}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (SplitLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME.ANY.SUBCLASS.OF OExpandingLoaf ); add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; yourself)! !SplitLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^(myIn compare: trace with: (region intersect: mySplit)) combine: (myOut compare: trace with: (region minus: mySplit))! {IntegerVar} count ^myIn count + myOut count! {XnRegion} domain ^myIn domain unionWith: myOut domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Look up the range element for the key. If it is embedded within a virtual structure, then make a virtual range element using the edition and globalKey." (mySplit hasMember: key) ifTrue: [^myIn fetch: key with: edition with: globalKey] ifFalse: [^myOut fetch: key with: edition with: globalKey]! {OExpandingLoaf} fetchBottomAt: key {Position} "Return the bottom-most Loaf. Used to get the owner and such of a position." self thingToDo. "This should be splaying!!" (mySplit hasMember: key) ifTrue: [^myIn fetchBottomAt: key] ifFalse: [^myOut fetchBottomAt: key]! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self thingToDo. "This should be splaying!!" (mySplit hasMember: key) ifTrue: [^myIn getBe: key] ifFalse: [^myOut getBe: key]! {Loaf} inPart "This effectively copies the region represented by my distinction." ^myIn! {BooleanVar} isLeaf ^false! {Loaf} outPart "This is used by the splay algorithms." ^myOut! {XnRegion} rangeOwners: positions {XnRegion | NULL} | result {XnRegion} | positions == NULL ifTrue: [^(myIn rangeOwners: NULL) unionWith: (myIn rangeOwners: NULL)]. result _ IDSpace global emptyRegion. (mySplit intersects: positions) ifTrue: [result _ myIn rangeOwners: positions]. (mySplit complement intersects: positions) ifTrue: [result _ (myIn rangeOwners: positions) unionWith: result]. ^result! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the o-tree that couldn't be assigned." | in {OrglRoot} out {OrglRoot} | in _ myIn setAllOwners: owner. out _ myOut setAllOwners: owner. in isEmpty ifTrue: [^out]. out isEmpty ifTrue: [^in]. ((in cast: ActualOrglRoot) fullcrum == myIn and: [(out cast: ActualOrglRoot) fullcrum == myOut]) ifTrue: [^ActualOrglRoot make: self with: (in simpleDomain simpleUnion: out simpleDomain)]. ^(in cast: ActualOrglRoot) makeNew: mySplit with: (in cast: ActualOrglRoot) with: (out cast: ActualOrglRoot)! {XnRegion} usedDomain ^myIn usedDomain unionWith: myOut usedDomain! ! !SplitLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | local {XnRegion} in {Stepper} out {Stepper} | local _ globalDsp inverseOfAll: region. in _ out _ NULL. (mySplit intersects: local) ifTrue: [in _ myIn bundleStepper: region with: order with: globalDsp]. (mySplit complement intersects: local) ifTrue: [out _ myOut bundleStepper: region with: order with: globalDsp]. in == NULL ifTrue: [out == NULL ifTrue: [^Stepper emptyStepper] ifFalse: [^out]] ifFalse: [out == NULL ifTrue: [^in] ifFalse: [^MergeBundlesStepper make: in with: out with: order]]! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion} with: globalDsp {Dsp} "Break another into pieces according to mySplit, and combine the corresponding pieces with my children transformed to global coordinates. Combine the two non-overlapping results." | newIn {ActualOrglRoot} newOut {ActualOrglRoot} hisIn {OrglRoot} hisOut {OrglRoot} globalIn {XnRegion} globalOut {XnRegion} | globalIn _ globalDsp ofAll: mySplit. globalOut _ globalIn complement. newIn _ ActualOrglRoot make: (myIn transformedBy: globalDsp) with: (limitRegion intersect: globalIn). newOut _ ActualOrglRoot make: (myOut transformedBy: globalDsp) with: (limitRegion intersect: globalOut). hisIn _ another copy: globalIn. hisOut _ another copy: globalOut. "Can this assume that the results don't overlap?" ^newIn makeNew: globalIn with: ((newIn combine: hisIn) cast: ActualOrglRoot) with: ((newOut combine: hisOut) cast: ActualOrglRoot)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." myIn fill: (keys intersect: mySplit) with: toArrange with: toArray with: globalDsp with: edition. myOut fill: (keys intersect: mySplit complement) with: toArrange with: toArray with: globalDsp with: edition.! {void} informTo: orgl {OrglRoot unused} "Copy the enclosure in orgl appropriate for this crum, then hand it down to the subCrums." self unimplemented. "orgl isKnownEmpty ifFalse: [myLeft informTo: ((orgl copy: leftWisp externalRegion) unTransformedBy: leftWisp dsp). myRight informTo: ((orgl copy: rightWisp externalRegion) unTransformedBy: rightWisp dsp)]"! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^(myIn keysLabelled: label) unionWith: (myOut keysLabelled: label)! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion} "Return a region describing the stuff I share with the orgl under trace." (self hCrum inTrace: trace) ifTrue: [^self domain] ifFalse: [^(myIn sharedRegion: trace with: (limitRegion intersect: mySplit)) unionWith: (myOut sharedRegion: trace with: (limitRegion intersect: mySplit complement))]! ! !SplitLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} [myIn == nil ifTrue: [aStream << self getCategory name << '(nil)'. ^VOID]] smalltalkOnly. aStream << '(' << mySplit << ', ' << myIn << ', ' << myOut << ')'! ! !SplitLoaf methodsFor: 'create'! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} super create: NULL with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} super create: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} with: hash {UInt32} super create: hash with: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self newShepherd. myIn addOParent: self. myOut addOParent: self.! create: split {XnRegion} with: inLoaf {Loaf} with: outLoaf {Loaf} with: hcrum {HUpperCrum} with: hash {UInt32} with: info {FlockInfo} "Special constructor for becoming this class" super create: hash with: hcrum with: ((inLoaf sensorCrum computeJoin: outLoaf sensorCrum) cast: SensorCrum). myIn _ inLoaf. myOut _ outLoaf. mySplit _ split. "Connect the HTrees." self flockInfo: info. myIn addOParent: self. myOut addOParent: self. self diskUpdate! ! !SplitLoaf methodsFor: 'smalltalk:'! crums ^((mySplit respondsTo: #isBoundedAbove) and: [mySplit isBoundedAbove]) ifTrue: [Array with: myIn with: myOut] ifFalse: [Array with: myOut with: myIn]! displayString ^'<', mySplit displayString, '>'! {BooleanVar} testChild: child {Loaf} "Return true if child is a child. Used for debugging." ^(myIn isEqual: child) or: [myOut isEqual: child]! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^(myIn hCrum == child) or: [myOut hCrum == child]! ! !SplitLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums in southern children." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. "My bertCrum may have been changed by the last operation." newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myIn updateBCrumTo: newBCrum. myOut updateBCrumTo: newBCrum] ifFalse: [(newBCrum isLE: bCrum) assert: 'unrelated bertCrums. Call dean!!']! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^(myIn attachTrailBlazer: blazer) unionWith: (myOut attachTrailBlazer: blazer)! {void} checkChildRecorders: finder {PropFinder} myIn checkRecorders: finder with: self sensorCrum. myOut checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myIn checkTrailBlazer: blazer. myOut checkTrailBlazer: blazer.! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} myIn delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache. myOut delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer | result {TrailBlazer | NULL} | result := myIn fetchTrailBlazer. result ~~ NULL ifTrue: [^result] ifFalse: [^myOut fetchTrailBlazer]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myIn storeRecordingAgents: recorder with: agenda. myOut storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} self sensorCrum isPartial ifTrue: [myIn triggerDetector: detect. myOut triggerDetector: detect] ifFalse: ["there is no partiality below me so I can just trigger it with everything" detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myIn updateBCrumTo: newBCrum. myOut updateBCrumTo: newBCrum. ^true]. ^false! ! !SplitLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. The transformation table follows: # in out return operation rearrange 1| 0 0 0 none none 2| 0 1 1 swap #4 (A (B* C)) -> (B* (A C)) 3| 0 2 1 swap #7 (A B*) -> (B* A) 4| 1 0 1 rotateRight ((A* B) C) -> (A* (B C)) 5| 1 1 1 interleave ((A* B) (C* D)) -> ((A* C*) (B D)) 6| 1 2 1 swap #8 ((A* B) C*) -> ((A* C*) B) 7| 2 0 1 none none 8| 2 1 1 rotateLeft (A* (B* C)) -> ((A* B*) C) 9| 2 2 2 none none" | in {UInt8} out {UInt8} | "For each child, compute the number of grandchildren completely contained in region." in _ myIn splay: region with: (mySplit intersect: limitRegion). out _ myOut splay: region with: (mySplit complement intersect: limitRegion). DiskManager consistent: 19 with: ["Swap the out and in sides if necessary to reduce the number of cases." out > in ifTrue: [| cnt {UInt8} | cnt _ out. out _ in. in _ cnt. self swapChildren]. "The hard cases are when a child is partially contained (in or out = 1). For those cases, construct the two new children, then install them." (in == 1 or: [out == 1]) ifTrue: [| newIn {Loaf} newOut {Loaf} | out == Int0 ifTrue: [newIn _ (myIn cast: InnerLoaf) inPart. newOut _ self makeNew: (myIn cast: InnerLoaf) outPart with: myOut] ifFalse: [in == 2 ifTrue: [newIn _ self makeNew: myIn with: (myOut cast: InnerLoaf) inPart. newOut _ (myOut cast: InnerLoaf) outPart] ifFalse: [newIn _ self makeNew: (myIn cast: InnerLoaf) inPart with: (myOut cast: InnerLoaf) inPart. newOut _ self makeNew: (myIn cast: InnerLoaf) outPart with: (myOut cast: InnerLoaf) outPart]]. "The splayed region represents the newDistinction for me in the split cases." self install: newIn with: newOut with: region. ^1] ifFalse: ["The non-rotating cases: ^in==0 ifTrue: [0] ifFalse: [ out==0 ifTrue: [1] ifFalse: [2] ]" "The 1 case here should change mySplit to the incoming one." ^in + out // 2]]! ! !SplitLoaf methodsFor: 'private: splay'! {void} install: newIn {Loaf} with: newOut {Loaf} with: newSplit {XnRegion} "Install new in and out children at the same time. This will need to be in a critical section. Add me as parent to the new loaves first in case the only ent reference to the new loaf is through one of my children (which might delete it if I'm *their* last reference)." newIn addOParent: self. newOut addOParent: self. myIn removeOParent: self. myIn _ newIn. myOut removeOParent: self. myOut _ newOut. mySplit _ newSplit. self thingToDo. "This shouldn't update the disk if the swapChildren already did." self diskUpdate! {Loaf} makeNew: newIn {Loaf} with: newOut {Loaf} "Make a new crum to replace some existing crums during a splay operation. The new crum must have the same trace as me to guarantee the hTree property. Optimization: look at parents of the new loaves to find a pre-existing parent with the same trace and wisps. This will coalesce the shearing that splaying causes." "The new loaf is made from pieces of me, so they are distinguished by my split." ^InnerLoaf make: mySplit with: newIn with: newOut with: (HUpperCrum make: (self hCrum cast: HUpperCrum))! {void} swapChildren "This is a support for the splay routine. Swapping the children reduces the number of cases. This way, if this crum is partially in a region being splayed, the part contained in the region resides in the left slot." | loaf {Loaf} | mySplit _ mySplit complement. loaf _ myIn. myIn _ myOut. myOut _ loaf. self thingToDo. "Swapping may be expensive if it's unnecessary. Check more cases in the splay routine." self diskUpdate! ! !SplitLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myIn) ifTrue: [myIn removeOParent: self]. (Heaper isConstructed: myOut) ifTrue: [myOut removeOParent: self]. super dismantle]! ! !SplitLoaf methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: mySplit hashForEqual) bitXor: myIn hashForEqual) bitXor: myOut hashForEqual! ! !SplitLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !SplitLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. mySplit _ receiver receiveHeaper. myIn _ receiver receiveHeaper. myOut _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: mySplit. xmtr sendHeaper: myIn. xmtr sendHeaper: myOut.! !Loaf subclass: #OExpandingLoaf instanceVariableNames: 'myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! OExpandingLoaf comment: ' NOT.A.TYPE'! (OExpandingLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #DEFERRED; add: #SHEPHERD.ANCESTOR; add: #DEFERRED.LOCKED; add: #(MAY.BECOME SplitLoaf ); yourself)! !OExpandingLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: another {ActualOrglRoot} with: limitRegion {XnRegion unused} with: globalDsp {Dsp} "Accumulate dsp downward." | myGlobalRegion {XnRegion} result {ActualOrglRoot} him {OrglRoot} | myGlobalRegion _ (globalDsp ofAll: myRegion). (another copy: myGlobalRegion) isEmpty ifFalse: [Heaper BLAST: #IntersectingCombine]. result _ ActualOrglRoot make: (self transformedBy: globalDsp) with: myGlobalRegion. him _ another. [ScruSet] USES. myGlobalRegion distinctions stepper forEach: [:split {XnRegion} | | hisOut {OrglRoot} | hisOut _ him copy: split complement. hisOut isEmpty ifFalse: [result _ result makeNew: split with: result with: (hisOut cast: ActualOrglRoot). him _ another copy: split]]. him isEmpty ifFalse: [Heaper BLAST: #CombineLoopFailed]. ^result! {void} informTo: orgl {OrglRoot unused} self unimplemented! {Boolean} isPartial ^false! {UInt8} splay: region {XnRegion} with: limitRegion {XnRegion} "Make each child completely contained or completely outside the region. Return the number of children completely in the region. Handle the containment cases using myRegion." (myRegion isSubsetOf: region) ifTrue: [^2] ifFalse: [(myRegion intersects: region) ifTrue: [^self actualSplay: region with: limitRegion] ifFalse: [^Int0]]! ! !OExpandingLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkChildRecorders: finder {PropFinder} "send checkRecorders to all children"! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "Default south-to-north turnaround point during 'now' part of backfollow (which is leafward, then rootward, in the H-tree, filtered by the Bert canopy). (Sometimes overridden). (OExpandingLoaf is the supercalss of all O-tree leaf types.)" self hCrum delayedStoreBackfollow: finder with: fossil with: recorder with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} agenda registerItem: (self sensorCrum recordingAgent: recorder)! {void} triggerDetector: detect {FeFillRangeDetector} self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^self hCrum mappingTo: trace with: (region coordinateSpace identityDsp restrict: region)! {IntegerVar} count ^myRegion count! {XnRegion} domain ^myRegion! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} self subclassResponsibility! {OExpandingLoaf} fetchBottomAt: key {Position} "I'm at the bottom." ^self! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: globalDsp {Dsp} with: edition {BeEdition} "Fill an array with my contents" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "This gets overridden by RegionLoaf." ^self domain coordinateSpace emptyRegion! {ID} owner "Return the owner of the atoms represented by the receiver." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} (positions == NULL or: [myRegion intersects: positions]) ifTrue: [^self owner asRegion] ifFalse: [^self owner coordinateSpace emptyRegion]! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion unused} "Return a region describing the stuff that can backfollow to trace." (self hCrum inTrace: trace) ifTrue: [^myRegion] ifFalse: [^myRegion coordinateSpace emptyRegion]! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myRegion << ')'! ! !OExpandingLoaf methodsFor: 'protected: splay'! {Int8} actualSplay: region {XnRegion unused} with: limitRegion {XnRegion unused} "Return an Inner loaf which is an expansion of me. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!! implementations must call diskUpdate." self subclassResponsibility! ! !OExpandingLoaf methodsFor: 'create'! create: region {XnRegion} super create: NULL with: NULL. region isEmpty not assert. myRegion _ region.! create: region {XnRegion} with: hcrum {HUpperCrum | NULL} with: sensor {SensorCrum} super create: hcrum with: sensor. region isEmpty not assert. myRegion _ region.! create: hash {UInt32} with: region {XnRegion} with: hcrum {HUpperCrum} with: sensor {SensorCrum} super create: hash with: hcrum with: sensor. region isEmpty not assert. myRegion _ region.! ! !OExpandingLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRegion hashForEqual! ! !OExpandingLoaf methodsFor: 'smalltalk:'! crums ^#()! displayString ^'"' , myRegion printString , '"'! inspect self basicInspect! ! !OExpandingLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OExpandingLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRegion.! !OExpandingLoaf subclass: #OPartialLoaf instanceVariableNames: ' myOwner {ID} myTrailBlazer {TrailBlazer | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OPartialLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #CONCRETE; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #(MAY.BECOME RegionLoaf ); yourself)! !OPartialLoaf methodsFor: 'accessing'! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual PlaceHolder." (self domain hasMember: key) ifTrue: [^FePlaceHolder fake: edition with: globalKey] ifFalse: [^NULL]! {BeRangeElement} getBe: key {Position} "Get or make the BeRangeElement at the location." "My region had better be just onto the key. become a RegionLoaf onto a new BePlaceHolder" | element {BeRangeElement} domain {XnRegion} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo}| domain _ key asRegion. (self domain isEqual: domain) ifFalse: [Heaper BLAST: #NotInTable]. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. DiskManager consistent: [self sensorCrum removePointer: self. InitialOwner fluidBind: self owner during: [[Ent] USES. CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: BertCrum make during: [element _ BePlaceHolder create: myTrailBlazer. myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer removeReference: self. myTrailBlazer := NULL]]]]. (RegionLoaf new.Become: self) create: domain with: element with: hcrum with: hash with: info]. ^element! {ID} owner "Return the owner of the atoms represented by the receiver." ^myOwner! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self unimplemented. ^PrimSpec pointer! {XnRegion} usedDomain ^self domain coordinateSpace emptyRegion! ! !OPartialLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. ^Stepper itemStepper: (FePlaceHolderBundle make: bundleRegion)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." (keys intersect: self domain) stepper forEach: [:key {Position} | | globalKey {Position} | globalKey _ dsp of: key. toArray at: (toArrange indexOf: globalKey) DOTasLong storeValue: (FePlaceHolder fake: edition with: globalKey)]! {void} informTo: orgl {OrglRoot unused} self unimplemented! {Boolean} isPartial "Partial crums are always partial." ^true! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myOwner) ifTrue: [myOwner _ owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !OPartialLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand me in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | crums {Pair of: SensorCrum} tmp1 {Loaf} tmp2 {Loaf} | crums _ self sensorCrum expand. DiskManager consistent: 3 with: [tmp1 _ OPartialLoaf create: (self domain intersect: region) with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums left cast: SensorCrum) with: myOwner with: myTrailBlazer]. DiskManager consistent: 3 with: [tmp2 _ OPartialLoaf create: (self domain intersect: region complement) with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums right cast: SensorCrum) with: myOwner with: myTrailBlazer]. myTrailBlazer ~~ NULL ifTrue: [DiskManager consistent: 1 with: [myTrailBlazer addReference: tmp1. myTrailBlazer addReference: tmp2. myTrailBlazer removeReference: self]]. DiskManager consistent: 5 with: [| hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} oldSensorCrum {CanopyCrum} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. oldSensorCrum _ self sensorCrum. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info. "The new SplitLoaf will add itself." oldSensorCrum removePointer: self]. ^1! ! !OPartialLoaf methodsFor: 'create'! create: region {XnRegion} super create: region. myOwner _ InitialOwner fluidFetch. myTrailBlazer := NULL. self newShepherd! create: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: region with: hcrum with: scrum. myOwner _ InitialOwner fluidFetch. myTrailBlazer := NULL. self newShepherd! create: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} with: owner {ID} with: blazer {TrailBlazer | NULL} super create: region with: hcrum with: scrum. myOwner := owner. myTrailBlazer := blazer. self newShepherd! ! !OPartialLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myTrailBlazer) ifTrue: [myTrailBlazer removeReference: self]. super dismantle]! ! !OPartialLoaf methodsFor: 'smalltalk: passe'! {void} inform: key {Position} with: element {BeRangeElement} with: trace {TracePosition} "inform a piece of partiality" self passe. [| in {XnRegion} impartial {Loaf} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} sensors {ImmuSet} | (self domain hasMember: key) ifFalse: [Heaper BLAST: #NotInTable]. (self hCrum hCut isEqual: trace) ifFalse: [Heaper BLAST: #CantInform]. in _ key asRegion. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. Someone shouldImplement. self unimplemented. "used to be detectors. sensors _ mySensors." (in isEqual: self domain) ifTrue: [impartial _ self. self sensorCrum removePointer: self. (RegionLoaf new.Become: self) create: in with: element with: (HUpperCrum make: hcrum) with: hash with: info] ifFalse: [ | partial {Loaf} | impartial _ Loaf make.Region: in with: (CurrentGrandMap fluidGet carrier: element). partial _ OPartialLoaf make: (self domain minus: in) with: (HUpperCrum make: hcrum) with: self sensorCrum. self sensorCrum removePointer: self. (SplitLoaf new.Become: self) create: in with: impartial with: partial with: hcrum with: hash with: info]. "self flockInfo: info." Dean shouldImplement. "sensors stepper forEach: [ :sensor {XnSensor} | sensor ring: impartial]"] smalltalkOnly "so we can look at the old code"! {void} wait: sensor {XnSensor} self passe! ! !OPartialLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} DiskManager consistent: 2 with: [myTrailBlazer ~~ NULL ifTrue: [myTrailBlazer isAlive ifTrue: [Heaper BLAST: #FatalError] ifFalse: [myTrailBlazer removeReference: self]]. myTrailBlazer := blazer. blazer addReference: self. self diskUpdate]. ^self domain! {void} checkTrailBlazer: blazer {TrailBlazer} (myTrailBlazer ~~ NULL and: [myTrailBlazer isEqual: blazer]) ifFalse: [Heaper BLAST: #InvalidTrail].! {TrailBlazer | NULL} fetchTrailBlazer (myTrailBlazer == NULL or: [myTrailBlazer isAlive]) ifTrue: [^myTrailBlazer]. "it was not successfully attached, so clean it up" DiskManager consistent: 2 with: [myTrailBlazer removeReference: self. myTrailBlazer := NULL. self diskUpdate. ^NULL]! {void} triggerDetector: detect {FeFillRangeDetector} "do nothing"! ! !OPartialLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOwner _ receiver receiveHeaper. myTrailBlazer _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOwner. xmtr sendHeaper: myTrailBlazer.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OPartialLoaf class instanceVariableNames: ''! (OPartialLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #NOT.A.TYPE; add: #CONCRETE; add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #(MAY.BECOME RegionLoaf ); yourself)! !OPartialLoaf class methodsFor: 'smalltalk: passe'! {Loaf} make: region {XnRegion} with: hcrum {HUpperCrum} with: scrum {SensorCrum} self passe! !OExpandingLoaf subclass: #OVirtualLoaf instanceVariableNames: ' myOwner {ID} myData {SharedData}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OVirtualLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !OVirtualLoaf methodsFor: 'accessing'! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual DataHolder." (self domain hasMember: key) ifTrue: [^FeDataHolder fake: ((myData fetch: key) cast: PrimValue) with: globalKey with: edition] ifFalse: [^NULL]! {BeRangeElement} getBe: key {Position} "Get or make the BeRangeElement at the location." "My region had better be just onto the key. become a RegionLoaf onto a new BeDataHolder containing the data extracted from my SharedData object." | element {BeRangeElement} domain {XnRegion} hcrum {HUpperCrum} hash {UInt32} info {FlockInfo}| domain _ key asRegion. (self domain isEqual: domain) ifFalse: [Heaper BLAST: #NotInTable]. hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. DiskManager consistent: [| oldSensorCrum {CanopyCrum} | oldSensorCrum _ self sensorCrum. [Ent] USES. InitialOwner fluidBind: self owner during: [CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: BertCrum make during: [element _ BeDataHolder create: ((myData fetch: key) cast: PrimValue)]]]. (RegionLoaf new.Become: self) create: domain with: element with: hcrum with: hash with: info. oldSensorCrum removePointer: self]. ^element! {ID} owner "Return the owner of the atoms represented by the receiver." ^myOwner! {PrimSpec} spec "Return the primSpec for my data." ^myData spec! {XnRegion} usedDomain ^self domain! ! !OVirtualLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} array {PrimArray} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. array _ myData spec array: bundleRegion count DOTasLong. myData fill: bundleRegion with: (order arrange: bundleRegion) with: array with: globalDsp. ^Stepper itemStepper: (FeArrayBundle make: bundleRegion with: array with: order)! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} myData fill: (keys intersect: self domain) with: toArrange with: toArray with: dsp! {void} informTo: orgl {OrglRoot unused} self unimplemented! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myOwner) ifTrue: [myOwner _ owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !OVirtualLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << "(myData table subTable: self domain) <<" ', ' << self hCrum hCut << ')'! ! !OVirtualLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand my virtual tree in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | crums {Pair of: SensorCrum} tmp1 {Loaf} tmp2 {Loaf} | crums _ self sensorCrum expand. InitialOwner fluidBind: self owner during: [DiskManager consistent: 3 with: [tmp1 _ OVirtualLoaf create: (self domain intersect: region) with: myData with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums left cast: SensorCrum)]. DiskManager consistent: 3 with: [tmp2 _ OVirtualLoaf create: (self domain intersect: region complement) with: myData with: (HUpperCrum make: (self hCrum cast: HUpperCrum)) with: (crums right cast: SensorCrum)]. DiskManager consistent: 5 with: [| hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} oldSensorCrum {CanopyCrum} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. oldSensorCrum _ self sensorCrum. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info. "The new SplitLoaf will add itself." oldSensorCrum removePointer: self]]. ^1! ! !OVirtualLoaf methodsFor: 'create'! create: region {XnRegion} with: data {SharedData} super create: region. myData _ data. myOwner _ InitialOwner fluidFetch. self newShepherd! create: region {XnRegion} with: data {SharedData} with: hcrum {HUpperCrum} with: scrum {SensorCrum} super create: region with: hcrum with: scrum. myData _ data. myOwner _ InitialOwner fluidFetch. self newShepherd! ! !OVirtualLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myData contentsHash! ! !OVirtualLoaf methodsFor: 'smalltalk:'! showOn: oo oo << myData! ! !OVirtualLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !OVirtualLoaf methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^self domain coordinateSpace emptyRegion! {void} checkTrailBlazer: blazer {TrailBlazer} "it's OK"! {TrailBlazer | NULL} fetchTrailBlazer ^NULL! {void} triggerDetector: detect {FeFillRangeDetector} detect rangeFilled: self asFeEdition! ! !OVirtualLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOwner _ receiver receiveHeaper. myData _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOwner. xmtr sendHeaper: myData.! !OExpandingLoaf subclass: #RegionLoaf instanceVariableNames: ' myRangeElement {BeRangeElement} myLabel {BeLabel}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (RegionLoaf getOrMakeCxxClassDescription) attributes: ((Set new) add: #COPY; add: #SHEPHERD.ANCESTOR; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !RegionLoaf methodsFor: 'accessing'! {Mapping} compare: trace {TracePosition} with: region {XnRegion} "return a mapping from my data to corresponding stuff in the given trace" ^myRangeElement mappingTo: trace with: (region coordinateSpace identityDsp restrict: region)! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} with: globalKey {Position} "Make a virtual DataHolder." (self domain hasMember: key) ifTrue: [^myRangeElement makeFe: myLabel] ifFalse: [^NULL]! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} with: edition {BeEdition} "Make an FeRangeElement for each position." (keys intersect: self domain) stepper forEach: [:key {Position} | | globalKey {Position} fe {FeRangeElement} | globalKey _ dsp of: key. fe := myRangeElement makeFe: myLabel. toArray at: (toArrange indexOf: globalKey) DOTasLong storeValue: fe]! {void} forwardTo: rangeElement {BeRangeElement} DiskManager consistent: [rangeElement addOParent: self. myRangeElement removeOParent: self. myRangeElement _ rangeElement. self diskUpdate]. Ravi thingToDo. "Is there a lazier way to make the FeEdition?" self hCrum bertCrum isSensorWaiting ifTrue: [self hCrum ringDetectors: self asFeEdition]! {BeRangeElement} getBe: key {Position} "If I'm here it must be non-virtual." (self domain hasMember: key) ifTrue: [^myRangeElement] ifFalse: [Heaper BLAST: #NotInTable. ^NULL]! {XnRegion} keysLabelled: label {BeLabel} "The keys in this Edition at which there are Editions with the given label." (myLabel ~~ NULL and: [myLabel isEqual: label]) ifTrue: [^self domain] ifFalse: [^self domain coordinateSpace emptyRegion]! {Mapping} mappingTo: trace {TracePosition} with: initial {Mapping} "return the mapping into the domain space of the given trace" ^self hCrum mappingTo: trace with: ((Mapping make: initial coordinateSpace with: self domain) restrict: initial domain)! {ID} owner "Return the owner of the atoms represented by the receiver." ^myRangeElement owner! {XnRegion} sharedRegion: trace {TracePosition} with: limitRegion {XnRegion unused} "Return a region describing the stuff that can backfollow to trace. Redefine this to pass down to my hRoot." (myRangeElement inTrace: trace) ifTrue: [^self domain] ifFalse: [^self domain coordinateSpace emptyRegion]! {PrimSpec} spec "Return the PrimSpec that describes the representation of the data." self unimplemented. ^PrimSpec pointer! {XnRegion} usedDomain ^self domain! ! !RegionLoaf methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} with: globalDsp {Dsp} "Return a stepper of bundles according to the order." | bundleRegion {XnRegion} | bundleRegion _ region intersect: (globalDsp ofAll: self domain). bundleRegion isEmpty ifTrue: [^Stepper emptyStepper]. ^Stepper itemStepper: (FeElementBundle make: bundleRegion with: (myRangeElement makeFe: myLabel))! {void} informTo: orgl {OrglRoot unused} self unimplemented! {OrglRoot} setAllOwners: owner {ID} "If the CurrentKeyMaster includes the owner of this loaf then change the owner and return NULL else just return self." (CurrentKeyMaster fluidGet hasAuthority: myRangeElement owner) ifTrue: [myRangeElement setOwner: owner. ^OrglRoot make: self domain coordinateSpace] ifFalse: [^ActualOrglRoot make: self with: self domain]! ! !RegionLoaf methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << self domain << ', ' << myRangeElement << ')'! ! !RegionLoaf methodsFor: 'protected: splay'! {Int8} actualSoftSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Don't expand me in place. Just move it closer to the top." ^2! {Int8} actualSplay: region {XnRegion} with: limitRegion {XnRegion unused} "Expand my partial tree in place. The area in the region must go into the leftCrum of my substitute, or the splay algorithm will fail!!" | tmp1 {Loaf} tmp2 {Loaf} | DiskManager consistent: 4 with: [tmp1 _ RegionLoaf create: (self domain intersect: region) with: myLabel with: myRangeElement with: (HUpperCrum make: (self hCrum cast: HUpperCrum))]. DiskManager consistent: 4 with: [tmp2 _ RegionLoaf create: (self domain intersect: region complement) with: myLabel with: myRangeElement with: (HUpperCrum make: (self hCrum cast: HUpperCrum))]. DiskManager consistent: 4 with: [ | hcrum {HUpperCrum} hash {UInt32} info {FlockInfo} | hcrum _ self hCrum cast: HUpperCrum. hash _ self hashForEqual. info _ self fetchInfo. (SplitLoaf new.Become: self) create: region with: tmp1 with: tmp2 with: hcrum with: hash with: info]. ^1! ! !RegionLoaf methodsFor: 'create'! create: region {XnRegion} with: label {BeLabel | NULL} with: element {BeRangeElement} with: hcrum {HUpperCrum | NULL} super create: region with: hcrum with: element sensorCrum. myLabel _ label. myRangeElement _ element. self newShepherd. myRangeElement addOParent: self.! create: region {XnRegion} with: element {BeRangeElement} with: hcrum {HUpperCrum} with: hash {UInt32} with: info {FlockInfo} super create: hash with: region with: hcrum with: element sensorCrum. (element isKindOf: BeEdition) ifTrue: [Heaper BLAST: #EditionsRequireLabels]. myLabel _ NULL. self knownBug. "This doesn't deal with labels." self flockInfo: info. myRangeElement _ element. myRangeElement addOParent: self. self diskUpdate! ! !RegionLoaf methodsFor: 'backfollow'! {void} addOParent: oparent {OPart} "add oparent to the set of upward pointers and update the bertCrums my child." | bCrum {BertCrum} newBCrum {BertCrum} | bCrum _ self hCrum bertCrum. super addOParent: oparent. newBCrum _ self hCrum bertCrum. (bCrum isLE: newBCrum) not ifTrue: [myRangeElement updateBCrumTo: newBCrum]! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} myRangeElement cast: BePlaceHolder into: [ :p | p attachTrailBlazer: blazer. ^self domain] others: [^self domain coordinateSpace emptyRegion]! {void} checkChildRecorders: finder {PropFinder} myRangeElement checkRecorders: finder with: self sensorCrum! {void} checkTrailBlazer: blazer {TrailBlazer} myRangeElement cast: BePlaceHolder into: [ :p | p checkTrailBlazer: blazer] others: ["OK"]! {void} delayedStoreMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} with: hCrumCache {HashSetCache of: HistoryCrum} "RegionLoaf is the one kind of o-leaf which actually shares range-element identity with other o-leafs. The range element identity is in myRangeElement rather than myself, so I override my super's version of this method to forward it south one more step to myRangeElement." recorder delayedStoreMatching: myRangeElement with: finder with: fossil with: hCrumCache! {TrailBlazer | NULL} fetchTrailBlazer myRangeElement cast: BePlaceHolder into: [ :p | ^p fetchTrailBlazer] others: [^NULL]! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} recorder storeRangeElementRecordingAgents: myRangeElement with: myRangeElement sensorCrum with: agenda! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^(myRangeElement hCrum basicCast: Heaper star) == child! {void} triggerDetector: detect {FeFillRangeDetector} (myRangeElement isKindOf: BePlaceHolder) ifFalse: [detect rangeFilled: self asFeEdition]! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myRangeElement updateBCrumTo: newBCrum. ^true]. ^false! ! !RegionLoaf methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myRangeElement) ifTrue: [myRangeElement removeOParent: self]. super dismantle]! ! !RegionLoaf methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myRangeElement hashForEqual! ! !RegionLoaf methodsFor: 'smalltalk: passe'! {void} wait: sensor {XnSensor} self passe! ! !RegionLoaf methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myRangeElement _ receiver receiveHeaper. myLabel _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myRangeElement. xmtr sendHeaper: myLabel.! !OPart subclass: #OrglRoot instanceVariableNames: 'myHCrum {HBottomCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (OrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !OrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} "check any recorders that might be triggered by a change in the stamp" self subclassResponsibility! {void} checkTrailBlazer: blazer {TrailBlazer} self subclassResponsibility! {TrailBlazer | NULL} fetchTrailBlazer self subclassResponsibility! {AgendaItem} propChanger: change {PropChange} "NOTE: The AgendaItem returned is not yet scheduled. Doing so is up to my caller." ^myHCrum propChanger: change! {void} triggerDetector: detect {FeFillRangeDetector} "A Detector has been added to my parent. Walk down and trigger it on all non-partial stuff" self subclassResponsibility! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "Ensure the my bertCrum is not be leafward of newBCrum." (myHCrum propagateBCrum: newBCrum) ifTrue: [self diskUpdate. ^true]. ^false! ! !OrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" self subclassResponsibility! {IntegerVar} count self subclassResponsibility! {XnRegion} domain self subclassResponsibility! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} "get an individual element" self subclassResponsibility! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." self subclassResponsibility! {HistoryCrum} hCrum ^myHCrum! {TracePosition} hCut "This is primarily for the example routines." ^myHCrum hCut! {void} introduceEdition: edition {BeEdition} myHCrum introduceEdition: edition. self remember. self diskUpdate! {BooleanVar} isEmpty self subclassResponsibility! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." self subclassResponsibility! {Mapping} mapSharedTo: trace {TracePosition} "return a mapping from my data to corresponding stuff in the given trace" self subclassResponsibility! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." self subclassResponsibility! {XnRegion} rangeOwners: positions {XnRegion | NULL} self subclassResponsibility! {void} removeEdition: stamp {BeEdition} myHCrum removeEdition: stamp. myHCrum isEmpty ifTrue: ["Now we get into the risky part of deletion. Only Editions can keep OrglRoots around, so destroy the receiver." self destroy] ifFalse: [self diskUpdate]! {OrglRoot} setAllOwners: owner {ID} "Return the portiong whose owner couldn't be changed." self subclassResponsibility! {XnRegion} sharedRegion: trace {TracePosition} "Return a region for all the stuff in this orgl that can backfollow to trace." self subclassResponsibility! {XnRegion} simpleDomain "Return a simple region that encloses the domain of the receiver." self subclassResponsibility! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." self subclassResponsibility! {XnRegion} usedDomain self subclassResponsibility! ! !OrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." self subclassResponsibility! {OrglRoot} combine: orgl {OrglRoot} self subclassResponsibility! {OrglRoot} copy: externalRegion {XnRegion} self subclassResponsibility! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} "This does the 'now' part of setting up a recorder, once the 'later' part has been set up. It does a walk south on the O-tree, then walks back north on all the H-trees, filtered by the Bert canopy." self subclassResponsibility! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} "Go ahead and actually store the recorder in the sensor canopy. However, instead of propogating the props immediately, accumulate all those agenda items into the 'agenda' parameter. This is done instead of scheduling them directly because our client needs to schedule something else following all the prop propogation." self subclassResponsibility! {OrglRoot} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." self subclassResponsibility! {OrglRoot} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." self subclassResponsibility! ! !OrglRoot methodsFor: 'protected:'! {void} dismantle DiskManager consistent: 3 with: [super dismantle. myHCrum _ NULL]! ! !OrglRoot methodsFor: 'create'! create: scrum {SensorCrum | NULL} super create: scrum. myHCrum _ HBottomCrum make.! ! !OrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myHCrum hashForEqual! ! !OrglRoot methodsFor: 'smalltalk: passe'! {ScruTable} asDataTable self passe! {ScruTable} asTable self passe! {void} checkRecorders: edition {BeEdition} with: finder {PropFinder} with: scrum {SensorCrum | NULL} self passe "fewer args"! {void} delayedFindMatching: finder {PropFinder} with: recorder {RecorderFossil} self passe "extra argument"! {FeRangeElement | NULL} fetch: key {Position} self passe! {ScruTable of: ID and: BeEdition} findMatching: finder {PropFinder} self passe! {void} inform: key {Position} with: value {HRoot} self passe! {void} introduceStamp: stamp {BeEdition} self passe.! {void} propChanged: change {PropChange} self passe! {void} removeStamp: stamp {BeEdition} self passe.! {void} wait: sensor {XnSensor} self passe! ! !OrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myHCrum _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myHCrum.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrglRoot class instanceVariableNames: ''! (OrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; yourself)! !OrglRoot class methodsFor: 'creation'! make.CoordinateSpace: cs {CoordinateSpace} "create a new orgl root" "This should definitely be cached!! We make them all the time probably." self thingToDo. DiskManager consistent: 4 with: [^EmptyOrglRoot create: cs]! make.XnRegion: region {XnRegion} region isEmpty ifTrue: [^OrglRoot make: region coordinateSpace]. ^ActualOrglRoot make: (Loaf make.XnRegion: region) with: region! {OrglRoot} make: keys {XnRegion} with: ordering {OrderSpec} with: values {PtrArray of: FeRangeElement} | stepper {Stepper} result {OrglRoot} i {Int32} | result _ OrglRoot make.CoordinateSpace: ordering coordinateSpace. self hack. "This should make a balanced tree directly." i _ Int32Zero. stepper _ keys stepper: ordering. stepper forEach: [:key {Position} | | element {BeCarrier} region {XnRegion} | (values fetch: i) notNULL: [:fe {FeRangeElement} | element _ fe carrier] else: [Heaper BLAST: #MustNotHaveNullElements]. region _ key asRegion. result _ result combine: (ActualOrglRoot make: (Loaf make.Region: region with: element) with: region). i _ i + 1]. ^result! {OrglRoot} makeData: values {PrimDataArray} with: arrangement {Arrangement} "Make an Orgl from a bunch of Data. The data is guaranteed to be of a reasonable size." ^ActualOrglRoot make: (Loaf make: values with: arrangement) with: arrangement region! {OrglRoot} makeData: keys {XnRegion} with: ordering {OrderSpec} with: values {PrimDataArray} "Make an Orgl from a bunch of Data. The data is guaranteed to be of a reasonable size." ^ActualOrglRoot make: (Loaf make: values with: (ordering arrange: keys)) with: keys! ! !OrglRoot class methodsFor: 'smalltalk:'! {OrglRoot} make: it {Heaper} "create a new orgl root" (it isKindOf: CoordinateSpace) ifTrue: [^self make.CoordinateSpace: it]. (it isKindOf: XnRegion) ifTrue: [^self make.XnRegion: it]. ^self make.ScruTable: (it cast: ScruTable)! !OrglRoot subclass: #ActualOrglRoot instanceVariableNames: ' myO {Loaf} myRegion {XnRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (ActualOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !ActualOrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^myO attachTrailBlazer: blazer! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL} myO checkRecorders: finder with: scrum! {void} checkTrailBlazer: blazer {TrailBlazer} myO checkTrailBlazer: blazer! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder} | hCrumCache {HashSetCache of: HistoryCrum} | "Cache for optimization: Frequently, in going northwards on the h-tree, one will encounter an h-crum already encountered during this very delayedFindMatching: operation. In this case, the cache helps us avoid *much* redundant work. We can get away with a bounded size cache because redundant work is still correct." hCrumCache _ HashSetCache make: 100. "Tell my O crum to do its flavor of the work. It will tell its children recursively." myO delayedStoreMatching: finder with: fossil with: recorder with: hCrumCache. hCrumCache destroy.! {TrailBlazer | NULL} fetchTrailBlazer ^myO fetchTrailBlazer! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda} myO storeRecordingAgents: recorder with: agenda! {void} triggerDetector: detect {FeFillRangeDetector} myO triggerDetector: detect! {BooleanVar} updateBCrumTo: newBCrum {BertCrum} "My bertCrum must not be leafward of newBCrum. Thus it must be LE to newCrum. Otherwise correct it and recur." (super updateBCrumTo: newBCrum) ifTrue: [myO updateBCrumTo: newBCrum. ^true]. ^false! ! !ActualOrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" ^myRegion coordinateSpace! {IntegerVar} count ^myO count! {XnRegion} domain ^myO domain! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} "get an individual element" ^myO fetch: key with: edition with: key! {Loaf} fullcrum ^myO! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." "Separate the position from the rest of the oplane with copy. Then instantiate it." CurrentTrace fluidBind: self hCrum hCut during: [CurrentBertCrum fluidBind: self hCrum bertCrum during: [^((self copy: key asRegion) cast: ActualOrglRoot) fullcrum getBe: key]]! {BooleanVar} isEmpty "ActualOrglRoots believe they have stuff beneath them." ^false! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myO keysLabelled: label! {Mapping} mapSharedTo: trace {TracePosition} "return a mapping from my data to corresponding stuff in the given trace" ^myO compare: trace with: myRegion! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." | loaf {OExpandingLoaf} | loaf _ myO fetchBottomAt: key. loaf == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^loaf owner! {XnRegion} rangeOwners: positions {XnRegion | NULL} ^myO rangeOwners: positions! {OrglRoot} setAllOwners: owner {ID} "Recur assigning owners. Return the portion of the receiver that couldn't be assigned." ^myO setAllOwners: owner! {XnRegion} sharedRegion: trace {TracePosition} "Return a region for all the stuff in this orgl that can backfollow to trace." ^myO sharedRegion: trace with: myRegion! {XnRegion} simpleDomain ^myRegion! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." | loaf {OExpandingLoaf} | loaf _ myO fetchBottomAt: key. loaf == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^loaf spec! {Pair of: OrglRoot} tryAllBecome: other {OrglRoot} "Change the identities of the RangeElements of this Edition to those at the same key in the other Edition. The left piece of the result contains those object which are know to not be able to become, because of - lack of ownership authority - different contents - incompatible types - no corresponding new identity The right piece of the result is NULL if there is nothing more that might be done, or else the remainder of the receiver on which we might be able to proceed. This material might fail at a later time because of any of the reasons above; or it might succeed , even though it failed this time because of - synchronization problem - just didn't feel like it This is always required to make progress if it can, although it isn't required to make all the progress that it might. Returns right=NULL when it can't make further progress." Dean shouldImplement. ^NULL "fodder"! {XnRegion} usedDomain ^myO usedDomain! ! !ActualOrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." ^myO bundleStepper: region with: order with: region coordinateSpace identityDsp! {OrglRoot} combine: another {OrglRoot} | him {ActualOrglRoot} result {OrglRoot} | another isEmpty ifTrue: [^self]. him _ another cast: ActualOrglRoot. result _ self fetchEasyCombine: him. result ~~ NULL ifTrue: [^result]. result _ him fetchEasyCombine: self. result ~~ NULL ifTrue: [^result]. "both Ins are non-empty & both Outs are empty" ^myO combine: him with: myRegion with: self coordinateSpace identityDsp! {OrglRoot} copy: region {XnRegion} "Copy out each simple region and then combine them." region isSimple ifTrue: [^self copySimple: region] ifFalse: [| result {OrglRoot} | result _ OrglRoot make: self coordinateSpace. (region disjointSimpleRegions) forEach: [:simple {XnRegion} | result _ result combine: (self copySimple: simple)]. ^result]! {OrglRoot} copyDistinction: region {XnRegion} "region must be a valid thing to store as a split." | cnt {UInt8} | cnt _ self splay: region. Int0 == cnt ifTrue: [^OrglRoot make: self coordinateSpace] ifFalse: [2 == cnt ifTrue: [^self] ifFalse: [^ActualOrglRoot make: (myO cast: InnerLoaf) inPart with: (myRegion intersect: region)]]! {OrglRoot} copySimple: simpleRegion {XnRegion} "simpleRegion must be simple!! Copy out each distinction." | result {OrglRoot} | [ImmuSet] USES. result _ self. simpleRegion isSimple assert: 'This must be a simple region.'. simpleRegion distinctions stepper forEach: [:distinct {XnRegion} | result isEmpty ifTrue: [^result]. result _ (result cast: ActualOrglRoot) copyDistinction: distinct]. ^result! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimDataArray} with: dsp {Dsp} with: edition {BeEdition} myO fill: keys with: toArrange with: toArray with: dsp with: edition! {ActualOrglRoot} makeNew: newSplit {XnRegion} with: newIn {ActualOrglRoot} with: newOut {ActualOrglRoot} ^ActualOrglRoot make: (InnerLoaf make: newSplit with: newIn fullcrum with: newOut fullcrum) with: (newIn simpleDomain simpleUnion: newOut simpleDomain)! {OrglRoot} transformedBy: externalDsp {Dsp} "Return a copy with externalDsp added to the receiver's dsp." externalDsp isIdentity ifTrue: [^self]. ^ActualOrglRoot make: (myO transformedBy: externalDsp) with: (externalDsp ofAll: myRegion)! {OrglRoot} unTransformedBy: externalDsp {Dsp} "Return a copy with externalDsp removed from the receiver's dsp." externalDsp isIdentity ifTrue: [^self]. ^ActualOrglRoot make: (myO unTransformedBy: externalDsp) with: (externalDsp inverseOfAll: myRegion)! ! !ActualOrglRoot methodsFor: 'create'! create: fullcrum {Loaf} with: region {XnRegion} super create: fullcrum sensorCrum. myO _ fullcrum. myRegion _ region. myO addOParent: self. self newShepherd! ! !ActualOrglRoot methodsFor: 'smalltalk:'! crums ^Array with: myO! displayString ^self getCategory name , (myO displayString)! inspect Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: self gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: Sensor ctrlDown separation: 5 @ 10)]! inspectTraces Sensor leftShiftDown ifTrue: [self basicInspect] ifFalse: [EntView openOn: (TreeBarnacle new buildOn: myO gettingChildren: [:crum | crum crums] gettingImage: [:crum | DisplayText text: crum hCrum hCut displayString asText textStyle: (TextStyle styleNamed: #small)] at: 0 @ 0 vertical: true separation: 20 @ 20)]! {BooleanVar} testChild: child {SplayEntLoaf} "Return true if child is a child. Used for debugging." ^myO == child! {BooleanVar} testHChild: child {HistoryCrum} "Return true if child is a child. Used for debugging." ^ myO hCrum == child! ! !ActualOrglRoot methodsFor: 'printing'! {void} printOn: aStream {ostream reference} aStream << self getCategory name << '(' << myRegion << ', ' << myO << ')'! ! !ActualOrglRoot methodsFor: 'private:'! {ActualOrglRoot | NULL} fetchEasyCombine: another {ActualOrglRoot} another simpleDomain distinctions stepper forEach: [:bound {XnRegion} | | myIn {OrglRoot} myOut {OrglRoot} | myIn _ self copy: bound. myOut _ self copy: bound complement. myIn isEmpty ifTrue: [^self makeNew: bound with: another with: (myOut cast: ActualOrglRoot)]. myOut isEmpty not ifTrue: [^self makeNew: bound with: ((another combine: myIn) cast: ActualOrglRoot) with: (myOut cast: ActualOrglRoot)]]. ^NULL! {UInt8} splay: region {XnRegion} "Splay a region into its own subtree as close as possible to the root" ^myO splay: region with: myRegion! ! !ActualOrglRoot methodsFor: 'protected: delete'! {void} dismantle DiskManager consistent: 4 with: [(Heaper isConstructed: myO) ifTrue: [myO removeOParent: self]. super dismantle]! ! !ActualOrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myO hashForEqual) bitXor: myRegion hashForEqual! ! !ActualOrglRoot methodsFor: 'smalltalk: passe'! {void} inform: key {Position} with: value {HRoot} self passe! {void} wait: sensor {XnSensor} self passe! ! !ActualOrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myO _ receiver receiveHeaper. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myO. xmtr sendHeaper: myRegion.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualOrglRoot class instanceVariableNames: ''! (ActualOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !ActualOrglRoot class methodsFor: 'creation'! make: loaf {Loaf} with: region {XnRegion} "create a new orgl root" region isEmpty not assert: 'Attempt to make an empty ActualOrglRoot'. DiskManager consistent: 13 with: [^ActualOrglRoot create: loaf with: region]! !OrglRoot subclass: #EmptyOrglRoot instanceVariableNames: 'myCS {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (EmptyOrglRoot getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #CONCRETE; yourself)! !EmptyOrglRoot methodsFor: 'backfollow'! {XnRegion} attachTrailBlazer: blazer {TrailBlazer} ^self domain! {void} checkRecorders: finder {PropFinder} with: scrum {SensorCrum | NULL}! {void} checkTrailBlazer: blazer {TrailBlazer unused} Heaper BLAST: #EmptyTrail! {void} delayedFindMatching: finder {PropFinder} with: fossil {RecorderFossil} with: recorder {ResultRecorder}! {TrailBlazer | NULL} fetchTrailBlazer ^NULL! {void} storeRecordingAgents: recorder {RecorderFossil} with: agenda {Agenda}! {void} triggerDetector: detect {FeFillRangeDetector}! ! !EmptyOrglRoot methodsFor: 'accessing'! {CoordinateSpace} coordinateSpace "the kind of domain elements allowed" ^myCS! {IntegerVar} count ^IntegerVar0! {XnRegion} domain ^myCS emptyRegion! {FeRangeElement | NULL} fetch: key {Position} with: edition {BeEdition} ^NULL! {BeRangeElement} getBe: key {Position} "Get or Make the BeRangeElement at the location." Heaper BLAST: #NotInTable. ^NULL! {BooleanVar} isEmpty ^true! {XnRegion} keysLabelled: label {BeLabel} "Just search for now." ^myCS emptyRegion! {Mapping} mapSharedTo: trace {TracePosition unused} "return a mapping from my data to corresponding stuff in the given trace" ^self coordinateSpace identityDsp! {ID} ownerAt: key {Position} "Return the owner for the given position in the receiver." Heaper BLAST: #NotInTable. ^NULL! {XnRegion} rangeOwners: positions {XnRegion | NULL} ^IDSpace global emptyRegion! {OrglRoot} setAllOwners: owner {ID} "There aren't any contents, so just return self." ^self! {XnRegion} sharedRegion: trace {TracePosition unused} "I have no contents, so I can't shared anything." ^ myCS emptyRegion! {XnRegion} simpleDomain "Return a simple region that encloses the domain of the receiver." ^ myCS emptyRegion! {PrimSpec} specAt: key {Position} "Return the owner for the given position in the receiver." Heaper BLAST: #NotInTable. ^NULL "fodder"! {XnRegion} usedDomain ^myCS emptyRegion! ! !EmptyOrglRoot methodsFor: 'operations'! {Stepper} bundleStepper: region {XnRegion} with: order {OrderSpec} "Return a stepper of bundles according to the order." ^Stepper emptyStepper! {OrglRoot} combine: orgl {OrglRoot} ^ orgl! {OrglRoot} copy: externalRegion {XnRegion unused} ^ self! {OrglRoot} transformedBy: externalDsp {Dsp unused} "Return a copy with externalDsp added to the receiver's dsp." ^ self! {OrglRoot} unTransformedBy: externalDsp {Dsp unused} "Return a copy with externalDsp removed from the receiver's dsp." ^ self! ! !EmptyOrglRoot methodsFor: 'create'! create: cs {CoordinateSpace} super create: (NULL basicCast: SensorCrum). myCS _ cs. self newShepherd! ! !EmptyOrglRoot methodsFor: 'smalltalk:'! crums ^#()! ! !EmptyOrglRoot methodsFor: 'testing'! {UInt32} contentsHash ^super contentsHash bitXor: myCS hashForEqual! ! !EmptyOrglRoot methodsFor: 'smalltalk: passe'! {void} inform: key {Position unused} with: value {HRoot unused} self passe! {void} propBy: anIObject {IObject unused} self passe! {void} unpropBy: anIObject {IObject unused} "Remove the endorsements for which aClubInfo is responsible. If there are no more references to this orgl, then it should be delete. This might also triggers sensors that wait for negative filters." self passe! {void} wait: sensor {XnSensor unused} self passe! ! !EmptyOrglRoot methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCS _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCS.! !Abraham subclass: #PairFlock instanceVariableNames: ' myLeft {Abraham} myRight {Abraham}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (PairFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !PairFlock methodsFor: 'accessing'! {Abraham} left ^myLeft! {Abraham} right ^myRight! ! !PairFlock methodsFor: 'creation'! create: left {Abraham} with: right {Abraham} super create. myLeft _ left. myRight _ right. self newShepherd! ! !PairFlock methodsFor: 'testing'! {UInt32} contentsHash ^(super contentsHash bitXor: myLeft hashForEqual) bitXor: myRight hashForEqual! ! !PairFlock methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLeft _ receiver receiveHeaper. myRight _ receiver receiveHeaper.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myLeft. xmtr sendHeaper: myRight.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PairFlock class instanceVariableNames: ''! (PairFlock getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !PairFlock class methodsFor: 'creation'! make: left {Abraham} with: right {Abraham} ^self create: left with: right! !Abraham subclass: #Pumpkin instanceVariableNames: '' classVariableNames: 'TheGreatPumpkin {Abraham} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (Pumpkin getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #EQ; add: #CONCRETE; yourself)! !Pumpkin methodsFor: 'protected: protected'! {void} becomeStub "This can only be implemented by classes which are shepherds." "Each subclass will have expressions of the form: 'new (this) MyStubClass()'" self shouldNotImplement! ! !Pumpkin methodsFor: 'creation'! create: hash {UInt32} super create: hash! ! !Pumpkin methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Pumpkin class instanceVariableNames: ''! (Pumpkin getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #EQ; add: #CONCRETE; yourself)! !Pumpkin class methodsFor: 'smalltalk: initialization'! linkTimeNonInherited TheGreatPumpkin _ NULL! ! !Pumpkin class methodsFor: 'pcreate'! {Abraham wimpy} make "Just return the soleInstance." TheGreatPumpkin == NULL ifTrue: [TheGreatPumpkin _ self create: 1. TheGreatPumpkin flockInfo: (FlockInfo remembered: TheGreatPumpkin with: Int32Zero with: Int32Zero)]. ^TheGreatPumpkin! !Abraham subclass: #RecorderFossil instanceVariableNames: ' myLoginAuthority {IDRegion} myTrailBlazer {TrailBlazer | NULL} myRecorder {ResultRecorder NOCOPY | NULL} myRecorderCount {IntegerVar NOCOPY} myAgendaCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! RecorderFossil comment: 'A Fossil for a ResultRecorder, which also stores its permissions, filters, and a cache of the results which have already been recorded.'! (RecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !RecorderFossil methodsFor: 'accessing'! {void} addItem: item {AgendaItem unused} DiskManager insistent: 1 with: [myAgendaCount _ myAgendaCount + 1. self diskUpdate. self memoryCheck]! {void} extinguish: trailBlazer {TrailBlazer} "Should only be called from BeEdition::fossilRelease(). Results in my becoming extinct." myTrailBlazer == NULL ifTrue: [Heaper BLAST: #AlreadyExtinct]. (myTrailBlazer isEqual: trailBlazer) not ifTrue: [Heaper BLAST: #WhoSays]. myRecorderCount ~= Int32Zero ifTrue: [Heaper BLAST: #RecordersStillOutstanding]. myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. DiskManager insistent: 1 with: [myTrailBlazer _ NULL. self diskUpdate. self memoryCheck]! {void} releaseRecorder "As a premature optimization, we don't destroy the waldo when the count goes to zero, but rather when we consider purging while the count is zero." (myRecorderCount >= 1) assert. myRecorderCount _ myRecorderCount - 1! {void} removeItem: item {AgendaItem unused} (myAgendaCount >= 1) assert. DiskManager insistent: 1 with: [myAgendaCount _ myAgendaCount - 1. self diskUpdate. self memoryCheck]! {ResultRecorder} secretRecorder "The Recorder of which this Fossil is the imprint. If necessary, reconstruct it using the information stored in the imprint. Should only be called if I am not extinct Should only be called from the reanimate macro." | | "If I'm extinct, somebody goofed. Blow 'em up. If we haven't already reanimated a recorder (because this is the outermost reanimate for this fossil) bind a new current KeyMaster (recovering the fossilized permissions) make a recorder implicitly using the fossilized permissions and explicitly using the fossilized endorsements and trail. bump the refcount on myRecorder return myRecorder" self isExtinct ifTrue: [Heaper BLAST: #FossilExtinct]. myRecorder == NULL ifTrue: [CurrentKeyMaster fluidBind: (FeKeyMaster makeAll: myLoginAuthority) during: [myRecorder := self actualRecorder]]. myRecorderCount := myRecorderCount + 1. ^myRecorder! ! !RecorderFossil methodsFor: 'smalltalk: reanimation'! {void} reanimate: aBlock {BlockClosure of: RecorderFossil} "Should only be called if I am not extinct. f reanimate: [:w {RecorderFossil} | ...] should translate to BEGIN_REANIMATE(f,RecorderFossil,w) { ... } END_REANIMATE;" [aBlock value: self secretRecorder] valueNowOrOnUnwindDo: (RecorderFossil bomb.ReleaseRecorder: self)! ! !RecorderFossil methodsFor: 'testing'! {BooleanVar} isExtinct "A Fossil (unlike a Grabber or an Orgl) does not prevent the grabbed IObject from being dismantled. Instead, if the IObject does get dismantled, then the Fossil is considered extinct. A waldo may not be gotten from an extinct fossil (if the species is really extinct, then it cannot be revived from its remaining fossils)." ^myTrailBlazer == NULL! {BooleanVar} isPurgeable "I can`t go to disk while someone has my WaldoSocket and might be doing something with the Waldo in it." (super isPurgeable and: [myRecorderCount == Int32Zero]) ifTrue: [myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. ^true] ifFalse: [^false]! ! !RecorderFossil methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartRecorderFossil: rcvr {Rcvr unused default: NULL} myRecorder _ NULL. myRecorderCount _ Int32Zero! ! !RecorderFossil methodsFor: 'protected: destruction'! {void} dismantle (myRecorderCount = Int32Zero) assert. "(myAgendaCount = Int32Zero) assert." myRecorder ~~ NULL ifTrue: [myRecorder destroy. myRecorder _ NULL]. DiskManager consistent: 2 with: [(Heaper isConstructed: myTrailBlazer) ifTrue: [myTrailBlazer removeReference: self]. myTrailBlazer := NULL. super dismantle]! ! !RecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder "Make the right kind of Recorder for this fossil" self subclassResponsibility! {void} memoryCheck (myTrailBlazer == NULL "and: [myAgendaCount = Int32Zero]") ifTrue: [self forget] ifFalse: [self remember]! {TrailBlazer} trailBlazer myTrailBlazer == NULL ifTrue: [Heaper BLAST: #FatalError]. "should have already been checked" ^myTrailBlazer! ! !RecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: trailBlazer {TrailBlazer} super create. myLoginAuthority := loginAuthority. myTrailBlazer := trailBlazer. myTrailBlazer addReference: self. myAgendaCount _ Int32Zero. self restartRecorderFossil: NULL.! ! !RecorderFossil methodsFor: 'backfollow'! {void} storeDataRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on data in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! {void} storePartialityRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on partiality in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! {void} storeRangeElementRecordingAgents: rangeElement {BeRangeElement unused} with: sensorCrum {SensorCrum} with: agenda {Agenda} "Store recording agents into a SensorCrum on a RangeElement in the original Edition that was a source of the query" agenda registerItem: (sensorCrum recordingAgent: self) "default behaviour"! ! !RecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myLoginAuthority _ receiver receiveHeaper. myTrailBlazer _ receiver receiveHeaper. myAgendaCount _ receiver receiveIntegerVar. self restartRecorderFossil: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myLoginAuthority. xmtr sendHeaper: myTrailBlazer. xmtr sendIntegerVar: myAgendaCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RecorderFossil class instanceVariableNames: ''! (RecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !RecorderFossil class methodsFor: 'create'! {RecorderFossil} transcluders: isDirectOnly {BooleanVar} with: loginAuthority {IDRegion} with: directFilter {Filter of: (Tuple of: ID with: ID)} with: indirectFilter {Filter of: (Tuple of: ID with: ID)} with: trailBlazer {TrailBlazer} DiskManager consistent: 2 with: [isDirectOnly ifTrue: [^DirectEditionRecorderFossil create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer] ifFalse: [^IndirectEditionRecorderFossil create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer]]! {RecorderFossil} works: isDirectOnly {BooleanVar} with: loginAuthority {IDRegion} with: endorsementsFilter {Filter of: (Tuple of: ID with: ID)} with: trailBlazer {TrailBlazer} DiskManager consistent: 2 with: [isDirectOnly ifTrue: [^DirectWorkRecorderFossil create: loginAuthority with: endorsementsFilter with: trailBlazer] ifFalse: [^IndirectWorkRecorderFossil create: loginAuthority with: endorsementsFilter with: trailBlazer]]! ! !RecorderFossil class methodsFor: 'exceptions: exceptions'! bomb.ReleaseRecorder: CHARGE {RecorderFossil} ^[CHARGE releaseRecorder]! ! !RecorderFossil class methodsFor: 'smalltalk: passe'! make: loginAuthority {IDRegion} with: eFilter {Filter of: (Tuple of: ID with: ID)} with: trail {BeEdition} self passe! !RecorderFossil subclass: #EditionRecorderFossil instanceVariableNames: ' myDirectFilter {Filter} myIndirectFilter {Filter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! EditionRecorderFossil comment: 'A Fossil for an EditionRecorder.'! (EditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; add: #NOT.A.TYPE; yourself)! !EditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder self subclassResponsibility! {Filter} directFilter ^myDirectFilter! {Filter} indirectFilter ^myIndirectFilter! ! !EditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: trailBlazer. myDirectFilter := directFilter. myIndirectFilter := indirectFilter.! ! !EditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myDirectFilter _ receiver receiveHeaper. myIndirectFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myDirectFilter. xmtr sendHeaper: myIndirectFilter.! !EditionRecorderFossil subclass: #DirectEditionRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! DirectEditionRecorderFossil comment: 'A Fossil for an EditionRecorder with the directOnly flag set.'! (DirectEditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DirectEditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^DirectEditionRecorder create: self directFilter with: self indirectFilter with: self trailBlazer! ! !DirectEditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer. self newShepherd. self remember.! ! !DirectEditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !EditionRecorderFossil subclass: #IndirectEditionRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! IndirectEditionRecorderFossil comment: 'A Fossil for an EditionRecorder with the directOnly flag off.'! (IndirectEditionRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !IndirectEditionRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^IndirectEditionRecorder create: self directFilter with: self indirectFilter with: self trailBlazer! ! !IndirectEditionRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: directFilter {Filter} with: indirectFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: directFilter with: indirectFilter with: trailBlazer. self newShepherd. self remember.! ! !IndirectEditionRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !RecorderFossil subclass: #WorkRecorderFossil instanceVariableNames: 'myEndorsementsFilter {Filter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! WorkRecorderFossil comment: 'A Fossil for a WorkRecorder.'! (WorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #DEFERRED; add: #DEFERRED.LOCKED; add: #NOT.A.TYPE; yourself)! !WorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder self subclassResponsibility! {Filter} endorsementsFilter ^myEndorsementsFilter! ! !WorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: trailBlazer. myEndorsementsFilter := endorsementsFilter.! ! !WorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myEndorsementsFilter _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myEndorsementsFilter.! !WorkRecorderFossil subclass: #DirectWorkRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! DirectWorkRecorderFossil comment: 'A Fossil for a DirectWorkRecorder.'! (DirectWorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !DirectWorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^DirectWorkRecorder create: self endorsementsFilter with: self trailBlazer! ! !DirectWorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: endorsementsFilter with: trailBlazer. self newShepherd. self remember.! ! !DirectWorkRecorderFossil methodsFor: 'backfollow'! {void} storeDataRecordingAgents: sensorCrum {SensorCrum} with: agenda {Agenda} "do nothing"! {void} storeRangeElementRecordingAgents: rangeElement {BeRangeElement} with: sensorCrum {SensorCrum} with: agenda {Agenda} ((rangeElement isKindOf: BeEdition) or: [rangeElement isKindOf: BePlaceHolder]) ifTrue: [super storeRangeElementRecordingAgents: rangeElement with: sensorCrum with: agenda]! ! !DirectWorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !WorkRecorderFossil subclass: #IndirectWorkRecorderFossil instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-fossil'! IndirectWorkRecorderFossil comment: 'A Fossil for a IndirectWorkRecorder.'! (IndirectWorkRecorderFossil getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #LOCKED; add: #NOT.A.TYPE; add: #CONCRETE; yourself)! !IndirectWorkRecorderFossil methodsFor: 'protected: accessing'! {ResultRecorder} actualRecorder ^IndirectWorkRecorder create: self endorsementsFilter with: self trailBlazer! ! !IndirectWorkRecorderFossil methodsFor: 'create'! create: loginAuthority {IDRegion} with: endorsementsFilter {Filter} with: trailBlazer {TrailBlazer} super create: loginAuthority with: endorsementsFilter with: trailBlazer. self newShepherd. self remember.! ! !IndirectWorkRecorderFossil methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Abraham subclass: #SharedData instanceVariableNames: ' myArrangement {Arrangement} myData {PrimArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Ents'! (SharedData getOrMakeCxxClassDescription) attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !SharedData methodsFor: 'accessing'! {UInt32} contentsHash ^super contentsHash bitXor: myData contentsHash! {Heaper | NULL} fetch: key {Position} ^myData fetchValue: (myArrangement indexOf: key) DOTasLong! {void} fill: keys {XnRegion} with: toArrange {Arrangement} with: toArray {PrimArray} with: dsp {Dsp} "Transfer my data into the toArray mapping through my arrangement and his arrangement." keys isEmpty ifFalse: [toArrange copyElements: toArray with: dsp with: myData with: myArrangement with: (dsp inverseOfAll: keys)]! {PrimSpec} spec "Return the primSpec for my data." ^myData spec! ! !SharedData methodsFor: 'creation'! create: data {PrimDataArray} with: arrange {Arrangement} super create. myData _ data. myArrangement _ arrange. myData count = myArrangement region count DOTasLong assert: 'Invalid arrangement'. self newShepherd. self remember! ! !SharedData methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myArrangement _ receiver receiveHeaper. myData _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myArrangement. xmtr sendHeaper: myData.! !Abraham subclass: #ShepherdLocked instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-sheph'! (ShepherdLocked getOrMakeCxxClassDescription) friends: '/* friends for class ShepherdLocked */'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !ShepherdLocked methodsFor: 'instance creation'! create super create! ! !ShepherdLocked methodsFor: 'accessing'! {BooleanVar} isReallyUnlocked [^ (StackExaminer pointersOnStack fetch: self asOop) == NULL] smalltalkOnly. 'return StackExaminer::pointersOnStack()->fetch((Int32)(void*)this) == NULL;' translateOnly.! ! !ShepherdLocked methodsFor: 'testing locks'! {void} publicUnlock "self unlock"! ! !ShepherdLocked methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ShepherdLocked class instanceVariableNames: ''! (ShepherdLocked getOrMakeCxxClassDescription) friends: '/* friends for class ShepherdLocked */'; attributes: ((Set new) add: #LOCKED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #CONCRETE; yourself)! !ShepherdLocked class methodsFor: 'instance creation'! {ShepherdLocked} makeLocked ^ShepherdLocked create! {ShepherdLocked} makeUnlocked | aLockedShepherd {ShepherdLocked} | aLockedShepherd _ ShepherdLocked create. aLockedShepherd publicUnlock. ^aLockedShepherd! !Abraham subclass: #TrailBlazer instanceVariableNames: ' myTrail {BeEdition} myRecorded {HashSetCache of: BeRangeElement} myRefCount {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tclude'! TrailBlazer comment: 'The object responsible for recording results into a trail. '! (TrailBlazer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !TrailBlazer methodsFor: 'create'! create super create. myTrail := NULL. myRecorded := HashSetCache make. myRefCount := IntegerVarZero. self newShepherd.! ! !TrailBlazer methodsFor: 'private:'! {void} setEdition: trail {BeEdition} myTrail := trail. self diskUpdate.! ! !TrailBlazer methodsFor: 'accessing'! {BooleanVar} isAlive "Whether this TrailBlazer was in fact successfully attached" ^myTrail ~~ NULL! {void} record: answer {BeRangeElement} "record the answer into my Edition, and keep only the partial part. Should usually suppress redundant records of the same object. (These are typically generated by a race between the now and future parts of a backfollow, which are guaranteed to err by overlapping rather than gapping. They may also be generated by a crash/reboot during AgendaItem processing.)" (myRecorded hasMember: answer) ifFalse: [ | iD {ID} newTrail {BeEdition} | iD := (myTrail coordinateSpace cast: IDSpace) newID. TrailBlazer problems.RecordFailure handle: [ :ex | ^VOID] do: [(myTrail get: iD) makeIdentical: (answer makeFe: NULL)]. myRecorded store: answer. Ravi thingToDo. "This should not be an edit operation (?)" newTrail := myTrail without: iD. Ravi thingToDo. "decrease refcount on old trail, increase on new one" DiskManager consistent: 1 with: [myTrail := newTrail. self diskUpdate]]! ! !TrailBlazer methodsFor: 'storage'! {void} addReference: object {Abraham unused} "Increment the reference count" DiskManager consistent: 1 with: [myRefCount := myRefCount + 1. myRefCount = 1 ifTrue: [self remember]. self diskUpdate]! {void} removeReference: object {Abraham unused} "Decrement the reference count" DiskManager consistent: 1 with: [myRefCount := myRefCount - 1. myRefCount = IntegerVarZero ifTrue: [self forget]. self diskUpdate]! ! !TrailBlazer methodsFor: 'generated:'! actualHashForEqual ^self asOop! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myTrail _ receiver receiveHeaper. myRecorded _ receiver receiveHeaper. myRefCount _ receiver receiveIntegerVar.! isEqual: other ^self == other! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myTrail. xmtr sendHeaper: myRecorded. xmtr sendIntegerVar: myRefCount.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TrailBlazer class instanceVariableNames: ''! (TrailBlazer getOrMakeCxxClassDescription) attributes: ((Set new) add: #SHEPHERD.PATRIARCH; add: #COPY; add: #EQ; add: #LOCKED; add: #CONCRETE; yourself)! !TrailBlazer class methodsFor: 'create'! make: trail {BeEdition} "should only be called from Edition::getOrMakeTrailBlazer" | result {TrailBlazer} partial {XnRegion} sub {BeEdition} | DiskManager consistent: 1 with: [result := self create]. partial := trail attachTrailBlazer: result. sub := trail copy: partial. DiskManager consistent: 1 with: [result setEdition: sub]. "this makes the blazer be alive, once attached" ^result! ! !TrailBlazer class methodsFor: 'exceptions:'! problems.RecordFailure ^Heaper signals: #(MustBeOwner CantMakeIdentical NotInTable)! !Abraham subclass: #Turtle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (Turtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Turtle methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Heaper} bootHeaper self subclassResponsibility! {Cookbook} cookbook self subclassResponsibility! {Counter} counter self subclassResponsibility! {Agenda | NULL} fetchAgenda "Under all normal conditions, a Turtle has an Agenda. However, during the construction of a Turtle, there may arise situations when a piece of code is invoked which normally asks the Turtle for its agenda before the Turtle is mature enough to have one." self subclassResponsibility! {Agenda} getAgenda "See Turtle::fetchAgenda()" | result {Agenda | NULL} | result _ self fetchAgenda. result == NULL ifTrue: [Heaper BLAST: #TurtleNotMature]. ^result! {XcvrMaker} protocol self subclassResponsibility! {void} saveBootHeaper: boot {Heaper} self subclassResponsibility! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} self subclassResponsibility! ! !Turtle methodsFor: 'protected: creation'! create super create! create: hash {UInt32} super create: hash! ! !Turtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Turtle class instanceVariableNames: ''! (Turtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; add: #SHEPHERD.PATRIARCH; add: #DEFERRED.LOCKED; yourself)! !Turtle class methodsFor: 'pseudo-constructors'! make: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} ^SimpleTurtle make: cookbook with: bootCategory with: maker! !Turtle subclass: #MockTurtle instanceVariableNames: ' myAgenda {Agenda | NULL} myBootCategory {Category}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! MockTurtle comment: 'The MockTurtle is used with the FakePacker. All it provides is an Agenda'! (MockTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !MockTurtle methodsFor: 'accessing'! {Category} bootCategory ^ myBootCategory! {Heaper} bootHeaper self unimplemented. ^NULL "fodder"! {Cookbook} cookbook self willNotImplement. ^ NULL! {Counter} counter self willNotImplement. ^NULL "fodder"! {Agenda | NULL} fetchAgenda ^myAgenda! {XcvrMaker} protocol self willNotImplement. ^ NULL! {void} saveBootHeaper: boot {Heaper} "Right" self willNotImplement.! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} "Right" self willNotImplement.! ! !MockTurtle methodsFor: 'protected: creation'! create: bootCategory {Category} super create. (CurrentPacker fluidGet cast: FakePacker) storeTurtle: self. myAgenda _ NULL. myBootCategory _ bootCategory. myAgenda _ Agenda make.! ! !MockTurtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myAgenda _ receiver receiveHeaper. myBootCategory _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myAgenda. xmtr sendHeaper: myBootCategory.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MockTurtle class instanceVariableNames: ''! (MockTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !MockTurtle class methodsFor: 'pseudo-constructor'! {Turtle} make: category {Category} ^ self create: category! !Turtle subclass: #SimpleTurtle instanceVariableNames: ' myCounter {Counter} myBootHeaper {Heaper} myProtocol {XcvrMaker NOCOPY} myCookbook {Cookbook NOCOPY} myBootCategory {Category} myAgenda {Agenda | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (SimpleTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !SimpleTurtle methodsFor: 'accessing'! {Category} bootCategory ^myBootCategory! {Heaper} bootHeaper ^myBootHeaper! {Cookbook} cookbook ^myCookbook! {Counter} counter ^myCounter! {Agenda | NULL} fetchAgenda ^myAgenda! {XcvrMaker} protocol ^myProtocol! {void} saveBootHeaper: boot {Heaper} myBootHeaper == NULL ifFalse: [Turtle BLAST: #DontChangeTurtlesBootHeaper] ifTrue: [DiskManager consistent: 1 with: [myBootHeaper _ boot. self diskUpdate]]! {void} setProtocol: xcvrMaker {XcvrMaker} with: book {Cookbook} myProtocol _ xcvrMaker. myCookbook _ book.! ! !SimpleTurtle methodsFor: 'testing'! {UInt32} contentsHash ^((super contentsHash bitXor: myCounter hashForEqual) bitXor: myBootHeaper hashForEqual) bitXor: myProtocol hashForEqual! ! !SimpleTurtle methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartSimpleTurtle: rcvr {Rcvr unused default: NULL} myProtocol _ XcvrMaker make. "The bogus protocol" myCookbook _ Cookbook make "with the empty cookbook"! ! !SimpleTurtle methodsFor: 'protected: creation'! create: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} | packer {DiskManager} | super create: 1. packer _ CurrentPacker fluidGet cast: DiskManager. DiskManager consistent: 1 with: [myCounter _ NULL. myBootHeaper _ NULL. myProtocol _ maker. myCookbook _ cookbook. myBootCategory _ bootCategory. myAgenda _ NULL. packer storeInitialFlock: self with: myProtocol with: cookbook]. DiskManager consistent: 3 with: [self thingToDo. "tune the number 5000" myCounter _ Counter fakeCounter: 3 with: 5000 with: 2. packer setHashCounter: myCounter. self remember. myCounter newShepherd. myCounter remember. myAgenda _ Agenda make. myAgenda rememberYourself]! ! !SimpleTurtle methodsFor: 'smalltalk: passe'! {void} newCounter: counter {Counter} self passe! ! !SimpleTurtle methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myCounter _ receiver receiveHeaper. myBootHeaper _ receiver receiveHeaper. myBootCategory _ receiver receiveHeaper. myAgenda _ receiver receiveHeaper. self restartSimpleTurtle: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myCounter. xmtr sendHeaper: myBootHeaper. xmtr sendHeaper: myBootCategory. xmtr sendHeaper: myAgenda.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SimpleTurtle class instanceVariableNames: ''! (SimpleTurtle getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #LOCKED; add: #COPY; yourself)! !SimpleTurtle class methodsFor: 'pseudo-constructors'! make: cookbook {Cookbook} with: bootCategory {Category} with: maker {XcvrMaker} ^SimpleTurtle create: cookbook with: bootCategory with: maker! !Heaper subclass: #Accumulator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! Accumulator comment: 'An Accumulator is a thing which collects a sequence of objects one at a time for some purpose. Typically, this purpose is to construct a new object out of all the collected objects. When used in this way, one can think of the Accumulator as being sort of like a pseudo-constructor which is spread out in time, and whose arguments are identified by the sequence they occur in. Accumulators are typically used in loops. A (future) example of an Accumulator which is not like "a pseudo-constructor spread out in time" is a communications stream between two threads (or even coroutines) managed by an Accumulator / Stepper pair. The producer process produces by putting objects into his Accumulator, and the consuming process consumes by pulling values out of his Stepper. If you want to stretch the analogy, I suppose you can see the Accumulator of the pair as a pseudo-constructor which constructs the Stepper, but *overlapped* in time. It is normally considered bad style for two methods/functions to be pointing at the same Acumulator. As long as Accumulators are used locally and without aliasing (i.e., as if they were pass-by-value Vars), these implementationally side-effecty objects can be understood applicatively. If a copy of an Accumulator can be passed instead of a pointer to the same one, this is to be prefered. This same comment applies even more so for Steppers. Example: To build a set consisting of some transform of the elements of an existing set (what Smalltalk would naturally do with "collect:"), a natural form for the loop would be: SPTR(Accumulator) acc = setAccumulator(); FOR_EACH(Heaper,each,oldSet->stepper(), { acc->step (transform (each)); }); return CAST(ImmuSet,acc->value()); See class Stepper for documentation of FOR_EACH.'! (Accumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Accumulator methodsFor: 'deferred operations'! {void} step: someObj {Heaper} "Accumulate a new object into the Accumulator" self subclassResponsibility! {Heaper} value "Return the object that results from accumulating all those objects" self subclassResponsibility! ! !Accumulator methodsFor: 'deferred creation'! {Accumulator} copy "Return a new Accumulator just like the current one, except that from now on they accumulate separately" self subclassResponsibility! ! !Accumulator methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Accumulator class instanceVariableNames: ''! (Accumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Accumulator class methodsFor: 'creation'! {Accumulator INLINE} ptrArray "An accumulator that returns a PtrArray of the object put into it, in sequence" ^PtrArrayAccumulator create! !Accumulator subclass: #BoxAccumulator instanceVariableNames: ' mySpace {CrossSpace} myRegions {PtrArray of: XnRegion} myIndex {Int32}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-cross'! BoxAccumulator comment: 'was NOT.A.TYPE but this prevented compilation '! (BoxAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^BoxAccumulator create: mySpace with: (myRegions copy cast: PtrArray) with: myIndex] ifFalse: [^(BoxAccumulator new.Become: result) create: mySpace with: (myRegions copy cast: PtrArray) with: myIndex]! ! !BoxAccumulator methodsFor: 'protected: creation'! create: region {GenericCrossRegion} super create. mySpace := region crossSpace. myRegions := region secretRegions copy cast: PtrArray. myIndex := region boxCount.! create: space {CrossSpace} with: expectedBoxCount {Int32} super create. mySpace := space. myRegions := PtrArray nulls: space axisCount * expectedBoxCount. myIndex := Int32Zero.! create: space {CrossSpace} with: regions {PtrArray unused of: XnRegion} with: expectedBoxCount {Int32} super create. mySpace := space. myRegions := PtrArray nulls: space axisCount * expectedBoxCount. myIndex := Int32Zero. Ravi shouldImplement. "shouldn't we be doing something with the 'regios' argument?"! ! !BoxAccumulator methodsFor: 'private:'! {void} aboutToAdd "Make sure there is room to add a box" myIndex * mySpace axisCount < myRegions count ifFalse: [myRegions := (myRegions copyGrow: (myIndex + 1) * mySpace axisCount) cast: PtrArray].! {Int32} addSubstitutedBox: current {Int32} with: dimension {Int32} with: newRegion {XnRegion} "Add a new box which is just like a current one except for the projection on one dimension. Return its index" self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: myRegions with: mySpace axisCount with: current * mySpace axisCount. myRegions at: myIndex * mySpace axisCount + dimension store: newRegion. myIndex := myIndex + 1. ^myIndex - 1! {Int32} boxCount self knownBug. "includes deleted boxes" ^myIndex! {XnRegion} boxProjection: box {Int32} with: dimension {Int32} "Change a projection of a box" ^(myRegions fetch: box * mySpace axisCount + dimension) cast: XnRegion! {void} deleteBox: box {Int32} "Mark a box as deleted" myRegions at: box * mySpace axisCount store: NULL! {BooleanVar} distributeUnion: added {Int32} with: start {Int32} with: stop {Int32} "Take my box at added and distribute it over my existing boxes from start to stop - 1 meanwhile taking pieces out of my box at remainder and delete it if it becomes empty Return true if there is still something left in the remainder" start almostTo: stop do: [ :index {Int32} | (self splitUnion: added with: index with: stop) ifFalse: [^false]]. ^true! {Int32} index ^myIndex! {BooleanVar} isDeleted: box {Int32} "Whether the box has been deleted" ^(myRegions fetch: box * mySpace axisCount) == NULL! {PtrArray of: XnRegion} secretRegions ^myRegions! {BooleanVar} splitUnion: added {Int32} with: current {Int32} with: stop {Int32} "Take my box at added and union it with my box at current delete it if it becomes empty Return true if there is still something left in the added box" | dimension {Int32} addedRegion {XnRegion} currentRegion {XnRegion} common {XnRegion} newAdded {Int32} extraCurrent {XnRegion} extraAdded {XnRegion} | (self isDeleted: current) ifTrue: [^true]. dimension := Int32Zero. [dimension + 1 < mySpace axisCount] whileTrue: ["see if the added intersects the current in this dimension" addedRegion := self boxProjection: added with: dimension. currentRegion := self boxProjection: current with: dimension. self thingToDo. "Add protocol for tri-delta: gives triple (a-b, a&b, b-a)" common := addedRegion intersect: currentRegion. common isEmpty ifTrue: [^true]. "split out the part of current that doesn't intersect" extraCurrent := currentRegion minus: common. extraCurrent isEmpty ifFalse: [self addSubstitutedBox: current with: dimension with: extraCurrent. self storeBoxProjection: current with: dimension with: common]. "split out the part of the added that doesn't intersect" extraAdded := addedRegion minus: common. extraAdded isEmpty ifFalse: [newAdded := self addSubstitutedBox: added with: dimension with: extraAdded. self distributeUnion: newAdded with: current + 1 with: stop. self storeBoxProjection: added with: dimension with: common]. dimension := dimension + 1]. "union the added into the last dimension of the current box" addedRegion := self boxProjection: added with: dimension. currentRegion := self boxProjection: current with: dimension. self storeBoxProjection: current with: dimension with: (currentRegion unionWith: addedRegion). self deleteBox: added. ^false! {void} storeBoxProjection: box {Int32} with: dimension {Int32} with: region {XnRegion} "Change a projection of a box" myRegions at: box * mySpace axisCount + dimension store: region! {void} tryMergeBoxes: i {Int32} with: j {Int32} "If two boxes differ by only one projection, union the second into the first and delete the second" | unequal {Int32} | unequal := -1. Int32Zero almostTo: mySpace axisCount do: [ :dim {Int32} | ((self boxProjection: i with: dim) isEqual: (self boxProjection: j with: dim)) ifFalse: [unequal >= Int32Zero ifTrue: [^VOID]. unequal := dim]]. self storeBoxProjection: i with: unequal with: ((self boxProjection: i with: unequal) unionWith: (self boxProjection: j with: unequal)). self deleteBox: j.! ! !BoxAccumulator methodsFor: 'operations'! {void} addAccumulatedBoxes: other {BoxAccumulator} "Add in all the boxes in another accumulator" Int32Zero almostTo: other index do: [ :box {Int32} | (other isDeleted: box) ifFalse: [self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: other secretRegions with: mySpace axisCount with: box * mySpace axisCount. myIndex := myIndex + 1]]! {Int32} addBox: box {BoxStepper} "Add the current box to the end of the array" ^self addProjections: box region secretRegions with: box boxIndex! {void} addInverseTransformedBox: box {BoxStepper} with: dsp {GenericCrossDsp} "Add the current box, transformed by the inverse of the dsp" | base {Int32} | self aboutToAdd. base := mySpace axisCount * myIndex. Int32Zero almostTo: mySpace axisCount do: [ :dimension {Int32} | myRegions at: base + dimension store: ((dsp subMapping: dimension) inverseOfAll: (box projection: dimension))]. myIndex := myIndex + 1.! {Int32} addProjections: projections {PtrArray of: XnRegion} with: boxIndex {Int32} "Add a box to the end of the array" self aboutToAdd. myRegions at: myIndex * mySpace axisCount storeMany: projections with: mySpace axisCount with: boxIndex * mySpace axisCount. myIndex := myIndex + 1. ^myIndex - 1! {void} addTransformedBox: box {BoxStepper} with: dsp {GenericCrossDsp} "Add the current box, transformed by the dsp" | base {Int32} | self aboutToAdd. base := myIndex * mySpace axisCount. Int32Zero almostTo: mySpace axisCount do: [ :dimension {Int32} | myRegions at: base + dimension store: ((dsp subMapping: dimension) ofAll: (box projection: dimension))]. myIndex := myIndex + 1.! {void} intersectWithBox: box {BoxStepper} "Intersect the current region with a box. May leave the result uncanonicalized" Int32Zero almostTo: myIndex do: [ :i {Int32} | (box intersectBoxInto: myRegions with: i) ifFalse: [self deleteBox: i]].! {void} mergeBoxes "merge boxes which differ in only one projection" Ravi thingToDo. "hash lookup" Int32Zero almostTo: myIndex do: [ :i {Int32} | (self isDeleted: i) ifFalse: [Int32Zero almostTo: myIndex do: [ :j {Int32} | (i == j or: [self isDeleted: j]) ifFalse: [self tryMergeBoxes: i with: j]]]]! {XnRegion} region "The current region in the accumulator. CLIENT MUST KNOW THAT IT IS CANONICAL" ^GenericCrossRegion make: mySpace with: myIndex with: ((myRegions copy: myIndex * mySpace axisCount) cast: PtrArray)! {void} removeDeleted "Remove boxes which have been deleted" | to {Int32} from {Int32} | from := to := Int32Zero. [from < myIndex] whileTrue: [(self isDeleted: from) ifFalse: [from > to ifTrue: [myRegions at: to * mySpace axisCount storeMany: myRegions with: mySpace axisCount with: from * mySpace axisCount]. to := to + 1]. from := from + 1]. myIndex := to! {void} step: someObj {Heaper} self unionWithBoxes: (someObj cast: GenericCrossRegion) boxStepper! {void} unionWithBox: box {BoxStepper} "Add the current box to the accumulator" | initialIndex {Int32} addedIndex {Int32} | initialIndex := myIndex. addedIndex := self addBox: box. self distributeUnion: addedIndex with: Int32Zero with: initialIndex.! {void} unionWithBoxes: boxes {BoxStepper} "Add a sequence of disjoint boxes to the accumulator" myIndex = Int32Zero ifTrue: [[boxes hasValue] whileTrue: [self addBox: boxes. boxes step]] ifFalse: [[boxes hasValue] whileTrue: [self unionWithBox: boxes. boxes step]]! {Heaper} value ^self region! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BoxAccumulator class instanceVariableNames: ''! (BoxAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BoxAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 8! linkTimeNonInherited SomeAccumulators := NULL! ! !BoxAccumulator class methodsFor: 'creation'! make: region {GenericCrossRegion} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: region] ifFalse: [^ (self new.Become: result) create: region]! make: space {CrossSpace} with: expectedBoxCount {Int32} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: space with: expectedBoxCount] ifFalse: [^ (self new.Become: result) create: space with: expectedBoxCount]! !Accumulator subclass: #EdgeAccumulator instanceVariableNames: ' myManager {EdgeManager} myStartsInside {BooleanVar} myEdges {PtrArray of: TransitionEdge} myIndex {Int32} myPending {TransitionEdge} myResultGiven {BooleanVar NOCOPY}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-EdgeRegion'! (EdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !EdgeAccumulator methodsFor: 'protected: create'! create: manager {EdgeManager} with: startsInside {BooleanVar} super create. myManager := manager. myStartsInside := startsInside. myEdges := PtrArray nulls: 4. myIndex := -1. myPending := NULL. myResultGiven := false! create: manager {EdgeManager} with: startsInside {BooleanVar} with: edges {PtrArray of: TransitionEdge} with: index {Int32} with: pending {TransitionEdge} super create. myManager := manager. myStartsInside _ startsInside. myEdges _ edges. myIndex := index. myPending _ pending. myResultGiven := false! ! !EdgeAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. myResultGiven := true. result == NULL ifTrue: [ ^EdgeAccumulator create: myManager with: myStartsInside with: myEdges with: myIndex with: myPending] ifFalse: [ ^(EdgeAccumulator new.Become: result) create: myManager with: myStartsInside with: myEdges with: myIndex with: myPending]! {void} destroy (SomeAccumulators store: self) ifFalse: [super destroy]! ! !EdgeAccumulator methodsFor: 'operations'! {void} step: someObj {Heaper} self edge: (someObj cast: TransitionEdge)! {Heaper} value ^self region! ! !EdgeAccumulator methodsFor: 'edge operations'! {void} edge: x {TransitionEdge} "add a transition at the given position. doing it again cancels it" myPending == NULL ifTrue: [myPending := x] ifFalse: [(myPending isEqual: x) ifTrue: [myPending := NULL] ifFalse: [self storeStep: myPending. myPending := x]].! {void} edges: stepper {EdgeStepper} "add a whole bunch of edges at once, assuming that they are sorted and there are no duplicates" "do the first step manually in case it is the same as the current edge then do all the rest without checking for repeats" stepper hasValue ifTrue: [|edge {TransitionEdge} | self edge: stepper fetchEdge. stepper step. [(edge := stepper fetch cast: TransitionEdge) ~~ NULL] whileTrue: [ myPending ~~ NULL ifTrue: [self storeStep: myPending]. myPending := edge. stepper step]]! {XnRegion} region "make a region out of the accumulated edges" myPending ~~ NULL ifTrue: [self storeStep: myPending. myPending := NULL]. myResultGiven := true. ^myManager makeNew: myStartsInside with: myEdges with: myIndex + 1! ! !EdgeAccumulator methodsFor: 'private:'! {void} storeStep: edge {TransitionEdge} "Just store an edge into the array and increment the count" myIndex := myIndex + 1. myIndex = myEdges count ifTrue: [ myEdges := (myEdges copyGrow: myEdges count) cast: PtrArray. myResultGiven := false] ifFalse: [ myResultGiven ifTrue: [ myEdges := myEdges copy cast: PtrArray. myResultGiven := false]]. myEdges at: myIndex store: edge.! ! !EdgeAccumulator methodsFor: 'hooks:'! {void RECEIVE.HOOK} restartEdgeAccumulator: rcvr {Rcvr unused} myResultGiven := false! ! !EdgeAccumulator methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myManager _ receiver receiveHeaper. myStartsInside _ receiver receiveBooleanVar. myEdges _ receiver receiveHeaper. myIndex _ receiver receiveInt32. myPending _ receiver receiveHeaper. self restartEdgeAccumulator: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myManager. xmtr sendBooleanVar: myStartsInside. xmtr sendHeaper: myEdges. xmtr sendInt32: myIndex. xmtr sendHeaper: myPending.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EdgeAccumulator class instanceVariableNames: ''! (EdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !EdgeAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 8! linkTimeNonInherited SomeAccumulators := NULL! ! !EdgeAccumulator class methodsFor: 'create'! make: manager {EdgeManager} with: startsInside {BooleanVar} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: manager with: startsInside] ifFalse: [^ (self new.Become: result) create: manager with: startsInside]! !Accumulator subclass: #IntegerEdgeAccumulator instanceVariableNames: ' myStartsInside {BooleanVar} myEdges {IntegerVarArray} myIndex {UInt32} havePending {BooleanVar} myPending {IntegerVar}' classVariableNames: 'SomeAccumulators {InstanceCache} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (IntegerEdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeAccumulator methodsFor: 'protected: creation'! create: startsInside {BooleanVar} with: count {UInt32} super create. myStartsInside _ startsInside. myEdges _ IntegerVarArray zeros: count. myIndex _ Int32Zero. havePending _ false. myPending _ IntegerVar0! create: startsInside {BooleanVar} with: edges {IntegerVarArray} with: index {UInt32} with: hasPending {BooleanVar} with: pending {IntegerVar} super create. myStartsInside _ startsInside. myEdges _ edges. myIndex _ index. havePending _ hasPending. myPending _ pending! ! !IntegerEdgeAccumulator methodsFor: 'creation'! {Accumulator} copy | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [ ^IntegerEdgeAccumulator create: myStartsInside with: myEdges with: myIndex with: havePending with: myPending] ifFalse: [ ^(IntegerEdgeAccumulator new.Become: result) create: myStartsInside with: myEdges with: myIndex with: havePending with: myPending]! {void} destroy (SomeAccumulators store: self) ifFalse: [super destroy]! ! !IntegerEdgeAccumulator methodsFor: 'operations'! {void} step: someObj {Heaper} self edge: (someObj cast: IntegerPos) asIntegerVar! {Heaper} value ^self region! ! !IntegerEdgeAccumulator methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << self region << ')'! ! !IntegerEdgeAccumulator methodsFor: 'edge operations'! {void} edge: x {IntegerVar} "add a transition at the given position. doing it again cancels it. This particular coding is used for C++ inlinability" havePending ifTrue: [myPending = x ifTrue: [havePending _ false] ifFalse: [myEdges at: myIndex storeIntegerVar: myPending. myIndex _ myIndex + 1. myPending _ x]] ifFalse: [havePending _ true. myPending _ x].! {void} edges: stepper {IntegerEdgeStepper} "add a whole bunch of edges at once, assuming that they are sorted and there are no duplicates" stepper hasValue ifTrue: [self edge: stepper edge. stepper step. stepper hasValue ifTrue: [havePending ifFalse: [myPending _ stepper edge. havePending _ true. stepper step]. [stepper hasValue] whileTrue: [myEdges at: myIndex storeIntegerVar: myPending. myIndex _ myIndex + 1. myPending _ stepper edge. stepper step]]]! {IntegerRegion} region "make a region out of the accumulated edges" havePending ifTrue: [myEdges at: myIndex storeIntegerVar: myPending. ^IntegerRegion create: myStartsInside with: myIndex + 1 with: myEdges] ifFalse: [myIndex == Int32Zero ifTrue: [myStartsInside ifTrue: [^IntegerRegion allIntegers] ifFalse: [^IntegerRegion make]] ifFalse: [^IntegerRegion create: myStartsInside with: myIndex with: myEdges]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerEdgeAccumulator class instanceVariableNames: ''! (IntegerEdgeAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !IntegerEdgeAccumulator class methodsFor: 'creation'! make: startsInside {BooleanVar} with: count {UInt32} | result {Heaper} | result := SomeAccumulators fetch. result == NULL ifTrue: [^ self create: startsInside with: count] ifFalse: [^ (self new.Become: result) create: startsInside with: count]! ! !IntegerEdgeAccumulator class methodsFor: 'smalltalk: init'! initTimeNonInherited SomeAccumulators := InstanceCache make: 16! linkTimeNonInherited SomeAccumulators := NULL! !Accumulator subclass: #PtrArrayAccumulator instanceVariableNames: ' myValues {PtrArray} myN {UInt4} myValuesGiven {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-aspire'! PtrArrayAccumulator comment: 'To save array copies, this class will hand out its internal array if the size is right. If it does so it remembers so that if new elements are introduced, a copy can be made for further use.'! (PtrArrayAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !PtrArrayAccumulator methodsFor: 'operations'! {Accumulator} copy ^PtrArrayAccumulator create: (myValues copy cast: PtrArray) with: myN! {void} step: x {Heaper} myN + 1 < myValues count ifFalse: [myValues := (myValues copyGrow: myValues count+1) cast: PtrArray]. myValues at: myN store: x. myN := myN + 1.! {Heaper} value myValues count == myN ifTrue: [ myValuesGiven := true. ^ myValues] ifFalse: [ ^myValues copy: myN]! ! !PtrArrayAccumulator methodsFor: 'create'! create super create. myValues := PtrArray nulls: 2. myN := UInt32Zero. myValuesGiven := false! create: count {UInt32} super create. myValues := PtrArray nulls: count. myN := UInt32Zero. myValuesGiven := false! create: values {PtrArray} with: n {UInt32} super create. myValues := values. myN := n. myValuesGiven := false! !Accumulator subclass: #SetAccumulator instanceVariableNames: 'muSet {MuSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! SetAccumulator comment: 'A SetAccumulator accumulates a bunch of objects and then makes an ImmuSet containing all the accumulated objects. Several people have observed that a SetAccumulator doesn''t buy you much because instead you could just store into a MuSet. While this is true (and is in fact how SetAccumulator is trivially implemented), my feeling is that if what a loop is doing is enumerating a bunch of elements from which a Set is to be formed, using a SetAccumulator in the loops says this more clearly to readers of the code.'! (SetAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SetAccumulator methodsFor: 'accessing'! {void} step: someObj {Heaper} muSet store: someObj! {Heaper} value ^ muSet asImmuSet! ! !SetAccumulator methodsFor: 'protected: creation'! create super create. muSet _ MuSet make! create: initialSet {ScruSet} super create. muSet _ initialSet asMuSet! ! !SetAccumulator methodsFor: 'creation'! {Accumulator} copy ^ SetAccumulator create: muSet asMuSet! ! !SetAccumulator methodsFor: 'smalltalk: passe'! {ImmuSet} get self passe! ! !SetAccumulator methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. muSet _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: muSet.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SetAccumulator class instanceVariableNames: ''! (SetAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !SetAccumulator class methodsFor: 'instance creation'! {SetAccumulator} make "Make a SetAccumulator which starts out with no elements accumulated" ^SetAccumulator create! {SetAccumulator} make: initialSet {ScruSet} "Make a new SetAccumulator in which all the current elements of initialSet are already accumulated. Future changes to initialSet have no effect on the accumulator." ^SetAccumulator create: initialSet! !Accumulator subclass: #TableAccumulator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! TableAccumulator comment: 'Consider this class''s public status as obsolete. Eventually This class will either be private of get retired.'! (TableAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TableAccumulator methodsFor: 'deferred operations'! {void} step: elem {Heaper} "Add elem to the internal table." self subclassResponsibility! {Heaper} value "Return the accumulated table." self subclassResponsibility! ! !TableAccumulator methodsFor: 'deferred create'! {Accumulator} copy "Should this copy the array?" self subclassResponsibility! ! !TableAccumulator methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << ' on ' << self value! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TableAccumulator class instanceVariableNames: ''! (TableAccumulator getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !TableAccumulator class methodsFor: 'pseudoConstructors'! {TableAccumulator} make "Returns an Accumulator which will produce an MuArray of the elements accumulated into it in order of accumulation. See MuArray. Equivalent to 'arrayAccumulator()'. Eventually either he or I should be declared obsolete. INLINE" ^MuArray arrayAccumulator! !TableAccumulator subclass: #ArrayAccumulator instanceVariableNames: 'arrayInternal {MuArray}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Steppers'! (ArrayAccumulator getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ArrayAccumulator methodsFor: 'protected: create'! create: onTable {MuArray} super create. arrayInternal _ onTable! ! !ArrayAccumulator methodsFor: 'operations'! {void} step: obj {Heaper} arrayInternal isEmpty ifTrue: [arrayInternal atInt: IntegerVar0 store: obj] ifFalse: [arrayInternal atInt: (arrayInternal domain quickCast: IntegerRegion) stop introduce: obj]! {Heaper} value ^ arrayInternal.! ! !ArrayAccumulator methodsFor: 'create'! {Accumulator} copy ^ ArrayAccumulator make: (arrayInternal copy cast: MuArray)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ArrayAccumulator class instanceVariableNames: ''! (ArrayAccumulator getOrMakeCxxClassDescription) friends: 'friend class XuArray;'; attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ArrayAccumulator class methodsFor: 'create'! {TableAccumulator} make: onTable {MuArray} ^ self create: onTable! ! !ArrayAccumulator class methodsFor: 'smalltalk: creation'! create.IntegerTable: aTable ^self new create: aTable! !Accumulator subclass: #UnionRecruiter instanceVariableNames: 'muSet {MuSet}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Collection-Sets'! UnionRecruiter comment: 'Like a SetAccumulator, a UnionRecruiter makes an ImmuSet out of the things that it Accumulates. However, the things that a UnionRecruiter accumulates must themselves be ScruSets, and the resulting ImmuSet consists of the union of the elements of each of the accumulated sets as of the time they were accumulated.'! (UnionRecruiter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !UnionRecruiter methodsFor: 'accessing'! {void} step: someObj {Heaper} muSet storeAll: (someObj cast: ScruSet)! {Heaper} value ^ muSet asImmuSet! ! !UnionRecruiter methodsFor: 'protected: creation'! create super create. muSet _ MuSet make! ! !UnionRecruiter methodsFor: 'creation'! {Accumulator} copy | result {Accumulator} | result _ UnionRecruiter make. result step: muSet. ^result! ! !UnionRecruiter methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. muSet _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: muSet.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! UnionRecruiter class instanceVariableNames: ''! (UnionRecruiter getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !UnionRecruiter class methodsFor: 'pseudo constructors'! {UnionRecruiter} make "Make a new UnionRecruiter which hasn't yet accumulated anything" ^UnionRecruiter create! !Heaper subclass: #Arrangement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-arrange'! Arrangement comment: 'Generally represents a pair of an OrderSpec and a Region. Arrangements map between regions and primArrays.'! (Arrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #COPY; yourself)! !Arrangement methodsFor: 'accessing'! {void} copyElements: toArray {PrimArray} with: toDsp {Dsp} with: fromArray {PrimArray} with: fromArrange {Arrangement} with: fromRegion {XnRegion} "Copy elements into toArray arranged according to the receiver. Copy them from fromArray arranged according to fromArrange. The source region is fromRegion. It gets tranformed by toDsp into the toArray." fromRegion stepper forEach: [:key {Position} | toArray at: (self indexOf: (toDsp of: key)) DOTasLong storeValue: (fromArray fetchValue: (fromArrange indexOf: key) DOTasLong)]! {IntegerVar} indexOf: position {Position unused} "Return the index of position into my Region according to my OrderSpec." self subclassResponsibility! {IntegerRegion} indicesOf: region {XnRegion} "Return the region of all the indices corresponding to positions in region." self subclassResponsibility! {XnRegion} keysOf: start {Int32} with: stop {Int32} "Return the region that corresponds to a range of indices." self subclassResponsibility! {XnRegion} region "The region of positions in the arrangement" self subclassResponsibility! ! !Arrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !Arrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr.! !Arrangement subclass: #ExplicitArrangement instanceVariableNames: 'myPositions {PtrArray of: Position}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-tumbler'! (ExplicitArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ExplicitArrangement methodsFor: 'create'! create: positions {PtrArray of: Position} super create. myPositions := positions.! ! !ExplicitArrangement methodsFor: 'accessing'! {IntegerVar} indexOf: position {Position} Int32Zero almostTo: myPositions count do: [ :i {Int32} | (position isEqual: (myPositions fetch: i)) ifTrue: [^i]]. Heaper BLAST: #NotFound. ^ -1 "compiler fodder"! {IntegerRegion} indicesOf: region {XnRegion} | result {IntegerRegion} | result := IntegerRegion make. Int32Zero almostTo: myPositions count do: [ :i {Int32} | (region hasMember: ((myPositions fetch: i) cast: Position)) ifTrue: [result := (result with: i integer) cast: IntegerRegion]]. ^result! {XnRegion} keysOf: start {Int32} with: stop {Int32} | result {XnRegion} | result := NULL. start almostTo: stop do: [ :i {Int32} | result == NULL ifTrue: [result := ((myPositions fetch: i) cast: Position) asRegion] ifFalse: [result := result with: ((myPositions fetch: i) cast: Position)]]. result == NULL ifTrue: [Heaper BLAST: #IndexOutOfBounds]. ^result! {XnRegion} region | result {XnRegion} | result := (myPositions get: Int32Zero) cast: XnRegion. 1 almostTo: myPositions count do: [ :i {Int32} | result := result with: ((myPositions get: i) cast: Position)]. ^result! ! !ExplicitArrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^ myPositions contentsHash! {UInt32} hashForEqual ^ myPositions contentsHash! {BooleanVar} isEqual: other {Heaper} other cast: ExplicitArrangement into: [:o {ExplicitArrangement} | ^ myPositions contentsEqual: o positions] others: [^ false ]. ^ false "fodder"! ! !ExplicitArrangement methodsFor: 'private: accessing'! {PtrArray} positions ^ myPositions! ! !ExplicitArrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myPositions _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myPositions.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExplicitArrangement class instanceVariableNames: ''! (ExplicitArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; add: #NOT.A.TYPE; yourself)! !ExplicitArrangement class methodsFor: 'create'! {Arrangement} make: positions {PtrArray of: Position} ^self create: positions! !Arrangement subclass: #IntegerArrangement instanceVariableNames: ' myOrdering {OrderSpec} myRegion {IntegerRegion}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! (IntegerArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IntegerArrangement methodsFor: 'accessing'! {void} copyElements: toArray {PrimArray} with: toDsp {Dsp} with: fromArray {PrimArray} with: fromArrange {Arrangement} with: fromRegion {XnRegion} | other {IntegerArrangement} start {Int32} stop {Int32} toStart {Int32} | other _ fromArrange cast: IntegerArrangement. (myOrdering isEqual: other ordering) ifFalse: [self unimplemented]. (myRegion isSimple and: [other region isSimple and: [fromRegion isSimple]]) ifFalse: [self unimplemented]. self knownBug. "Assume ascending for the moment." start _ (fromArrange indexOf: (fromRegion chooseOne: myOrdering)) DOTasLong. stop _ (fromArrange indexOf: (fromRegion chooseOne: myOrdering reversed)) DOTasLong. toStart _ (self indexOf: (toDsp of: (fromRegion chooseOne: myOrdering))) DOTasLong. "stop < start ifTrue: [| tmp {Int32} | tmp _ start. start _ stop. stop _ tmp]." toArray at: toStart storeMany: fromArray with: stop + 1 - start with: start! {IntegerVar} indexOf: position {Position} "Return the index of position into my Region according to my OrderSpec." | sum {IntegerVar} intPos {IntegerVar} | sum _ IntegerVar0. intPos _ (position cast: IntegerPos) asIntegerVar. (myRegion simpleRegions: myOrdering) forEach: [:region {IntegerRegion} | (region hasIntMember: intPos) ifTrue: [^sum + (intPos - ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar) abs] ifFalse: [sum _ sum + region count]]. Heaper BLAST: #NotInTable. ^ -1 "compiler fodder"! {IntegerRegion} indicesOf: region {XnRegion} "Return the region of all the indices corresponding to positions in region." Someone shouldImplement. ^NULL "fodder"! {XnRegion} keysOf: start {Int32} with: stop {Int32} "Return the region that corresponds to a range of indices." | offset {Int32} left {Int32} right {Int32} | offset _ start. left _ -1. (myRegion simpleRegions: myOrdering) forEach: [:region {XnRegion} | region count <= offset ifTrue: [offset _ offset - region count DOTasLong] ifFalse: [left == -1 ifTrue: [left _ ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar DOTasLong + offset. offset _ stop - (start - offset). offset <= region count DOTasLong ifTrue: [^IntegerRegion make: left with: (((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar + offset)]] ifFalse: [right _ ((region chooseOne: myOrdering) cast: IntegerPos) asIntegerVar DOTasLong + offset. ^IntegerRegion make: left with: right]]]. Heaper BLAST: #NotInTable. ^ NULL "compiler fodder"! {OrderSpec} ordering ^myOrdering! {XnRegion} region ^myRegion! ! !IntegerArrangement methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myRegion << ', ' << myOrdering << ')'! ! !IntegerArrangement methodsFor: 'protected: creation'! create: region {XnRegion} with: ordering {OrderSpec} super create. region isFinite ifFalse: [Heaper BLAST: #MustBeFinite]. myRegion _ region cast: IntegerRegion. myOrdering _ ordering! ! !IntegerArrangement methodsFor: 'testing'! {UInt32} actualHashForEqual ^ myOrdering hashForEqual + myRegion hashForEqual! {UInt32} hashForEqual ^ myOrdering hashForEqual + myRegion hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: IntegerArrangement into: [:o {IntegerArrangement} | ^ (myOrdering isEqual: o ordering) and: [myRegion isEqual: o region]] others: [^ false]. ^ false "fodder"! ! !IntegerArrangement methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myOrdering _ receiver receiveHeaper. myRegion _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendHeaper: myOrdering. xmtr sendHeaper: myRegion.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerArrangement class instanceVariableNames: ''! (IntegerArrangement getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !IntegerArrangement class methodsFor: 'creation'! make: region {XnRegion} with: ordering {OrderSpec} ^self create: region with: ordering! !Heaper subclass: #BeCarrier instanceVariableNames: ' myLabel {BeLabel | NULL} myRangeElement {BeRangeElement}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Basic'! BeCarrier comment: 'These are used to carry a combination of a rangeElement and a label. Using FeRangeElements would be a hack that drags in permissions checking, etc.'! (BeCarrier getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeCarrier methodsFor: 'accessing'! {BeLabel | NULL} fetchLabel ^myLabel! {BeLabel} getLabel myLabel == NULL ifTrue: [Heaper BLAST: #NoLabel]. ^myLabel! {FeRangeElement} makeFe myLabel == NULL ifTrue: [^myRangeElement makeFe: myLabel] ifFalse: [^myRangeElement makeFe: myLabel]! {BeRangeElement} rangeElement ^myRangeElement! ! !BeCarrier methodsFor: 'creation'! create: label {BeLabel | NULL} with: element {BeRangeElement} super create. myLabel _ label. myRangeElement _ element. (myLabel ~~ NULL) == (myRangeElement isKindOf: BeEdition) ifFalse: [Heaper BLAST: #IncorrectLabel]! ! !BeCarrier methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeCarrier class instanceVariableNames: ''! (BeCarrier getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeCarrier class methodsFor: 'creation'! {BeCarrier} label: element {BeRangeElement} "For non-Editions only." [BeGrandMap] USES. ^self create: (CurrentGrandMap fluidGet newLabel) with: element! make: element {BeRangeElement} "For non-Editions only." ^self create: NULL with: element! make: label {BeLabel | NULL} with: element {BeRangeElement} "For editions only." ^self create: label with: element! !XnExecutor subclass: #BeEditionDetectorExecutor instanceVariableNames: 'myEdition {BeEdition}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange3'! BeEditionDetectorExecutor comment: 'This class notifies its edition when its last detector has gone.'! (BeEditionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BeEditionDetectorExecutor methodsFor: 'protected: create'! create: edition {BeEdition} super create. myEdition := edition.! ! !BeEditionDetectorExecutor methodsFor: 'execute'! {void} execute: arg {Int32} arg == Int32Zero ifTrue: [ myEdition removeLastDetector].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeEditionDetectorExecutor class instanceVariableNames: ''! (BeEditionDetectorExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BeEditionDetectorExecutor class methodsFor: 'creation'! {XnExecutor} make: edition {BeEdition} ^ self create: edition! !XnExecutor subclass: #BeWorkLockExecutor instanceVariableNames: 'myWork {BeWork}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-brange2'! (BeWorkLockExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeWorkLockExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32 unused} "The work's locking pointer will already be NULL, so we only have to update" myWork updateFeStatus! ! !BeWorkLockExecutor methodsFor: 'create'! create: work {BeWork} super create. myWork := work! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BeWorkLockExecutor class instanceVariableNames: ''! (BeWorkLockExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !BeWorkLockExecutor class methodsFor: 'pseudoconstructors'! make: work {BeWork} ^ BeWorkLockExecutor create: work! !Heaper subclass: #ByteShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! ByteShuffler comment: 'Instances shuffle bytes to convert between byte sexes. Subclasses are defined for each of the various transformations.'! (ByteShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !ByteShuffler methodsFor: 'shuffle'! {ByteShuffler} inverse "Return a shuffler that inverts the receiver's shuffler. This will typically be the same transformation." ^self! {void} shuffle: precision {Int32} with: buffer {void star} with: size {Int32} "Go from one byte sex to another for representing numbers of the specified precision." precision == 8 ifTrue: [^VOID]. precision == 16 ifTrue: [self shuffle16: buffer with: size. ^VOID]. precision == 32 ifTrue: [self shuffle32: buffer with: size. ^VOID]. precision == 64 ifTrue: [self shuffle64: buffer with: size. ^VOID]. Heaper BLAST: #BadPrecision! ! !ByteShuffler methodsFor: 'private: shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 16 bit numbers." self subclassResponsibility! {void} shuffle32: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 32 bit numbers." self subclassResponsibility! {void} shuffle64: buffer {void star} with: count {Int32} "Go from one byte sex to another for representing 64 bit numbers." self subclassResponsibility! ! !ByteShuffler methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !ByteShuffler subclass: #NoShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! NoShuffler comment: 'No transformation.'! (NoShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !NoShuffler methodsFor: 'shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} "Do nothing."! {void} shuffle32: buffer {void star} with: count {Int32} "Do nothing."! {void} shuffle64: buffer {void star} with: count {Int32} "Do nothing."! !ByteShuffler subclass: #SimpleShuffler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! SimpleShuffler comment: 'shuffle big-endian to little-endian transformation.'! (SimpleShuffler getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !SimpleShuffler methodsFor: 'shuffle'! {void} shuffle16: buffer {void star} with: count {Int32} " shuffle alternating bytes. " [0 almostTo: count * 2 by: 2 do: [:index | | temp {Uint8} | temp _ buffer at: index. buffer at: index storeUInt: (buffer at: index + 1). buffer at: index + 1 storeUInt: temp]] smalltalkOnly. 'UInt8 temp; UInt8 * base = (UInt8 *) buffer; for (Int32 index = 0 ; index < count * 2 ; index += 2) { temp = base[index]; base[index] = base[index + 1]; base[index + 1] = temp; } ' translateOnly.! {void} shuffle32: buffer {void star} with: count {Int32} " shuffle alternating words. " [0 almostTo: count * 4 by: 4 do: [:index | | temp {UInt8} | temp _ buffer at: index. buffer at: index storeUInt: (buffer at: index + 3). buffer at: index + 3 storeUInt: temp. temp _ buffer at: index + 1. buffer at: index + 1 storeUInt: (buffer at: index + 2). buffer at: index + 2 storeUInt: temp. ]] smalltalkOnly. 'UInt8 temp; UInt8 * base = (UInt8 *) buffer; for (Int32 index = 0 ; index < count * 4; index += 4) { temp = base[index]; base[index] = base[index + 3]; base[index + 3] = temp; temp = base[index + 1]; base[index + 1] = base[index + 2]; base[index + 2] = temp; }' translateOnly.! {void} shuffle64: buffer {void star} with: count {Int32} self unimplemented.! !Heaper subclass: #CacheManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cache'! (CacheManager getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !CacheManager methodsFor: 'accessing'! {Heaper | NULL} fetch: key {Heaper} "Return the value associated with the key, if any." self subclassResponsibility! {BooleanVar} hasMember: key {Heaper} "Does te cach contain something at the given key?" "Should the key be a Heaper or a Position?" self subclassResponsibility! {BooleanVar} wipe: key {Heaper} "Remove the cached association with key. Return true if the cache contained something at that key." self subclassResponsibility! ! !CacheManager methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !Heaper subclass: #CanopyCache instanceVariableNames: ' myCachedCrum {CanopyCrum} myCachedRoot {CanopyCrum} myCachedPath {MuSet of: CanopyCrum}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Be-Canopy'! (CanopyCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CanopyCache methodsFor: 'protected: creation'! create super create. myCachedCrum _ NULL. myCachedRoot _ NULL. myCachedPath _ MuSet make! ! !CanopyCache methodsFor: 'operations'! {void} clearCache "Clear the cache because the canopy has changed. This ought to destroy the cachedPath. This must be cleared after every episode!!!!!!" myCachedCrum _ NULL. myCachedRoot _ NULL. myCachedPath _ MuSet make.! {MuSet of: CanopyCrum} pathFor: canopyCrum {CanopyCrum} "Return the set of all crums from canopyCrum (inclusive) to the top of canopyCrum's canopy." (myCachedCrum basicCast: Heaper star) == canopyCrum ifFalse: [| cur {CanopyCrum} | cur _ canopyCrum. myCachedCrum _ canopyCrum. myCachedRoot _ canopyCrum. myCachedPath _ MuSet make. [cur ~~ NULL] whileTrue: [myCachedRoot _ cur. myCachedPath store: cur. cur _ cur fetchParent]]. ^myCachedPath! {CanopyCrum} rootFor: bertCrum {CanopyCrum} "Return the crum at the top of canopyCrum's canopy." self pathFor: bertCrum. ^myCachedRoot! {void} updateCache: childCrum {CanopyCrum} forParent: parentCrum {CanopyCrum} "If the cache contains childCrum it must be made to contain childCrum's new parent: parentCrum. Also update CachedRoot." (myCachedPath hasMember: childCrum) ifTrue: [myCachedPath store: parentCrum. (myCachedRoot basicCast: Heaper star) == childCrum ifTrue: [myCachedRoot _ parentCrum]]! {void} updateCacheFor: canopyCrum {CanopyCrum} "If the cache contains canopyCrum, it must be updated because canopyCrum has new parents. For now, just invalidate the cache." (myCachedCrum basicCast: Heaper star) == canopyCrum ifTrue: [self clearCache]! ! !CanopyCache methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CanopyCache class instanceVariableNames: ''! (CanopyCache getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CanopyCache class methodsFor: 'make'! make ^ self create! !XnExecutor subclass: #Cattleman instanceVariableNames: 'myPasture {DiskManager}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-diskman'! Cattleman comment: 'Remove flocks from the snarfpacker'! (Cattleman getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Cattleman methodsFor: 'create'! create: dm {DiskManager} super create. myPasture := dm! ! !Cattleman methodsFor: 'invoking'! {void} execute: token {Int32} "[Drops add: token] smalltalkOnly." (Heaper isConstructed: myPasture) ifTrue: [ [Heaper setGC: true] smalltalkOnly. myPasture dropFlock: token. [Heaper setGC: false] smalltalkOnly]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cattleman class instanceVariableNames: ''! (Cattleman getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !Cattleman class methodsFor: 'create'! make: dm {DiskManager} ^ self create: dm! !Heaper subclass: #CBlockTracker instanceVariableNames: ' myFileName {char star | NULL} myLineNo {Int4} myMaxDirty {IntegerVar} myLimit {IntegerVar} myDirtySoFar {IntegerVar} myTrulyDirtySoFar {IntegerVar} myDirtyInfos {MuSet of: IntegerPos} myDirtyInfosCount {IntegerVar} myOuterTracker {CBlockTracker | NULL} myOccurencesCount {IntegerVar}' classVariableNames: 'TheTrackerList {CBlockTracker | NULL} ' poolDictionaries: '' category: 'Xanadu-Snarf'! (CBlockTracker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTracker methodsFor: 'creation'! create: dirty {IntegerVar} with: outer {CBlockTracker | NULL} super create. dirty = -1 ifTrue: [myMaxDirty _ 1000] ifFalse: [myMaxDirty _ dirty]. myOuterTracker _ outer. myFileName _ NULL. myLineNo _ Int32Zero. myDirtySoFar _ Int32Zero. myTrulyDirtySoFar _ Int32Zero. myDirtyInfos _ MuSet make. myDirtyInfosCount _ Int32Zero. myOccurencesCount _ 1. outer == NULL ifTrue: [myLimit _ myMaxDirty] ifFalse: [myLimit _ outer slack min: myMaxDirty]! ! !CBlockTracker methodsFor: 'accessing'! {void} dirty: info {FlockInfo | NULL} myDirtySoFar _ myDirtySoFar + 1. myTrulyDirtySoFar _ myTrulyDirtySoFar + 1. (info ~~ NULL) assert. myDirtyInfos store: (IntegerPos make: info getShepherd hashForEqual). myDirtyInfosCount _ myDirtyInfos count. self reportProblems! {CBlockTracker | NULL} fetchUnwrapped | result {CBlockTracker | NULL} stored {CBlockTracker | NULL} | result _ myOuterTracker. result ~~ NULL ifTrue: [result innerDirtied: myMaxDirty. result innerTrulyDirtied: myTrulyDirtySoFar. result innerDirtyInfos: myDirtyInfos. result reportProblems]. myFileName ~~ NULL ifTrue: [(TheTrackerList == NULL or: [(stored _ TheTrackerList fetchMatch: self) == NULL]) ifTrue: [myOuterTracker _ TheTrackerList. myDirtyInfos _ MuSet make. TheTrackerList _ self] ifFalse: [stored updateFrom: self]]. ^result! {void} track: fileName {char star} with: lineNo {Int32} myFileName _ fileName. myLineNo _ lineNo.! ! !CBlockTracker methodsFor: 'printing'! {void} printAllOn: oo {ostream reference} oo << self << ' '. myOuterTracker ~~ NULL ifTrue: [myOuterTracker printAllOn: oo]! {void} printOn: oo {ostream reference} oo << '"' << myFileName << '"' << ', line ' << myLineNo << ': ' << self getCategory name << '('. oo << myMaxDirty << ', ' << myLimit << ', ' << myDirtySoFar << ', ' << myTrulyDirtySoFar << ', ' << myDirtyInfosCount << ', ' << myOccurencesCount << ')'! ! !CBlockTracker methodsFor: 'private: accessing'! {IntegerVar} dirtyInfosCount ^myDirtyInfosCount! {IntegerVar} dirtySoFar ^myDirtySoFar! {CBlockTracker | NULL} fetchMatch: other {CBlockTracker} (myFileName ~~ NULL and: [other fileName ~~ NULL and: [(String strcmp: myFileName with: other fileName) = Int32Zero and: [myLineNo = other lineNo]]]) ifTrue: [^self] ifFalse: [myOuterTracker == NULL ifTrue: [^NULL] ifFalse: [^myOuterTracker fetchMatch: other]]! {char star | NULL} fileName ^myFileName! {void} innerDirtied: dirty {IntegerVar} myDirtySoFar _ myDirtySoFar + dirty! {void} innerDirtyInfos: dirties {MuSet of: IntegerPos} myDirtyInfos storeAll: dirties. myDirtyInfosCount _ myDirtyInfos count! {void} innerTrulyDirtied: dirty {IntegerVar} myTrulyDirtySoFar _ myTrulyDirtySoFar + dirty! {IntegerVar} limit ^myLimit! {Int32} lineNo ^myLineNo! {IntegerVar} maxDirty ^myMaxDirty! {IntegerVar} occurencesCount ^ myOccurencesCount! {void} reportProblems ^VOID "(myLimit < 1000 and: [myDirtyInfosCount > myMaxDirty ""((myDirtySoFar max: myTrulyDirtySoFar) max: myDirtyInfosCount) > myLimit""]) ifTrue: [cerr << ' Limit exceeded [ '. self printAllOn: cerr. [cerr endEntry. ""myDirtyInfosCount > myMaxDirty ifTrue: [self halt]""] smalltalkOnly]"! {IntegerVar} slack ^myLimit - myDirtySoFar! {IntegerVar} trulyDirtySoFar ^myTrulyDirtySoFar! {void} updateFrom: other {CBlockTracker} myMaxDirty _ myMaxDirty max: other maxDirty. myLimit _ myLimit min: other limit. myDirtySoFar _ myDirtySoFar max: other dirtySoFar. myTrulyDirtySoFar _ myTrulyDirtySoFar max: other trulyDirtySoFar. myDirtyInfosCount _ myDirtyInfosCount max: other dirtyInfosCount. myOccurencesCount _ myOccurencesCount + other occurencesCount! ! !CBlockTracker methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CBlockTracker class instanceVariableNames: ''! (CBlockTracker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTracker class methodsFor: 'creation'! make: dirty {IntegerVar} with: outer {CBlockTracker | NULL} ^self create: dirty with: outer! ! !CBlockTracker class methodsFor: 'smalltalk: init'! linkTimeNonInherited TheTrackerList _ NULL! ! !CBlockTracker class methodsFor: 'printing'! {void} printTrackersOn: oo {ostream reference} "CBlockTracker printTrackersOn: cerr. cerr endEntry" oo << ' Consistent-Block Behavior '. TheTrackerList ~~ NULL ifTrue: [TheTrackerList printAllOn: oo]. oo << ' '.! !Heaper subclass: #Chameleon instanceVariableNames: ' myA {IntegerVar} myB {Heaper} myC {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Chameleon getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Chameleon methodsFor: 'instance creation'! create super create. myA _ IntegerVar0. myB _ NULL. myC _ false.! create: a {IntegerVar} with: b {Heaper} with: c {BooleanVar} super create. myA _ a. myB _ b. myC _ c.! ! !Chameleon methodsFor: 'accessing'! {void} explain: oo {ostream reference} oo << self getCategory name << ' '.! ! !Chameleon methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !Chameleon methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myA _ receiver receiveIntegerVar. myB _ receiver receiveHeaper. myC _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myA. xmtr sendHeaper: myB. xmtr sendBooleanVar: myC.! !Chameleon subclass: #Butterfly instanceVariableNames: ' myE {IntegerVar} myF {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Butterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !Butterfly methodsFor: 'instance creation'! create super create. myE _ IntegerVar0. myF _ NULL.! ! !Butterfly methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myE _ receiver receiveIntegerVar. myF _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myE. xmtr sendHeaper: myF.! !Butterfly subclass: #GoldButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (GoldButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)!Butterfly subclass: #IronButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (IronButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME.ANY.SUBCLASS.OF Chameleon ); yourself)!Butterfly subclass: #LeadButterfly instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (LeadButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #(MAY.BECOME DeadMoth ); add: #(MAY.BECOME Butterfly ); add: #CONCRETE; yourself)!Chameleon subclass: #DeadButterfly instanceVariableNames: ' myJ {IntegerVar} myK {Heaper} myL {Heaper} myM {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Cxx-class-stuff'! (DeadButterfly getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !DeadButterfly methodsFor: 'instance creation'! create super create. myJ _ IntegerVar0. myK _ NULL.! ! !DeadButterfly methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myJ _ receiver receiveIntegerVar. myK _ receiver receiveHeaper. myL _ receiver receiveHeaper. myM _ receiver receiveHeaper.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myJ. xmtr sendHeaper: myK. xmtr sendHeaper: myL. xmtr sendHeaper: myM.! !Chameleon subclass: #DeadMoth instanceVariableNames: ' myG {IntegerVar} myH {Heaper} myI {BooleanVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (DeadMoth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !DeadMoth methodsFor: 'instance creation'! create super create. myG _ IntegerVar0. myH _ NULL. myI _ false.! ! !DeadMoth methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myG _ receiver receiveIntegerVar. myH _ receiver receiveHeaper. myI _ receiver receiveBooleanVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myG. xmtr sendHeaper: myH. xmtr sendBooleanVar: myI.! !Chameleon subclass: #Moth instanceVariableNames: 'myD {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Chameleon'! (Moth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME Butterfly ); add: #COPY; yourself)! !Moth methodsFor: 'becoming'! {void} molt (Butterfly new.Become: self) create! ! !Moth methodsFor: 'instance creation'! create: d {IntegerVar} super create. myD _ d.! ! !Moth methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myD _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myD.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Moth class instanceVariableNames: ''! (Moth getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #(MAY.BECOME Butterfly ); add: #COPY; yourself)! !Moth class methodsFor: 'instance creation'! make ^self create: 4! !Heaper subclass: #ChunkCleaner instanceVariableNames: 'myNext {ChunkCleaner}' classVariableNames: 'FirstCleaner {ChunkCleaner} ' poolDictionaries: '' category: 'Xanadu-schunk'! ChunkCleaner comment: 'Chunk cleaners perform end-of-session cleanup work. This includes making sure that session level objects are released.'! (ChunkCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ChunkCleaner methodsFor: 'private: accessing'! {ChunkCleaner} next ^ myNext! ! !ChunkCleaner methodsFor: 'invoking'! {void} cleanup self subclassResponsibility! ! !ChunkCleaner methodsFor: 'protected: create'! create super create. myNext := FirstCleaner. FirstCleaner := self.! ! !ChunkCleaner methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChunkCleaner class instanceVariableNames: ''! (ChunkCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !ChunkCleaner class methodsFor: 'cleanup'! {void} beClean | cleaner {ChunkCleaner} | cleaner := FirstCleaner. [cleaner ~~ NULL] whileTrue: [ cleaner cleanup. cleaner := cleaner next].! ! !ChunkCleaner class methodsFor: 'smalltalk: init'! linkTimeNonInherited FirstCleaner := NULL! !ChunkCleaner subclass: #PersistentCleaner instanceVariableNames: '' classVariableNames: 'ThePersistentCleaner {PersistentCleaner} ' poolDictionaries: '' category: 'Xanadu-packer'! PersistentCleaner comment: 'This does a makePersistent when ServerChunks go away'! (PersistentCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PersistentCleaner methodsFor: 'invoking'! {void} cleanup CurrentPacker fluidGet purge! ! !PersistentCleaner methodsFor: 'protected: create'! create super create! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PersistentCleaner class instanceVariableNames: ''! (PersistentCleaner getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !PersistentCleaner class methodsFor: 'smalltalk: init'! linkTimeNonInherited ThePersistentCleaner := NULL! ! !PersistentCleaner class methodsFor: 'create'! make ThePersistentCleaner == NULL ifTrue: [ThePersistentCleaner := self create]. ^ ThePersistentCleaner! !XnExecutor subclass: #CloseExecutor instanceVariableNames: '' classVariableNames: ' FDArray {Int32Array} FileDescriptorHolders {WeakPtrArray} ' poolDictionaries: '' category: 'Xanadu-gchooks'! CloseExecutor comment: 'This executor manages objects that need to close file descriptors on finalization.'! (CloseExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !CloseExecutor methodsFor: 'protected: create'! create super create! ! !CloseExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32} | fd {Int32} | fd := FDArray intAt: estateIndex. fd ~= -1 ifTrue: [ [fd close] smalltalkOnly. 'close((int)fd);' translateOnly. FDArray at: estateIndex storeInt: -1]! ! !CloseExecutor methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CloseExecutor class instanceVariableNames: ''! (CloseExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !CloseExecutor class methodsFor: 'accessing'! {void} registerHolder: holder {Heaper} with: fd {Int32} | slot {Int32} | slot _Int32Zero. FDArray == NULL ifTrue: [ | exec {XnExecutor} | FDArray := Int32Array make: 32. exec := CloseExecutor create. FileDescriptorHolders := WeakPtrArray make: exec with: 32]. slot := FileDescriptorHolders indexOf: NULL. [self halt.] smalltalkOnly. slot == -1 ifTrue: [ [self halt]smalltalkOnly. slot := FDArray count. FDArray := (FDArray copyGrow: 16) cast: Int32Array. FileDescriptorHolders := (FileDescriptorHolders copyGrow: 16) cast: WeakPtrArray]. FDArray at: slot storeInt: fd. FileDescriptorHolders at: slot store: holder.! {void} unregisterHolder: holder {Heaper} with: fd {Int32} | slot {Int32} | slot := FileDescriptorHolders indexOfEQ: holder. [slot ~= -1 and: [slot < FDArray count and: [(FDArray intAt: slot) ~= fd]]] whileTrue: [ slot := FileDescriptorHolders indexOfEQ: holder with: slot + 1]. (slot == -1 or: [(FDArray intAt: slot) ~= fd]) ifTrue: [ Heaper BLAST: #SanityViolation]. FileDescriptorHolders at: slot store: NULL. FDArray at: slot storeInt: -1.! ! !CloseExecutor class methodsFor: 'smalltalk: init'! linkTimeNonInherited FDArray := NULL. FileDescriptorHolders := NULL! !Heaper subclass: #CommIbid instanceVariableNames: 'myNumber {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Xcvr'! (CommIbid getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !CommIbid methodsFor: 'creation'! create: number {IntegerVar} super create. myNumber _ number.! ! !CommIbid methodsFor: 'accessing'! {IntegerVar} number ^myNumber! ! !CommIbid methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myNumber << ')'.! ! !CommIbid methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! ! !CommIbid methodsFor: 'generated:'! create.Rcvr: receiver {Rcvr} super create.Rcvr: receiver. myNumber _ receiver receiveIntegerVar.! {void} sendSelfTo: xmtr {Xmtr} super sendSelfTo: xmtr. xmtr sendIntegerVar: myNumber.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommIbid class instanceVariableNames: ''! (CommIbid getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #COPY; yourself)! !CommIbid class methodsFor: 'creation'! make: number {IntegerVar} ^self create: number! !Heaper subclass: #Connection instanceVariableNames: '' classVariableNames: 'TheBootPlans {PrimPtr2PtrTable of: Category with: BootPlan} ' poolDictionaries: '' category: 'Xanadu-cobbler'! Connection comment: 'Suclasses represent particular kinds of connections. The connection object serves two purposes: you can get the boot object from it, and you can destroy it to break the connection. Note that destroying the bootObject does not break the connection because you might have gotten other objects from it.'! (Connection getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Connection methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Heaper} bootHeaper self subclassResponsibility! ! !Connection methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Connection class instanceVariableNames: ''! (Connection getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Connection class methodsFor: 'smalltalk: init'! initTimeNonInherited TheBootPlans _ PrimPtr2PtrTable make: 8.! linkTimeNonInherited TheBootPlans _ NULL! ! !Connection class methodsFor: 'registration'! {void} clearPlan: cat {Category} "Throw out any plan associated with cat." TheBootPlans remove: cat! {void} registerBootPlan: plan {BootPlan} "For the current run, return plan if anyone looks for a bootPlan that returns an instance of the category that plan returns." TheBootPlans at: plan bootCategory introduce: plan! ! !Connection class methodsFor: 'creation'! make: category {Category} ^((TheBootPlans get: category) cast: BootPlan) connection! !Connection subclass: #DirectConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! DirectConnection comment: 'We just made the object, so the connection is just a reference to the object.'! (DirectConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DirectConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !DirectConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} super create. myCategory _ cat. myHeaper _ heaper! {void} destruct "myHeaper destroy. There are bootHeapers that you REALLY don't want to destroy, such as the GrandMap" super destruct! !Connection subclass: #DiskConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! DiskConnection comment: 'Keep an object from the disk. For the moment, put the disk connection in a global variable and export a function so that anyone can destroy it....'! (DiskConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DiskConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !DiskConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} super create. myCategory _ cat. myHeaper _ heaper! {void} destruct myHeaper _ NULL. CurrentPacker fluidGet purge. CurrentPacker fluidGet destroy. CurrentPacker fluidSet: (NULL basicCast: DiskManager). super destruct! !Connection subclass: #NestedConnection instanceVariableNames: ' myCategory {Category} myHeaper {Heaper} mySub {Connection}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! NestedConnection comment: 'We just made an object that wraps another object, so the connection needs to wrap the connection by which that other object was obtained.'! (NestedConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NestedConnection methodsFor: 'accessing'! {Category} bootCategory ^myCategory! {Heaper} bootHeaper ^myHeaper! ! !NestedConnection methodsFor: 'creation'! create: cat {Category} with: heaper {Heaper} with: sub {Connection} super create. myCategory _ cat. myHeaper _ heaper. mySub _ sub! {void} destruct mySub destroy. myHeaper destroy. super destruct! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NestedConnection class instanceVariableNames: ''! (NestedConnection getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !NestedConnection class methodsFor: 'creation'! {Connection} make: cat {Category} with: heaper {Heaper} with: sub {Connection} ^self create: cat with: heaper with: sub! !Heaper subclass: #Cookbook instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-cobbler'! (Cookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Cookbook methodsFor: 'accessing'! {Category} bootCategory self subclassResponsibility! {Recipe} fetchRecipe: cat {Category} self subclassResponsibility! {Category} getCategoryFor: no {IntegerVar} self subclassResponsibility! {Recipe} getRecipe: cat {Category} self subclassResponsibility! {char star} id "return a string that uniquely determines the version of the cookbook. It should change whenever classes are added or removed, or when their storage or transmission protocol changes" self subclassResponsibility! {Cookbook} next self subclassResponsibility! {IntegerVar} numberOfCategory: cat {Category} self subclassResponsibility! {PtrArray} recipes self subclassResponsibility! ! !Cookbook methodsFor: 'printing'! {void} printOn: oo {ostream reference} self subclassResponsibility! ! !Cookbook methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Cookbook class instanceVariableNames: ''! (Cookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; add: #EQ; yourself)! !Cookbook class methodsFor: 'declaring'! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine to: recipes. ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} with: cuisine3 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine3 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! {Cookbook} declareCookbook: id {char star} with: bootCat {Category} with: cuisine1 {Recipe} with: cuisine2 {Recipe} with: cuisine3 {Recipe} with: cuisine4 {Recipe} "Create and register a cookbook. The cookbook can be looked up according to etiher its name or bootCategory." | recipes {PtrArray} count {Int32} | "preorder -> recipe." recipes _ WeakPtrArray make: XnExecutor noopExecutor with: Heaper preorderMax + 1. count _ ActualCookbook addCuisine: cuisine1 to: recipes. count _ count + (ActualCookbook addCuisine: cuisine2 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine3 to: recipes). count _ count + (ActualCookbook addCuisine: cuisine4 to: recipes). ^ActualCookbook create: bootCat with: id with: recipes with: count! ! !Cookbook class methodsFor: 'creation'! {Cookbook} make "Just return the empty cookbook." ^ActualCookbook make.String: 'empty'! {Cookbook} make.Category: bootCat {Category} "Return the cookbook registered for the given bootCategory." ^ActualCookbook make.Category: bootCat! {Cookbook} make.String: id {char star} "Return the cookbook registered for the given string." ^ActualCookbook make.String: id! !Cookbook subclass: #ActualCookbook instanceVariableNames: ' myName {char star} myBootCategory {Category} myNext {Cookbook} myRecipes {PtrArray of: Recipe} myDecoding {PtrArray of: Category} myEncoding {UInt32Array}' classVariableNames: 'TheCookbooks {Cookbook} ' poolDictionaries: '' category: 'Xanadu-cobbler'! ActualCookbook comment: 'We internally map from Category to preorder number for the category and lookup using that preorder number.'! (ActualCookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ActualCookbook methodsFor: 'accessing'! {Category} bootCategory ^myBootCategory! {Recipe} fetchRecipe: cat {Category} ^(myRecipes fetch: cat preorderNumber) cast: Recipe! {Category} getCategoryFor: no {IntegerVar} | category {Category} | category _ (myDecoding fetch: no DOTasLong) cast: Category. category == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^category! {Recipe} getRecipe: cat {Category} | recipe {Recipe} | recipe _ (myRecipes fetch: cat preorderNumber) cast: Recipe. recipe == NULL ifTrue: [Heaper BLAST: #NotInTable]. ^recipe! {char star} id ^myName! {Cookbook} next ^myNext! {IntegerVar} numberOfCategory: cat {Category} | num {Int32} | num _ myEncoding uIntAt: cat preorderNumber. num >= myRecipes count ifTrue: [Heaper BLAST: #UnencodedCategory]. ^num! {PtrArray} recipes ^myRecipes! ! !ActualCookbook methodsFor: 'creation'! create: cat {Category} with: id {char star} with: recipes {PtrArray of: Recipe} with: count {Int32} | preorderLimit {Int32} code {Int32} | super create. myName _ id. myBootCategory _ cat. preorderLimit _ Heaper preorderMax + 1. "preorder -> recipe." myRecipes _ recipes. "preorder -> code." myEncoding _ UInt32Array make: preorderLimit. "code -> category" myDecoding _ PtrArray nulls: count. code _ Int32Zero. Int32Zero almostTo: preorderLimit do: [:i {Int32} | | recipe {Recipe} | recipe _ (myRecipes fetch: i) cast: Recipe. recipe == NULL ifTrue: [myEncoding at: i storeUInt: preorderLimit] ifFalse: [myEncoding at: i storeUInt: code. myDecoding at: code store: recipe categoryOfDish. code _ code + 1]]. myNext _ TheCookbooks. TheCookbooks _ self! {void} destroy "ActualCookbooks last for the whole run."! ! !ActualCookbook methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << 'an ' << self getCategory name! ! !ActualCookbook methodsFor: 'smalltalk: hooks:'! {void RECEIVE.HOOK} receiveClassList: rcvr {Rcvr} | count {IntegerVar} | count _ rcvr receiveIntegerVar. myRecipes _ MuTable make: HeaperSpace make. Int32Zero almostTo: count do: [:i {Int32} | | clName {String} cl {Category} | clName _ rcvr receiveString. [cl _ Smalltalk at: clName asSymbol ifAbsent: [Cookbook BLAST: 'class name not recognized']] smalltalkOnly. myRecipes at: cl store: cl getRecipe.]! {void SEND.HOOK} sendClassList: xmtr {Xmtr} xmtr sendIntegerVar: myRecipes count. myRecipes stepper forEach: [:rec | xmtr sendString: rec categoryOfDish name]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ActualCookbook class instanceVariableNames: ''! (ActualCookbook getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ActualCookbook class methodsFor: 'global: utility'! {Int32} addCuisine: cuisine {Recipe} to: recipes {PtrArray} | recipe {Recipe} count {Int32} | count _ Int32Zero. recipe _ cuisine. [recipe ~~ NULL] whileTrue: [recipes at: recipe categoryOfDish preorderNumber store: recipe. count _ count + 1. recipe _ recipe next]. ^count! ! !ActualCookbook class methodsFor: 'creation'! {Cookbook} make.Category: bootCat {Category} | cookbook {Cookbook} | cookbook _ TheCookbooks. [cookbook ~~ NULL] whileTrue: [(cookbook bootCategory isEqual: bootCat) ifTrue: [^cookbook]. cookbook _ cookbook next]. Heaper BLAST: #UnknownCookbook. ^NULL "fodder"! {Cookbook} make.String: id {char star} | cookbook {Cookbook} | cookbook _ TheCookbooks. [cookbook ~~ NULL] whileTrue: [(String strcmp: cookbook id with: id) == Int32Zero ifTrue: [^cookbook]. cookbook _ cookbook next]. Heaper BLAST: #UnknownCookbook. ^NULL "fodder"! ! !ActualCookbook class methodsFor: 'smalltalk: initialization'! {void} cleanupGarbage TheCookbooks _ NULL! initTimeNonInherited Cookbook declareCookbook: 'empty' with: Heaper with: NULL! {void} linkTimeNonInherited TheCookbooks _ NULL! !Heaper subclass: #CoordinateSpace instanceVariableNames: ' myEmptyRegion {XnRegion} myFullRegion {XnRegion} myIdentityDsp {Dsp} myAscending {OrderSpec | NULL} myDescending {OrderSpec | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! CoordinateSpace comment: 'A coordinate space represents (among other things) the domain space of a table. Corresponding to each coordinate space will be a set of objects of the following kinds: Position -- The elements of the coordinate space. Mapping -- (Add a description.) OrderSpec -- The ways of specifying partial orders of this coordinate space''s Positions. XuRegion -- An XuRegion represents a set of Positions. The domain of a table is an XuRegion. When defining a new coordinate space class, one generally defines new corresponing subclasses of each of the above classes. A kind of any of the above classes knows what coordinate space it is a part of (the "coordinateSpace()" message will yield an appropriate kind of CoordinateSpace). CoordinateSpace objects exist mostly just to represent this commonality. Coordinate spaces are disjoint--it is an error to use any of the generic protocol of any of the above classes if the objects in question are of two different coordinate spaces. For example, "dsp->of (pos)" is not an error iff "dsp->coordinateSpace()->isEqual (pos->coordinateSpace())". Note that this class is not COPY or even PSEUDO_COPY. All of the instance variables for CoordinateSpace are basically cached quantities that require vary little actual state from the derived classes in order to be constructed. This realization allows a knot to be untangled when reading these objects from external storage.'! (CoordinateSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CoordinateSpace methodsFor: 'accessing'! {UInt32} actualHashForEqual ^Heaper takeOop! {OrderSpec CLIENT INLINE} ascending "Essential. The natural full-ordering of the coordinate space." ^self getAscending! {Mapping CLIENT INLINE} completeMapping: range {XnRegion} "Essential. A Mapping which maps each position in this space to every position in the range region. The region can be from any CoordinateSpace." ^Mapping make.CoordinateSpace: self with.Region: range! {OrderSpec CLIENT INLINE} descending "The mirror image of the partial order returned by 'CoordinateSpace::ascending'." ^self getDescending! {XnRegion CLIENT INLINE} emptyRegion "Essential. An empty region in this coordinate space" ^myEmptyRegion! {(OrderSpec | NULL) INLINE} fetchAscending "The natural full-ordering of the coordinate space." ^myAscending! {(OrderSpec | NULL) INLINE} fetchDescending "The mirror image of the partial order returned by 'CoordinateSpace::fetchAscending'." ^myDescending! {XnRegion CLIENT INLINE} fullRegion "A full region in this coordinate space" ^myFullRegion! {OrderSpec} getAscending "Essential. The natural full-ordering of the coordinate space." | result {OrderSpec | NULL} | result := self fetchAscending. result == NULL ifTrue: [Heaper BLAST: #NoFullOrder]. ^result! {OrderSpec} getDescending "The mirror image of the partial order returned by 'CoordinateSpace::getAscending'." | result {OrderSpec | NULL} | result := self fetchDescending. result == NULL ifTrue: [Heaper BLAST: #NoFullOrder]. ^result! {Dsp INLINE} identityDsp "A Dsp which maps all positions in the coordinate space onto themselves" ^myIdentityDsp! {Mapping CLIENT INLINE} identityMapping "Essential. A Mapping which maps all positions in the coordinate space onto themselves" ^self identityDsp! {BooleanVar} isEqual: other{Heaper} self subclassResponsibility! {BooleanVar} verify: thing {Heaper} "tell whether this is a valid Position/XuRegion/Dsp/OrderSpec for this space" thing cast: (Position | XnRegion | Dsp | OrderSpec) into: [:t | ^self isEqual: t coordinateSpace]. "cast into blasts here." ^false! ! !CoordinateSpace methodsFor: 'smalltalk: defaults'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} self create: emptyRegion with: fullRegion with: identityDsp with: NULL with: NULL! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} self create: emptyRegion with: fullRegion with: identityDsp with: ascending with: NULL! ! !CoordinateSpace methodsFor: 'protected: create followup'! {void} finishCreate: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} myEmptyRegion := emptyRegion. myFullRegion := fullRegion. myIdentityDsp := identityDsp. myAscending := ascending. (descending == NULL and: [ascending ~~ NULL]) ifTrue: [myDescending := ascending reversed] ifFalse: [myDescending := descending].! ! !CoordinateSpace methodsFor: 'create'! create super create. myEmptyRegion := NULL. myFullRegion := NULL. myIdentityDsp := NULL. myAscending := NULL. myDescending := NULL.! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} super create. myEmptyRegion := emptyRegion. myFullRegion := fullRegion. myIdentityDsp := identityDsp. myAscending := ascending. (descending == NULL and: [ascending ~~ NULL]) ifTrue: [myDescending := ascending reversed] ifFalse: [myDescending := descending].! ! !CoordinateSpace methodsFor: 'smalltalk: passe'! {Mapping} importMapping: data {PrimArray} with: rangeSpace {CoordinateSpace default: NULL} self passe! {OrderSpec} importOrderSpec: data {PrimArray} self passe! {XnRegion} importRegion: data {PrimArray} self passe! {Mapping} mapping: data {PrimArray} self passe! {Mapping} mapping: data {PrimArray} with: rangeSpace {CoordinateSpace default: NULL} self passe! {OrderSpec} orderSpec: data {PrimArray} self passe! {XnRegion} region: data {PrimArray} self passe! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CoordinateSpace class instanceVariableNames: ''! (CoordinateSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CoordinateSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{OrderSpec CLIENT} ascending {Mapping CLIENT} completeMapping: range {XuRegion} {OrderSpec CLIENT} descending {XuRegion CLIENT} emptyRegion {XuRegion CLIENT} fullRegion {Mapping CLIENT} identityMapping "! !CoordinateSpace subclass: #BasicSpace instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Basic'! BasicSpace comment: 'BasicSpace versus CoordinateSpace is not a type distinction in that there is no difference in contract with the client. BasicSpace exists as a convenience to the definer of new CoordinateSpaces. A new subclass of CoordinateSpace should be a subclass of BasicSpace iff there is only one coordinateSpace that corresponds to the new class. I.e., that the instances are not parameterized to yield different coordinate spaces. BasicSpace provides some conveniences (especially in Smalltalk) for defining a single canonical instance at dynamic initialization time, and always using it. As this class is irrelevent to CoordinateSpace clients, but is useful to those defining other kinds of coordinate spaces, it is an exellent example of something that would be classified as a "protected" class--something to be persued if we try to make modules more like classes.'! (BasicSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #OBSOLETE; add: #SMALLTALK.ONLY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BasicSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !BasicSpace methodsFor: 'creation'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} with: descending {OrderSpec default: NULL} super create: emptyRegion with: fullRegion with: identityDsp with: ascending with: descending.! ! !BasicSpace methodsFor: 'smalltalk: defaults'! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} self create: emptyRegion with: fullRegion with: identityDsp with: NULL with: NULL! create: emptyRegion {XnRegion} with: fullRegion {XnRegion} with: identityDsp {Dsp} with: ascending {OrderSpec default: NULL} self create: emptyRegion with: fullRegion with: identityDsp with: ascending with: NULL! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicSpace class instanceVariableNames: 'theSpace {BasicSpace star} '! (BasicSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #OBSOLETE; add: #SMALLTALK.ONLY; add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !BasicSpace class methodsFor: 'smalltalk: initialization'! initTimeInherited self REQUIRES: PrimSpec. theSpace _ (self new.AllocType: #PERSISTENT) create.! linkTimeInherited theSpace _ NULL.! suppressInitTimeInherited! suppressLinkTimeInherited! !CoordinateSpace subclass: #CrossSpace instanceVariableNames: 'mySubSpaces {PtrArray of: CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! CrossSpace comment: 'Represents the cross of several coordinate spaces. '! (CrossSpace getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxStepper; friend class GenericCrossSpace; friend class GenericCrossRegion; friend class BoxProjectionStepper;'; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossSpace methodsFor: 'accessing'! {PtrArray CLIENT of: CoordinateSpace} axes "Essential. The base spaces that I am a cross of." ^mySubSpaces copy cast: PtrArray! {CoordinateSpace CLIENT} axis: dimension {Int32} "The sub coordinate space on the given axis" ^(mySubSpaces fetch: dimension) cast: CoordinateSpace! {Int32 CLIENT INLINE} axisCount "The number of dimensions in this space" ^mySubSpaces count! ! !CrossSpace methodsFor: 'testing'! {UInt32} actualHashForEqual ^mySubSpaces contentsHash bitXor: #cat.U.CrossSpace hashForEqual! {BooleanVar} isEqual: other {Heaper} other cast: CrossSpace into: [:cross | ^cross secretSubSpaces contentsEqual: mySubSpaces] others: [^false]. ^ false "compiler fodder"! ! !CrossSpace methodsFor: 'making'! {Mapping CLIENT} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} "Essential. Map each coordinate according to the mapping from its space. NULLs mean 'use the identity mapping'" self subclassResponsibility! {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {PrimIntArray default: NULL} "Essential. Make a lexical ordering of all elements in the space, using the given ordering for each sub space. If no sub space ordering is given, then it is in the order they are in the array. subSpaceOrdering lists the lexicographic order in which each dimension should be processed. Every dimension should be listed exactly one, from most significant (at index 0) to least significant. subOrderings are indexed by *dimension*, not by lexicographic order. In order to index by lex order, look up the dimension in subSpaceOrdering, and then look up the resulting dimension number in subOrderings." self subclassResponsibility! {Tuple CLIENT} crossOfPositions: coordinates {PtrArray of: Position} "Essential. Make an individual position" self subclassResponsibility! {CrossRegion CLIENT} crossOfRegions: subRegions {PtrArray of: XnRegion | NULL} "Essential. Make a 'rectangular' region as a cross of all the given regions" self subclassResponsibility! {CrossRegion CLIENT} extrusion: dimension {Int32} with: subRegion {XnRegion} "Return a region whose projection is 'subRegion' along 'dimension', but is full on all other dimensions" self subclassResponsibility! ! !CrossSpace methodsFor: 'smalltalk: passe'! {IntegerVar} count self passe "axisCount"! {Int32} intCount self passe "axisCount"! {CrossMapping} makeCrossMapping: subMappings {PtrArray of: Mapping} self passe! {CrossOrderSpec} makeCrossOrderSpec: subOrderings {PtrArray of: OrderSpec | NULL} with: subSpaceOrdering {Int32Array default: NULL} "Make a lexical ordering of all elements in the space, using the given ordering for each sub space. If no sub space ordering is given, then it is in the order they are in the array" self passe! {CrossRegion} makeCrossRegion: subRegions {PtrArray of: XnRegion | NULL} "Make a 'rectangular' region as a cross of all the given regions" self passe! {Tuple} makeTuple: coordinates {PtrArray of: Position} "Make an individual position" self passe! {CoordinateSpace} subSpace: dimension {Int32} self passe "axis"! {PtrArray of: CoordinateSpace} subSpaces self passe "axes"! ! !CrossSpace methodsFor: 'smalltalk: defaults'! {Mapping CLIENT} crossOfMappings ^self crossOfMappings: NULL! {CrossOrderSpec CLIENT} crossOfOrderSpecs ^self crossOfOrderSpecs: NULL with: NULL! {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} ^self crossOfOrderSpecs: subOrderings with: NULL! ! !CrossSpace methodsFor: 'protected: accessing'! {PtrArray INLINE of: CoordinateSpace} secretSubSpaces "The actual array of sub spaces. DO NOT MODIFY" ^mySubSpaces! ! !CrossSpace methodsFor: 'protected: creation'! create super create. mySubSpaces := NULL.! create: subSpaces {PtrArray of: CoordinateSpace} super create. mySubSpaces := subSpaces.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CrossSpace class instanceVariableNames: ''! (CrossSpace getOrMakeCxxClassDescription) friends: 'friend class BoxAccumulator; friend class BoxStepper; friend class GenericCrossSpace; friend class GenericCrossRegion; friend class BoxProjectionStepper;'; attributes: ((Set new) add: #ON.CLIENT; add: #DEFERRED; yourself)! !CrossSpace class methodsFor: 'creation'! {CrossSpace CLIENT} make: subSpaces {PtrArray of: CoordinateSpace} "Make a cross space with the given list of subspaces" "Should use middlemen. Just hard code special cases for now" ^GenericCrossSpace make: (subSpaces copy cast: PtrArray)! make: zeroSpace {CoordinateSpace} with: oneSpace {CoordinateSpace} "Cross two sub spaces" ^GenericCrossSpace create: ((PrimSpec pointer arrayWithTwo: zeroSpace with: oneSpace) cast: PtrArray)! ! !CrossSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{PtrArray CLIENT of: CoordinateSpace} axes {CoordinateSpace CLIENT} axis: dimension {Int32} {Int32 CLIENT} axisCount {Mapping CLIENT} crossOfMappings {Mapping CLIENT} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} {CrossOrderSpec CLIENT} crossOfOrderSpecs {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} {CrossOrderSpec CLIENT} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {Int32Array default: NULL} {Tuple CLIENT} crossOfPositions: coordinates {PtrArray of: Position} {CrossRegion CLIENT} crossOfRegions: subRegions {PtrArray of: XuRegion | NULL} {CrossRegion CLIENT} extrusion: dimension {Int32} with: subRegion {XuRegion} "! !CrossSpace subclass: #GenericCrossSpace instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Cross'! GenericCrossSpace comment: 'Default implementation of cross coordinate space. was NOT.A.TYPE but that prevented compilation'! (GenericCrossSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !GenericCrossSpace methodsFor: 'making'! {Mapping} crossOfMappings: subMappings {(PtrArray of: Mapping | NULL) default: NULL} subMappings == NULL ifTrue: [^CrossMapping make: self]. Int32Zero almostTo: subMappings count do: [:i {Int32} | | subM {Mapping | NULL} | subM := (subMappings fetch: i) cast: Mapping. (subM ~~ NULL and: [(subM isKindOf: Dsp) not]) ifTrue: [MarkM shouldImplement]]. ^CrossMapping make: self with: subMappings! {CrossOrderSpec} crossOfOrderSpecs: subOrderings {(PtrArray of: OrderSpec | NULL) default: NULL} with: subSpaceOrdering {PrimIntArray default: NULL} ^CrossOrderSpec make: self with: subOrderings with: subSpaceOrdering! {Tuple} crossOfPositions: coordinates {PtrArray of: Position} ^ActualTuple make: coordinates! {CrossRegion} crossOfRegions: subRegions {PtrArray of: XnRegion | NULL} | result {PtrArray of: XnRegion} | result := subRegions copy cast: PtrArray. Int32Zero almostTo: result count do: [ :dimension {Int32} | (result fetch: dimension) == NULL ifTrue: [result at: dimension store: (self axis: dimension) fullRegion] ifFalse: [((result fetch: dimension) cast: XnRegion) isEmpty ifTrue: [^self emptyRegion cast: CrossRegion]]]. ^GenericCrossRegion make: self with: 1 with: result! {CrossRegion} extrusion: dimension {Int32} with: subRegion {XnRegion} | projs {PtrArray of: XnRegion} | subRegion isEmpty ifTrue: [^self emptyRegion cast: CrossRegion]. projs := PtrArray nulls: mySubSpaces count. Int32Zero almostTo: mySubSpaces count do: [ :i {Int32} | i = dimension ifTrue: [projs at: i store: subRegion] ifFalse: [projs at: i store: ((mySubSpaces fetch: i) cast: CoordinateSpace) fullRegion]]. ^GenericCrossRegion make: self with: 1 with: projs! ! !GenericCrossSpace methodsFor: 'private: creation'! create: subSpaces {PtrArray of: CoordinateSpace} super create: subSpaces. self finishCreate: (GenericCrossRegion empty: self) with: (GenericCrossRegion full: self with: subSpaces) with: (GenericCrossDsp identity: self with: subSpaces) with: (CrossOrderSpec fetchAscending: self with: subSpaces) with: (CrossOrderSpec fetchDescending: self with: subSpaces).! ! !GenericCrossSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << '<'. Int32Zero almostTo: mySubSpaces count do: [ :i {Int32} | i > Int32Zero ifTrue: [oo << ' x ']. oo << (mySubSpaces fetch: i)]. oo << '>'! ! !GenericCrossSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendGenericCrossSpaceTo: xmtr {Xmtr} xmtr sendHeaper: mySubSpaces.! ! !GenericCrossSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendGenericCrossSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericCrossSpace class instanceVariableNames: ''! (GenericCrossSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !GenericCrossSpace class methodsFor: 'rcvr pseudoconstructors'! {Heaper} make.Rcvr: rcvr {Rcvr} ^(GenericCrossSpace new.Become: ((rcvr cast: SpecialistRcvr) makeIbid: GenericCrossSpace)) create: (rcvr receiveHeaper cast: PtrArray)! ! !GenericCrossSpace class methodsFor: 'pseudoconstructors'! {CrossSpace} make: subSpaces {PtrArray of: CoordinateSpace} ^GenericCrossSpace create: subSpaces! !CoordinateSpace subclass: #FilterSpace instanceVariableNames: 'myBaseSpace {CoordinateSpace}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Filter'! FilterSpace comment: 'A FilterSpace can be described mathematically as a power space of its baseSpace, i.e. the set of all subsets of the baseSpace. Each position in a FilterSpace is a Region in the baseSpace, and each Filter is a set of Regions taken from the baseSpace. See Filter for more detail.'! (FilterSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !FilterSpace methodsFor: 'creation'! create: base {CoordinateSpace} super create. self finishCreate: (ClosedFilter make: self) with: (OpenFilter make: self) with: (FilterDsp make: self) with: NULL with: NULL. myBaseSpace := base! ! !FilterSpace methodsFor: 'testing'! {UInt32} actualHashForEqual ^myBaseSpace hashForEqual + 1! {BooleanVar} isEqual: other {Heaper} other cast: FilterSpace into: [:fs | ^fs baseSpace isEqual: myBaseSpace] others: [^false]. ^false "fodder"! ! !FilterSpace methodsFor: 'accessing'! {CoordinateSpace CLIENT INLINE} baseSpace "Essential. The CoordinateSpace of the Regions that are the input to Filters in this FilterSpace." ^myBaseSpace! ! !FilterSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '(' << myBaseSpace << ')'! ! !FilterSpace methodsFor: 'making'! {Filter CLIENT INLINE} allFilter: region {XnRegion} "Essential. A region that matches any region that contains all the Positions in, i.e. is a superset of, the given region." ^Filter supersetFilter: self with: region! {Filter CLIENT INLINE} anyFilter: baseRegion {XnRegion} "Essential. A filter that matches any region that intersects the given region." ^Filter intersectionFilter: self with: baseRegion! {Filter INLINE} intersectionFilter: region {XnRegion} "Essential. A filter that matches any region that intersects the given region." ^Filter intersectionFilter: self with: region! {Filter INLINE} notSubsetFilter: region {XnRegion} "A filter matching any regions that is not a subset of the given region." ^Filter notSubsetFilter: self with: region! {Filter INLINE} notSupersetFilter: region {XnRegion} "A filter that matches any region that is not a superset of the given region." ^Filter notSupersetFilter: self with: region! {Filter INLINE} orFilter: subs {ScruSet of: Filter} "A filter that matches any region that any of the filters in the set would have matched." ^Filter orFilter: self with: subs! {FilterPosition CLIENT INLINE} position: baseRegion {XnRegion} "Essential. Given a Region in the baseSpace, make a Position which corresponds to it, so that filter->hasMember (this->position (baseRegion)) iff filter->match (baseRegion)" ^FilterPosition make: baseRegion! {Filter INLINE} subsetFilter: region {XnRegion} "A filter that matches any region that is a subset of the given region." ^Filter subsetFilter: self with: region! {Filter INLINE} supersetFilter: region {XnRegion} "Essential. A region that matches any region that is a superset of the given region." ^Filter supersetFilter: self with: region! ! !FilterSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendFilterSpaceTo: xmtr {Xmtr} xmtr sendHeaper: myBaseSpace.! ! !FilterSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendFilterSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilterSpace class instanceVariableNames: ''! (FilterSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !FilterSpace class methodsFor: 'creation'! {FilterSpace CLIENT} make: base {CoordinateSpace} "A FilterSpace on the given base space." ^FilterSpace create: base! ! !FilterSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{Filter CLIENT} andFilter: baseRegion {XnRegion} {Filter CLIENT} anyFilter: baseRegion {XnRegion} {CoordinateSpace CLIENT} baseSpace {FilterPosition CLIENT} position: baseRegion {XnRegion} "! ! !FilterSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} ^(FilterSpace new.Become: ((rcvr cast: SpecialistRcvr) makeIbid: FilterSpace)) create: (rcvr receiveHeaper cast: CoordinateSpace)! !CoordinateSpace subclass: #HeaperSpace instanceVariableNames: '' classVariableNames: 'TheHeaperSpace {HeaperSpace} ' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! HeaperSpace comment: 'A HeaperSpace is one whose positions represent the identity of individual Heapers. Identity of a Heaper is determined according by its response to "isEqual" and "hashForEqual" (see "The Equality of Decisions" for a bunch of surprising issues regarding Heaper equality). A region is a HeaperSpace is a SetRegion (see SetRegion). As a result of having HeaperSpaces, one can use the identity of Heapers to index into hash tables, and still obey the convention that a table maps from positions in some coordinate space. HeaperSpaces cannot (yet?) be used as the domain space for Xanadu Stamps, and therefore also not as the domain space of an IndexedWaldo. In order to do this, the Heapers in question would have to persist in a way that Xanadu doesn''t provide for. As is typical for an unordered space, the only Dsp for this space is the identity Dsp. No type or pseudo-constructor is exported however--the Dsp is gotten by converting a HeaperSpace to a Dsp. Similarly, no heaper-specific type or pseudo-constructor is exported for my regions. The conversions are sufficient. The resulting regions are guaranteed to be SetRegions.'! (HeaperSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !HeaperSpace methodsFor: 'creation'! create super create: HeaperRegion make with: HeaperRegion make complement with: HeaperDsp make with: NULL with: NULL! ! !HeaperSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !HeaperSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeaperSpace class instanceVariableNames: ''! (HeaperSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #PSEUDO.COPY; yourself)! !HeaperSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited TheHeaperSpace := self create! linkTimeNonInherited TheHeaperSpace := NULL! ! !HeaperSpace class methodsFor: 'pseudo constructors'! {HeaperSpace INLINE} make "Return the one instance of HeaperSpace" ^TheHeaperSpace! ! !HeaperSpace class methodsFor: 'rcvr pseudo constructor'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheHeaperSpace. ^TheHeaperSpace! !CoordinateSpace subclass: #IDSpace instanceVariableNames: ' myBackend {Sequence | NULL} mySpaceNumber {IntegerVar} myNewIDCounter {Counter}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Spaces-Unordered'! IDSpace comment: 'A space of IDs, which can generate globally unique IDs. Implementation note: myBackend - the identifier of the Server which generated this space. If NULL, then it was generated by the current Server (unless mySpaceNumber is -1, in which case it is the single global IDSpace shared by all Servers. mySpaceNumber - identifies which space this is. If -1, then it is the global ID space, and myBackend must be NULL.'! (IDSpace getOrMakeCxxClassDescription) friends: 'friend IDSimpleStepper; friend class BeGrandMap; friend class IDTester; friend class ID; friend class IDRegion;'; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IDSpace methodsFor: 'making'! {IDRegion CLIENT} iDsFromServer: identifier {Sequence} "Essential. The Region of IDs in this space which might be genrated by the given Server" RaviNow shouldImplement. ^NULL "fodder"! {ID CLIENT} newID "Essential. A new ID guaranteed to be different from every other newID generated by this IDSpace or any IDSpace isEqual to it, on any Server. (Although of course IDs generated using this->oldID () may conflict if the right numbers happen to have been supplied.)" ^ID make: self fetchIDSpace with: NULL with: myNewIDCounter increment! {IDRegion CLIENT} newIDs: count {IntegerVar} "A region containing a finite number of globally unique IDs. See newID for uniqueness guarantees." ^IDRegion make: self fetchIDSpace with: (IntegerRegion integerExtent: (myNewIDCounter incrementBy: count) with: count) with: NULL with: false! ! !IDSpace methodsFor: 'private: for friends'! {Sequence} backend "Essential. The Server which created this IDSpace" myBackend == NULL ifTrue: [mySpaceNumber = -1 ifTrue: [^Sequence zero] ifFalse: [^FeServer identifier]]. ^myBackend! {Sequence | NULL} fetchBackend ^myBackend! {IDSpace | NULL} fetchIDSpace "NULL if this is the global IDSpace, self otherwise" (myBackend == NULL and: [mySpaceNumber = -1]) ifTrue: [^NULL] ifFalse: [^self]! {IDRegion} oldIDs: backend {Sequence} with: numbers {IntegerRegion} "Recreate a region of IDs from information that was stored outside the Server" backend isZero ifTrue: [(numbers intersects: (IntegerRegion after: IntegerVarZero)) ifTrue: [Heaper BLAST: #InvalidRequest] ifFalse: [^IDRegion make: self fetchIDSpace with: numbers with: NULL with: false]] ifFalse: [ | table {MuTable} | (numbers isSubsetOf: (IntegerRegion after: IntegerVarZero)) ifFalse: [Heaper BLAST: #InvalidRequest]. (backend isEqual: FeServer identifier) ifTrue: [^IDRegion make: self fetchIDSpace with: numbers with: NULL with: false]. table := MuTable make: SequenceSpace make. table at: backend store: numbers. ^IDRegion make: self fetchIDSpace with: IntegerRegion make with: table asImmuTable with: false]. ^NULL "fodder"! {IntegerVar} spaceNumber "Essential. Identifies this particular space among all those generated by the same Server." ^mySpaceNumber! ! !IDSpace methodsFor: 'private: create'! create: backend {Sequence | NULL} with: number {IntegerVar} with: counter {Counter} super create. myBackend := backend. mySpaceNumber := number. self finishCreation. myNewIDCounter := counter! {void} finishCreation | myself {IDSpace} | (myBackend == NULL and: [mySpaceNumber = -1]) ifTrue: [myself := NULL] ifFalse: [myself := self]. self finishCreate: (IDRegion usingx: myself with: (IntegerSpace make emptyRegion cast: IntegerRegion) with: NULL with: false) with: (IDRegion usingx: myself with: (IntegerSpace make fullRegion cast: IntegerRegion) with: NULL with: true) with: (IDDsp make: self) with: (IDUpOrder make: self) with: NULL! ! !IDSpace methodsFor: 'testing'! {UInt32} actualHashForEqual myBackend == NULL ifTrue: [^mySpaceNumber DOThashForEqual bitXor: self getCategory hashForEqual] ifFalse: [^(myBackend hashForEqual bitXor: mySpaceNumber DOThashForEqual) bitXor: self getCategory hashForEqual]! {BooleanVar} isEqual: other {Heaper} other cast: IDSpace into: [ :space | ^self == space or: [mySpaceNumber = space spaceNumber and: [(myBackend == NULL and: [space fetchBackend == NULL]) or: [myBackend ~~ NULL and: [space fetchBackend ~~ NULL and: [myBackend isEqual: space fetchBackend]]]]]] others: [^false]. ^false "fodder"! ! !IDSpace methodsFor: 'printing'! {void} printOn: oo {ostream reference} oo << self getCategory name << '('. self fetchIDSpace == NULL ifTrue: [oo << '!!0'] ifFalse: [oo << self backend << '.' << mySpaceNumber]. oo << ')'! ! !IDSpace methodsFor: 'accessing'! {UInt8Array CLIENT} export "Essential. Produce an array which can be handed to Server::importIDSpace on any Server to get back the same IDSpace" | xmtr {SpecialistXmtr} result {WriteVariableArrayStream} | result := WriteVariableArrayStream make: 200. xmtr := Binary2XcvrMaker make makeXmtr: (TransferSpecialist make: Cookbook make) with: result. ID exportSequence: xmtr with: self backend. xmtr sendIntegerVar: self spaceNumber. ^result array! ! !IDSpace methodsFor: 'obsolete:'! {Sequence} identifier "A Sequence uniquely identifying this IDSpace, so that FeServer::current ()->oldIDSpace (this->identifier ()) ->isEqual (this)" Ravi thingToDo. "get rid of this message and its clients" ^self backend withLast: mySpaceNumber! ! !IDSpace methodsFor: 'hooks:'! {void SEND.HOOK} sendIDSpaceTo: xmtr {Xmtr} xmtr sendHeaper: myBackend. xmtr sendIntegerVar: mySpaceNumber. xmtr sendHeaper: myNewIDCounter.! ! !IDSpace methodsFor: 'smalltalk: passe'! {ID} oldID: identifier {Sequence} "Recreate an ID from its identifier." self passe.! ! !IDSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr} self sendIDSpaceTo: xmtr.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IDSpace class instanceVariableNames: ''! (IDSpace getOrMakeCxxClassDescription) friends: 'friend IDSimpleStepper; friend class BeGrandMap; friend class IDTester; friend class ID; friend class IDRegion;'; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IDSpace class methodsFor: 'creation'! {IDSpace CLIENT} global "Return the global ID space." ^CurrentGrandMap fluidGet globalIDSpace! {IDSpace CLIENT} import: data {PrimIntArray} "Essential. Take some information describing an IDSpace and create the IDSpace it was exported from." | rcvr {SpecialistRcvr} backend {Sequence} number {IntegerVar} | rcvr := Binary2XcvrMaker make makeRcvr: (TransferSpecialist make: Cookbook make) with: (XnReadStream make: (data cast: UInt8Array)). backend := ID importSequence: rcvr. number := rcvr receiveIntegerVar. ^self make: backend with: number! {IDSpace CLIENT} unique "Essential. Create a new globally unique space of IDs" ^CurrentGrandMap fluidGet newIDSpace! ! !IDSpace class methodsFor: 'private: pseudo constructors'! make: identifier {Sequence | NULL} with: number {IntegerVar} ^self make: identifier with: number with: (CurrentGrandMap fluidGet getOrMakeIDCounter: identifier with: number)! make: identifier {Sequence | NULL} with: number {IntegerVar} with: counter {Counter} | cgm {BeGrandMap} | cgm := CurrentGrandMap fluidFetch. (identifier ~~ NULL and: [identifier isZero or: [cgm ~~ NULL and: [identifier isEqual: cgm identifier]]]) ifTrue: [^self create: NULL with: number with: counter]. ^self create: identifier with: number with: counter! ! !IDSpace class methodsFor: 'smalltalk: passe'! {FilterSpace of: IDSpace} iDFilterSpace "The coordinate space of filters on IDRegions." self passe! {Filter of: IDSpace} openIDFilter self passe.! ! !IDSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} | memory {Heaper} backend {Sequence} space {IntegerVar} idCounter {Counter} | self thingToDo. "Should intern someday" memory _ (rcvr cast: SpecialistRcvr) makeIbid: IDSpace. backend _ rcvr receiveHeaper cast: Sequence. space _ rcvr receiveIntegerVar. idCounter _ rcvr receiveHeaper cast: Counter. ^(IDSpace new.Become: memory) create: backend with: space with: idCounter! ! !IDSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{UInt8Array CLIENT} export {IDRegion CLIENT} iDsFromServer: identifier {Sequence} {ID CLIENT} newID {IDRegion CLIENT} newIDs: count {IntegerVar} "! !CoordinateSpace subclass: #IntegerSpace instanceVariableNames: '' classVariableNames: 'TheIntegerSpace {IntegerSpace} ' poolDictionaries: '' category: 'Xanadu-Spaces-Integers'! IntegerSpace comment: 'The space of all integers. See the class comments in IntegerRegion, XuInteger, and IntegerDsp for interesting properties of this space. Especially IntegerRegion. IntegerSpaces are the most frequently used of the coordinate spaces. XuArrays are an efficient data structure which we provide as a table whose domain space is an integer space. In so doing, the notion of an array is made to be simply a particular case of a table indexed by the positions of a coordinate space. However, IntegerSpaces and XuArrays are both expected to be more efficient than other spaces and tables built on other spaces. See XuArray'! (IntegerSpace getOrMakeCxxClassDescription) friends: '/* friends for class IntegerSpace */ friend class IntegerRegion; friend class IntegerDsp; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerSpace methodsFor: 'creation'! create super create: (IntegerRegion usingx: false with: Int32Zero with: (IntegerVarArray zeros: Int32Zero)) with: (IntegerRegion usingx: true with: Int32Zero with: (IntegerVarArray zeros: Int32Zero)) with: IntegerMapping identity with: IntegerUpOrder make! ! !IntegerSpace methodsFor: 'making'! {IntegerRegion CLIENT} above: start {IntegerPos} with: inclusive {BooleanVar} "Essential. Make a region that contains all integers greater than (or equal if inclusive is true) to start." | after {IntegerVar} | after _ start asIntegerVar. inclusive ifFalse: [after _ after + 1]. ^IntegerRegion after: after! {IntegerRegion CLIENT} below: stop {IntegerPos} with: inclusive {BooleanVar} "Make a region that contains all integers less than (or equal if inclusive is true) to stop." | after {IntegerVar} | after _ stop asIntegerVar. inclusive ifTrue: [after _ after + 1]. ^IntegerRegion before: after! {IntegerRegion CLIENT} interval: start {IntegerPos} with: stop {IntegerPos} "Make a region that contains all integers greater than or equal to start and less than stop." ^IntegerRegion make: start asIntegerVar with: stop asIntegerVar! {IntegerPos CLIENT INLINE} position: value {IntegerVar} "Essential. Make an integer Position object" ^value integer! {IntegerMapping CLIENT} translation: value {IntegerVar} "Essential. Make a Mapping which adds a fixed amount to any value. Should this just be supplanted by CoordinateSpace::mapping ()?" value = IntegerVarZero ifTrue: [^self identityDsp cast: IntegerMapping]. ^IntegerMapping make: value! ! !IntegerSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !IntegerSpace methodsFor: 'smalltalk: passe'! {IntegerPos} integer: value {IntegerVar} self passe "position"! ! !IntegerSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerSpace class instanceVariableNames: ''! (IntegerSpace getOrMakeCxxClassDescription) friends: '/* friends for class IntegerSpace */ friend class IntegerRegion; friend class IntegerDsp; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !IntegerSpace class methodsFor: 'creation'! {IntegerSpace INLINE} implicitReceiver "Get the receievr for wire requests." ^TheIntegerSpace! {IntegerSpace CLIENT INLINE} make "return the one integer space" ^TheIntegerSpace! ! !IntegerSpace class methodsFor: 'rcvr pseudo constructor'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheIntegerSpace. ^TheIntegerSpace! ! !IntegerSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited TheIntegerSpace := self create! linkTimeNonInherited TheIntegerSpace := NULL! ! !IntegerSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{IntegerRegion CLIENT} above: start {IntegerVar} with: inclusive {BooleanVar} {IntegerRegion CLIENT} below: start {IntegerVar} with: inclusive {BooleanVar} {IntegerRegion CLIENT} interval: start {IntegerVar} with: stop {IntegerVar} {XuInteger CLIENT} position: value {IntegerVar} {IntegerMapping CLIENT} translation: value {IntegerVar} "! !CoordinateSpace subclass: #RealSpace instanceVariableNames: '' classVariableNames: 'TheRealSpace {RealSpace} ' poolDictionaries: '' category: 'Xanadu-tumbler'! RealSpace comment: 'Non-arithmetic space of real numbers in which only certain positions are explicitly representable. In this release, the only exactly representable numbers are those real numbers which can be represented in IEEE64 (double precision) format. Future releases may make more real numbers representable.'! (RealSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !RealSpace methodsFor: 'create'! create super create: (RealRegion make: false with: PtrArray empty) with: (RealRegion make: true with: PtrArray empty) with: RealDsp make with: RealUpOrder make! ! !RealSpace methodsFor: 'making'! {RealRegion CLIENT} above: val {RealPos} with: inclusive {BooleanVar} "The region consisting of all positions >= val if inclusive, or all > val if not inclusive." inclusive ifTrue: [^RealRegion make: false with: (PrimSpec pointer arrayWith: (BeforeReal make: val))] ifFalse: [^RealRegion make: false with: (PrimSpec pointer arrayWith: (AfterReal make: val))]! {RealRegion CLIENT} below: val {RealPos} with: inclusive {BooleanVar} "The region consisting of all positions <= val if inclusive, or all < val if not inclusive." inclusive ifTrue: [^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: val))] ifFalse: [^RealRegion make: true with: (PrimSpec pointer arrayWith: (BeforeReal make: val))]! {RealRegion CLIENT} interval: start {RealPos} with: stop {RealPos} "Return a region of all numbers >= lower and < upper." MarkM thingToDo. "use a single constructor" ^((self above: start with: true) intersect: (self below: stop with: false)) cast: RealRegion! {RealPos CLIENT INLINE} position: val {IEEE64} "The XuReal representing the same real number as that exactly represented by 'val'. If 'val' doesn't represent a real number (i.e., it is an infinity or a NAN), then this message BLASTs. If 'val' is a negative zero, it is silently converted to a positive zero" ^RealPos make: val! ! !RealSpace methodsFor: 'obsolete:'! {RealRegion} after: val {IEEE64} "The region consisting of all position >= val. Should this just be supplanted by CoordinateSpace::region ()?" self thingToDo. "update clients" ^RealRegion make: false with: (PrimSpec pointer arrayWith: (BeforeReal make: (RealPos make: val)))! {RealRegion} before: val {IEEE64} "The region consisting of all position <= val Should this just be supplanted by CoordinateSpace::region ()?" self thingToDo. "update clients" ^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! {RealRegion} strictlyAfter: val {IEEE64} "The region consisting of all position > val Should this just be supplanted by CoordinateSpace::region ()? Add Boolean to after to say whether its inclusive?" self thingToDo. "update clients" ^RealRegion make: false with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! {RealRegion} strictlyBefore: val {IEEE64} "The region consisting of all position < val Should this just be supplanted by CoordinateSpace::region ()? Add Boolean to before to say whether its inclusive?" self thingToDo. "update clients" ^RealRegion make: true with: (PrimSpec pointer arrayWith: (AfterReal make: (RealPos make: val)))! ! !RealSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !RealSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RealSpace class instanceVariableNames: ''! (RealSpace getOrMakeCxxClassDescription) attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !RealSpace class methodsFor: 'creation'! {RealSpace CLIENT INLINE} make ^TheRealSpace! ! !RealSpace class methodsFor: 'rcvr pseudo constructors'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheRealSpace. ^TheRealSpace! ! !RealSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: PrimSpec. TheRealSpace := self create! linkTimeNonInherited TheRealSpace := NULL! ! !RealSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{RealRegion CLIENT} above: val {IEEE64} with: inclusive {BooleanVar} {RealRegion CLIENT} below: val {IEEE64} with: inclusive {BooleanVar} {RealRegion CLIENT} interval: lower {XuRegion} with: upper {XuReal} {XuReal CLIENT} position: val {IEEE64} "! !CoordinateSpace subclass: #SequenceSpace instanceVariableNames: '' classVariableNames: 'TheSequenceSpace {SequenceSpace} ' poolDictionaries: '' category: 'Xanadu-tumbler'! SequenceSpace comment: 'The space of all Sequences'! (SequenceSpace getOrMakeCxxClassDescription) friends: '/* friends for class SequenceSpace */ friend class Sequence; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !SequenceSpace methodsFor: 'create'! create super create: (SequenceRegion usingx: false with: PtrArray empty) with: (SequenceRegion usingx: true with: PtrArray empty) with: (SequenceMapping make: IntegerVarZero with: Sequence zero) with: SequenceUpOrder make! ! !SequenceSpace methodsFor: 'temporary'! {Sequence CLIENT login INLINE} position: numbers {PrimArray} ^self position: numbers with: IntegerVarZero! ! !SequenceSpace methodsFor: 'making'! {SequenceRegion CLIENT} above: sequence {Sequence} with: inclusive {BooleanVar} "Essential. All sequences >= sequence if inclusive, > sequence if not." inclusive ifTrue: [^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWith: (BeforeSequence make: sequence)) cast: PtrArray)] ifFalse: [^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWith: (AfterSequence make: sequence)) cast: PtrArray)]! {SequenceRegion CLIENT} below: sequence {Sequence} with: inclusive {BooleanVar} "Essential. All sequences <= sequence if inclusive, < sequence if not." inclusive ifTrue: [^SequenceRegion usingx: true with: ((PrimSpec pointer arrayWith: (AfterSequence make: sequence)) cast: PtrArray)] ifFalse: [^SequenceRegion usingx: true with: ((PrimSpec pointer arrayWith: (BeforeSequence make: sequence)) cast: PtrArray)]! {SequenceRegion CLIENT} interval: start {Sequence} with: stop {Sequence} "Return a region of all sequence >= lower and < upper." "Ravi thingToDo." "use a single constructor" "Performance" ^((self above: start with: true) intersect: (self below: stop with: false)) cast: SequenceRegion! {SequenceMapping CLIENT} mapping: shift {IntegerVar} with: translation {Sequence default: NULL} "A transformation which shifts a value by some number of places and then adds a translation to it." self thingToDo. "better name for this method" translation == NULL ifTrue: [^SequenceMapping make: shift with: Sequence zero]. ^SequenceMapping make: shift with: translation! {Sequence CLIENT login} position: arg {PrimArray} with: shift {IntegerVar} "Essential. A sequence using the given numbers and shift. Leading and trailing zeros will be stripped, and a copy will be made so that noone modifies it" "IntegerVars cannot have default arguments" | numbers {PrimIntegerArray} | numbers _ arg cast: PrimIntegerArray. numbers == NULL ifTrue: [^Sequence usingx: shift with: (IntegerVarArray zeros: Int32Zero)]. ^Sequence usingx: shift with: (numbers copy cast: PrimIntegerArray)! {SequenceRegion CLIENT} prefixedBy: sequence {Sequence} with: limit {IntegerVar} "Essential. All sequences which match the given one up to and including the given index." ^SequenceRegion usingx: false with: ((PrimSpec pointer arrayWithTwo: (BeforeSequencePrefix below: sequence with: limit) with: (BeforeSequencePrefix above: sequence with: limit)) cast: PtrArray)! ! !SequenceSpace methodsFor: 'smalltalk: passe'! {Sequence} sequence: numbers {PrimIntegerArray | NULL} with: shift {IntegerVar | IntegerVarZero} self passe "position"! {SequenceRegion} sequencesAfter: sequence {Sequence} "Essential. All sequences greater than or equal to the given sequence. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: false with: (PrimSpec pointer arrayWith: (BeforeSequence make: sequence))! {SequenceRegion} sequencesBefore: sequence {Sequence} "Essential. All sequences less than or equal to the given sequence. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: true with: (PrimSpec pointer arrayWith: (AfterSequence make: sequence))! {SequenceRegion} sequencesPrefixedBy: sequence {Sequence} with: limit {IntegerVar} "Essential. All sequences which match the given one up to and including the given index. Should this just be supplanted by CoordinateSpace::region ()?" self passe. ^SequenceRegion usingx: false with: (PrimSpec pointer arrayWithTwo: (BeforeSequencePrefix below: sequence with: limit) with: (BeforeSequencePrefix above: sequence with: limit))! {SequenceMapping} shiftAndTranslation self passe! {SequenceDsp} shiftAndTranslation: shift {IntegerVar} self passe! {SequenceDsp} shiftAndTranslation: shift {IntegerVar} with: translation {Sequence} self passe! ! !SequenceSpace methodsFor: 'testing'! {UInt32} actualHashForEqual "is equal to any basic space on the same category of positions" ^self getCategory hashForEqual + 1! {BooleanVar} isEqual: anObject {Heaper} "is equal to any basic space on the same category of positions" ^anObject getCategory == self getCategory! ! !SequenceSpace methodsFor: 'smalltalk: defaults'! {SequenceMapping CLIENT} mapping: shift {IntegerVar} "A transformation which shifts a value by some number of places and then adds a translation to it." ^self mapping: shift with: NULL! ! !SequenceSpace methodsFor: 'generated:'! {void} sendSelfTo: xmtr {Xmtr}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SequenceSpace class instanceVariableNames: ''! (SequenceSpace getOrMakeCxxClassDescription) friends: '/* friends for class SequenceSpace */ friend class Sequence; '; attributes: ((Set new) add: #PSEUDO.COPY; add: #CONCRETE; add: #ON.CLIENT; yourself)! !SequenceSpace class methodsFor: 'rcvr creation'! {Heaper} make.Rcvr: rcvr {Rcvr} (rcvr cast: SpecialistRcvr) registerIbid: TheSequenceSpace. ^TheSequenceSpace! ! !SequenceSpace class methodsFor: 'creation'! {SequenceSpace INLINE} implicitReceiver "Get the receiver for wire requests." ^TheSequenceSpace! {SequenceSpace CLIENT login INLINE} make ^TheSequenceSpace! ! !SequenceSpace class methodsFor: 'smalltalk: init'! initTimeNonInherited self REQUIRES: Sequence. TheSequenceSpace := self create! linkTimeNonInherited TheSequenceSpace := NULL! ! !SequenceSpace class methodsFor: 'smalltalk: system'! info.stProtocol "{SequenceRegion CLIENT} above: sequence {Sequence} with: inclusive {BooleanVar} {SequenceRegion CLIENT} below: sequence {Sequence} with: inclusive {BooleanVar} {SequenceRegion CLIENT} interval: lower {Region} with: upper {Sequence} {SequenceMapping CLIENT} mapping: shift {IntegerVar} with: translation {Sequence} {Sequence CLIENT} position: numbers {PrimIntegerArray} {Sequence CLIENT} position: numbers {PrimIntegerArray | NULL} with: shift {IntegerVar | IntegerVarZero} {SequenceRegion CLIENT} prefixedBy: sequence {Sequence} with: limit {IntegerVar} "! !XnExecutor subclass: #DeleteExecutor instanceVariableNames: '' classVariableNames: ' StorageArray {void vector star} StorageHolders {WeakPtrArray} ' poolDictionaries: '' category: 'Xanadu-gchooks'! DeleteExecutor comment: 'This executor manages objects that need to release non-Heaper storage on finalization.'! (DeleteExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !DeleteExecutor methodsFor: 'invoking'! {void} execute: estateIndex {Int32} | storage {void star} | storage := StorageArray at: estateIndex. storage ~~ NULL ifTrue: [ storage delete]. StorageArray at: estateIndex put: NULL.! ! !DeleteExecutor methodsFor: 'protected: create'! create super create! ! !DeleteExecutor methodsFor: 'generated:'! actualHashForEqual ^self asOop! isEqual: other ^self == other! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DeleteExecutor class instanceVariableNames: ''! (DeleteExecutor getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #EQ; add: #NOT.A.TYPE; yourself)! !DeleteExecutor class methodsFor: 'accessing'! {void} registerHolder: holder {Heaper} with: storage {void star} | slot {Int32} | StorageArray == NULL ifTrue: [ | exec {XnExecutor} | 'DeleteExecutor::StorageArray = new void* [32]; memset (DeleteExecutor::StorageArray, 0, 32 * sizeof(void*));' translateOnly. [StorageArray := PtrArray nulls: 32] smalltalkOnly. exec := DeleteExecutor create. StorageHolders := WeakPtrArray make: exec with: 32]. slot := StorageHolders indexOf: NULL. slot == -1 ifTrue: [ slot := StorageHolders count. 'void ** newArray = new void* [slot + 16]; memset(&newArray[slot], 0, 16 * sizeof(void*)); MEMMOVE(newArray, DeleteExecutor::StorageArray, (int)slot); delete DeleteExecutor::StorageArray; DeleteExecutor::StorageArray = newArray;' translateOnly. [StorageArray := StorageArray copyGrow: 16] smalltalkOnly. StorageHolders := (StorageHolders copyGrow: 16) cast: WeakPtrArray]. StorageArray at: slot put: storage. StorageHolders at: slot store: holder.! {void} unregisterHolder: holder {Heaper} with: storage {void star} | slot {Int32} | slot := StorageHolders indexOfEQ: holder. [slot ~= -1 and: [slot < StorageHolders count and: [(StorageArray at: slot) ~~ storage]]] whileTrue: [ slot := StorageHolders indexOfEQ: holder with: slot + 1]. (slot == -1 or: [(StorageArray at: slot) ~~ storage]) ifTrue: [ Heaper BLAST: #SanityViolation]. StorageArray at: slot put: NULL. StorageHolders at: slot store: NULL.! ! !DeleteExecutor class methodsFor: 'smalltalk: init'! linkTimeNonInherited StorageArray := NULL. StorageHolders := NULL.! !Heaper subclass: #DetectorEvent instanceVariableNames: ' myNext {DetectorEvent} myDetector {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! DetectorEvent comment: 'The detectors for comm create these and queue them up because they can only go out between requests.'! (DetectorEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #DEFERRED; yourself)! !DetectorEvent methodsFor: 'accessing'! {IntegerVar} detector ^myDetector! {DetectorEvent} next ^myNext! {void} setNext: event {DetectorEvent} myNext _ event! ! !DetectorEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." self subclassResponsibility! ! !DetectorEvent methodsFor: 'creation'! create: detector {IntegerVar} super create. myDetector _ detector. myNext _ NULL! ! !DetectorEvent methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! !DetectorEvent subclass: #DoneEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (DoneEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DoneEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager doneResponse. pm sendIntegerVar: self detector.! ! !DoneEvent methodsFor: 'creation'! create: detector {IntegerVar} super create: detector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DoneEvent class instanceVariableNames: ''! (DoneEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !DoneEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} ^ self create: detector! !DetectorEvent subclass: #FilledEvent instanceVariableNames: 'myFilling {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (FilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FilledEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager filledResponse. pm sendIntegerVar: self detector. pm sendPromise: myFilling! ! !FilledEvent methodsFor: 'creation'! create: detector {IntegerVar} with: filling {Heaper} super create: detector. myFilling _ filling! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilledEvent class instanceVariableNames: ''! (FilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !FilledEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: filling {Heaper} ^ self create: detector with: filling! !DetectorEvent subclass: #GrabbedEvent instanceVariableNames: ' myWork {Heaper} myAuthor {Heaper} myReason {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (GrabbedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrabbedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager grabbedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendPromise: myAuthor. pm sendIntegerVar: myReason. pm sendPromise: (PrimIntValue make: myReason)! ! !GrabbedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: author {Heaper} with: reason {IntegerVar} super create: detector. myWork _ work. myAuthor _ author. myReason _ reason! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrabbedEvent class instanceVariableNames: ''! (GrabbedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !GrabbedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: author {Heaper} with: reason {IntegerVar} ^self create: detector with: work with: author with: reason! !DetectorEvent subclass: #RangeFilledEvent instanceVariableNames: 'myFilling {Heaper}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (RangeFilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RangeFilledEvent methodsFor: 'creation'! create: detector {IntegerVar} with: filling {Heaper} super create: detector. myFilling _ filling! ! !RangeFilledEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager rangeFilledResponse. pm sendIntegerVar: self detector. pm sendPromise: myFilling! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RangeFilledEvent class instanceVariableNames: ''! (RangeFilledEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RangeFilledEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: filling {Heaper} ^ self create: detector with: filling! !DetectorEvent subclass: #ReleasedEvent instanceVariableNames: ' myWork {Heaper} myReason {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (ReleasedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ReleasedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: reason {IntegerVar} super create: detector. myWork _ work. myReason _ reason! ! !ReleasedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager releasedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendIntegerVar: myReason. pm sendPromise: (PrimIntValue make: myReason)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ReleasedEvent class instanceVariableNames: ''! (ReleasedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !ReleasedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: reason {IntegerVar} ^self create: detector with: work with: reason! !DetectorEvent subclass: #RevisedEvent instanceVariableNames: ' myWork {Heaper} myContents {Heaper} myAuthor {Heaper} myTime {IntegerVar} mySequence {IntegerVar}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-proman'! (RevisedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisedEvent methodsFor: 'creation'! create: detector {IntegerVar} with: work {Heaper} with: contents {Heaper} with: author {Heaper} with: time {IntegerVar} with: sequence {IntegerVar} super create: detector. myWork _ work. myContents _ contents. myAuthor _ author. myTime _ time. mySequence _ sequence! ! !RevisedEvent methodsFor: 'triggering'! {void} trigger: pm {PromiseManager} "Send the message across the wire." pm sendResponse: PromiseManager revisedResponse. pm sendIntegerVar: self detector. pm sendPromise: myWork. pm sendPromise: myContents. pm sendPromise: myAuthor. pm sendIntegerVar: myTime. pm sendPromise: (PrimIntValue make: myTime). pm sendIntegerVar: mySequence. pm sendPromise: (PrimIntValue make: mySequence)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RevisedEvent class instanceVariableNames: ''! (RevisedEvent getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; add: #NOT.A.TYPE; yourself)! !RevisedEvent class methodsFor: 'creation'! {DetectorEvent} make: detector {IntegerVar} with: work {Heaper} with: contents {Heaper} with: author {Heaper} with: time {IntegerVar} with: sequence {IntegerVar} ^ self create: detector with: work with: contents with: author with: time with: sequence! !Heaper subclass: #DiskManager instanceVariableNames: ' myFluidSpace {char star} myFlockInfoTable {PrimPtrTable} myFlockTable {WeakPtrArray}' classVariableNames: 'SecretEmulsion {Emulsion star} ' poolDictionaries: '' category: 'Xanadu-Snarf'! DiskManager comment: 'This is the public interface for managing objects that should go to disk. This is also the anchor for the so-called Backend emulsion, but I''ll call it the DiskManager emulsion for simplicity.'! (DiskManager getOrMakeCxxClassDescription) friends: '/* friends for class DiskManager */ friend class Abraham; '; attributes: ((Set new) add: #DEFERRED; yourself)! !DiskManager methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will probably happen later." self subclassResponsibility! {void} diskUpdate: info {FlockInfo | NULL} "The flock described by info is Dirty!! On the next commit, rewrite it to the disk." self subclassResponsibility! {void} dismantleFlock: info {FlockInfo} "The flock designated by info has completed all dismantling actions; throw it off the disk." self subclassResponsibility! {void} dropFlock: token {Int32} "The flock identified by token is being removed from memory. For now, this is an error if the flock has been updated. If the flock has been forgotten, then it will be dismantled when next it comes in from disk." self subclassResponsibility! {void} forgetFlock: info {FlockInfo} "Remember that there are no more persistent pointers to the shepherd described by info. If it gets garbage collected, remember to dismantle it when it comes back in from the disk." self subclassResponsibility! {Turtle} getInitialFlock "Return the starting object for the entire backend. This will be the 0th flock in the first snarf following the snarfInfo tables. This will eventually always be a shepherd that describes the protocol of the rest of the disk." self subclassResponsibility! {UInt32} nextHashForEqual "Shepherds use a sequence number for their hash. The most trivial (reasonable) implementation just uses a BatchCounter. This will not be persistent till we get Turtles." self subclassResponsibility! {void} rememberFlock: info {FlockInfo} "There are now persistent pointers to the shepherd described by info. See forgetFlock." self subclassResponsibility! {void} setHashCounter: aCounter {Counter unused}! {void} storeAlmostNewShepherd: shep {Abraham} "Shep has been created, but is not consistent yet. storeNewFlock must be called on it before the next makeConsistent." self subclassResponsibility! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} "A turtle just got created!! Remember it as the initial flock." self subclassResponsibility! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." self subclassResponsibility! ! !DiskManager methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32} with: snarfID {SnarfID} with: index {Int32} "If something is already imaged at that location, then return it. If there is already an existing stub with the same hash at a different location, follow them both till we know that they are actually different objects." self subclassResponsibility! {void} makeReal: info {FlockInfo} "Retrieve from the disk the flock at index within the specified snarf. Since stubs are canonical, and this only gets called by stubs, the existing stub will *become* the shepherd for the flock." self subclassResponsibility! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} "Called to register a newly created stub (by the diskSpecialist) in the internal tables. The diskSpecialist in particular calls this when it couldn't find an already existing stub (with fetchCacnonical) representing the flock at the particular location." self subclassResponsibility! ! !DiskManager methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar} "This is called before entering consistent block. 'dirty' is the block's declaration of the maximum number of shepherds which it can dirty. If this is a top level consistent block, the virtual image in memory is now in a consistent state. It may be written to the disk if necessary. " self subclassResponsibility! {void} consistentBlockAt: fileName {char star unused} with: lineNo {Int32 unused} "This is called after beginConsistent, but before entering a consistent block, for debugging purposes. Default is to do nothing"! {void} endConsistent: dirty {IntegerVar} "This is called after exiting a consistent block." self subclassResponsibility! {BooleanVar} insideCommit self subclassResponsibility! {void} purge "Flush everything out to disk and remove all purgeable imaged objects from memory. " self subclassResponsibility! {void} purgeClean: noneLocked {BooleanVar default: false} "purge all shepherds that are currently clean, not locked, not dirty, and purgeable. Purging just turns them into stubs, freeing the rest of their flocks. Garbage collection can clean up the flocks and any stubs no longer pointed to by something in memory." self subclassResponsibility! ! !DiskManager methodsFor: 'smalltalk: passe'! {void} consistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self passe! {void} consistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self passe! {void} makeConsistent "The virtual image in memory is now in a consistent state. It may be written to the disk if necessary." self passe! {void} makeConsistentBegin: dirty {IntegerVar} "The virtual image in memory is now in a consistent state. It may be written to the disk if necessary. This is called before entering a top level consistent block. 'dirty' is the block's declaration of the maximum number of shepherds which it can dirty." self passe! {void} makeConsistentEnd "This is called after exiting a top level consistent block." self passe! ! !DiskManager methodsFor: 'testing'! {UInt32} actualHashForEqual ^Heaper takeOop! {BooleanVar} isFake self subclassResponsibility! ! !DiskManager methodsFor: 'protected: accessing'! {void INLINE} flockInfoTable: table{PrimPtrTable} myFlockInfoTable := table! {void INLINE} flockTable: table {WeakPtrArray} myFlockTable := table.! ! !DiskManager methodsFor: 'accessing'! {PrimPtrTable INLINE} flockInfoTable ^ myFlockInfoTable! {WeakPtrArray INLINE} flockTable ^ myFlockTable! ! !DiskManager methodsFor: 'protected: creation'! create super create. myFluidSpace _ NULL. myFlockInfoTable _ PrimPtrTable make: 2048. myFlockTable _ WeakPtrArray make: (Cattleman make: self) with: 2048.! {void} destruct (myFluidSpace ~~ NULL) ifTrue: [ CurrentPacker fluidBind: self during: [DiskManager emulsion destructAll]]. super destruct.! ! !DiskManager methodsFor: 'emulsion accessing'! {char star} fluidSpace ^myFluidSpace.! {char star} fluidSpace: aFluidSpace {char star} ^myFluidSpace _ aFluidSpace.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskManager class instanceVariableNames: ''! (DiskManager getOrMakeCxxClassDescription) friends: '/* friends for class DiskManager */ friend class Abraham; '; attributes: ((Set new) add: #DEFERRED; yourself)! !DiskManager class methodsFor: 'creation'! {DiskManager} initializeDisk: fname {char star} "This builds the disk managing structure." CurrentPacker fluidSet: (SnarfPacker initializeUrdiOnDisk: fname). ^CurrentPacker fluidGet! make: fname {char star} CurrentPacker fluidSet: (SnarfPacker make: fname). ^CurrentPacker fluidGet! ! !DiskManager class methodsFor: 'emulsion accessing'! {Emulsion} emulsion [SecretEmulsion == nil ifTrue: [SecretEmulsion _ NULL]] smalltalkOnly. (SecretEmulsion == NULL) ifTrue: [ SecretEmulsion _ DiskManagerEmulsion make]. ^SecretEmulsion.! ! !DiskManager class methodsFor: 'smalltalk: initialization'! {void} cleanupGarbage DiskCuisine _ NULL. SecretEmulsion _ NULL.! {void} exitTimeNonInherited CurrentPacker fluidFetch ~~ NULL ifTrue: [CurrentPacker fluidGet destroy. CurrentPacker fluidSet: NULL]! linkTimeNonInherited Recipe star defineGlobal: #DiskCuisine with: NULL. SecretEmulsion _ NULL.! staticTimeNonInherited DiskManager defineFluid: #CurrentPacker with: Emulsion globalEmulsion with: [NULL]. BooleanVar defineFluid: #InsideAgenda with: DiskManager emulsion with: [false].! ! !DiskManager class methodsFor: 'exceptions: exceptions'! bomb.ConsistentBlock: CHARGE {IntegerVar} ^[CurrentPacker fluidGet endConsistent: CHARGE]! ! !DiskManager class methodsFor: 'smalltalk: transactions'! {void} consistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." DiskManager consistent: -1 with: aBlock with: thisContext sender! {void} consistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self knownBug. "there are still unbounded consistent bugs which need to be broken up" self consistent: dirty with: aBlock with: thisContext sender! {void} consistent: dirty {IntegerVar default: -1} with: aBlock {BlockClosure} with: context {Context} | fileName {String} | CurrentPacker fluidGet beginConsistent: dirty. "(context isKindOf: MethodContext) ifTrue: [fileName _ context printString] ifFalse: [fileName _ '[] in ', context mclass name, '>>', context selector]. CurrentPacker fluidGet consistentBlockAt: fileName with: context pc." [InsideTransactionFlag fluidBind: true during: aBlock] valueNowOrOnUnwindDo: (DiskManager bomb.ConsistentBlock: dirty)! {void} insistent: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." DiskManager insistent: -1 with: aBlock with: thisContext sender! {void} insistent: dirty {IntegerVar} with: aBlock {BlockClosure} "Execute the block inside a pseudo-transaction." self insistent: dirty with: aBlock with: thisContext sender! {void} insistent: dirty {IntegerVar default: -1} with: aBlock {BlockClosure} with: context {Context} InsideTransactionFlag fluidFetch assert: 'Must be inside a transaction'. DiskManager consistent: dirty with: aBlock with: context! !DiskManager subclass: #CBlockTrackingPacker instanceVariableNames: ' myPacker {DiskManager} myTracker {CBlockTracker | NULL}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! (CBlockTrackingPacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTrackingPacker methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar} myTracker _ CBlockTracker make: dirty with: myTracker. myPacker beginConsistent: dirty! {void} consistentBlockAt: fileName {char star} with: lineNo {Int32} self checkTracker ifTrue: [myTracker track: fileName with: lineNo. myPacker consistentBlockAt: fileName with: lineNo]! {void} endConsistent: dirty {IntegerVar} self checkTracker ifTrue: [myTracker _ myTracker fetchUnwrapped. myPacker endConsistent: dirty]! {BooleanVar} insideCommit ^ myPacker insideCommit! {void} purge myPacker purge! {void} purgeClean: noneLocked {BooleanVar default: false} myPacker purgeClean: noneLocked! ! !CBlockTrackingPacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will probably happen later." myPacker destroyFlock: info! {void} diskUpdate: info {FlockInfo | NULL} self checkTracker ifTrue: [myTracker dirty: info. myPacker diskUpdate: info]! {void} dismantleFlock: info {FlockInfo} "The flock designated by info has completed all dismantling actions; throw it off the disk." myPacker dismantleFlock: info! {void} dropFlock: token {Int32} myPacker dropFlock: token! {void} forgetFlock: info {FlockInfo} self checkTracker ifTrue: [myTracker dirty: info. myPacker forgetFlock: info]! {Turtle} getInitialFlock ^myPacker getInitialFlock! {UInt32} nextHashForEqual ^myPacker nextHashForEqual! {void} rememberFlock: info {FlockInfo} self checkTracker ifTrue: [myTracker dirty: info. myPacker rememberFlock: info]! {void} storeAlmostNewShepherd: shep {Abraham} myPacker storeAlmostNewShepherd: shep! {void} storeInitialFlock: turtle {Abraham} with: protocol {XcvrMaker} with: cookbook {Cookbook} myPacker storeInitialFlock: turtle with: protocol with: cookbook! {void} storeNewFlock: shep {Abraham} self checkTracker ifTrue: [myPacker storeNewFlock: shep. myTracker dirty: shep getInfo]! ! !CBlockTrackingPacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32} with: snarfID {SnarfID} with: index {Int32} ^myPacker fetchCanonical: hash with: snarfID with: index! {void} makeReal: info {FlockInfo} myPacker makeReal: info! {void} registerStub: shep {Abraham} with: snarfID {SnarfID} with: index {Int32} myPacker registerStub: shep with: snarfID with: index! ! !CBlockTrackingPacker methodsFor: 'smalltalk: testing'! consistentCount ^myPacker consistentCount! ! !CBlockTrackingPacker methodsFor: 'create'! create: subPacker {DiskManager} super create. myPacker _ subPacker. myTracker _ NULL. self flockTable: myPacker flockTable. self flockInfoTable: myPacker flockInfoTable.! ! !CBlockTrackingPacker methodsFor: 'protected: destruction'! {void} destruct (myTracker == NULL) assert. myPacker destroy. super destruct! ! !CBlockTrackingPacker methodsFor: 'testing'! {BooleanVar} isFake ^ myPacker isFake! ! !CBlockTrackingPacker methodsFor: 'private:'! {BooleanVar} checkTracker myTracker ~~ NULL ifTrue: [^true]. [Logger] USES. ErrorLog << 'Must be inside consistent block '! {void} commitState: flag {BooleanVar} "Used by ResetCommit bomb" (myPacker cast: SnarfPacker) commitState: flag! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CBlockTrackingPacker class instanceVariableNames: ''! (CBlockTrackingPacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !CBlockTrackingPacker class methodsFor: 'creation'! {DiskManager} make: subPacker {DiskManager} ^CBlockTrackingPacker create: subPacker! !DiskManager subclass: #FakePacker instanceVariableNames: ' myTurtle {Turtle | NULL} myCount {UInt4}' classVariableNames: '' poolDictionaries: '' category: 'Xanadu-Snarf'! FakePacker comment: 'Most of the disk operations are just no-ops.'! (FakePacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FakePacker methodsFor: 'transactions'! {void} beginConsistent: dirty {IntegerVar unused}! {void} endConsistent: dirty {IntegerVar unused} | agenda {Agenda | NULL} | InsideTransactionFlag fluidFetch ifFalse: [agenda _ myTurtle fetchAgenda. (agenda ~~ NULL and: [InsideAgenda fluidFetch not]) ifTrue: [InsideAgenda fluidBind: true during: [[agenda step] whileTrue]]]! {BooleanVar} insideCommit ^ false! {void} purge "Flush everything out to disk and remove all purgeable imaged objects from memory. This doesn't clear the ShepherdMap table. This will have to be a weak table, and then the destruction of a shepherd or shepherdStub should remove it from myShepherdMap."! {void} purgeClean: noneLocked {BooleanVar unused default: false} "No shepherds are clean, so no-op."! ! !FakePacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. dismantle it immediately in the FakePacker." self knownBug. "This needs to stack shepherds for deletion after all agenda items." info markDestroyed. info getShepherd dismantle! {void} diskUpdate: info {FlockInfo | NULL} "The flock identified by token is Dirty!! On some later commit, write it to the disk."! {void} dismantleFlock: info {FlockInfo} "Tehre are no local data-structures." "info markDismantled."! {void} dropFlock: token {Int32} "No prob."! {void} forgetFlock: info {FlockInfo} "Yeah. Right."! {Turtle} getInitialFlock ^ myTurtle! {UInt32} nextHashForEqual "Shepherds use a sequence number for their hash. Return the next one and increment. This should actually spread the hashes." "This actually needs to roll over the UInt32 limit." myCount _ myCount + 1. ^ myCount! {void} rememberFlock: info {FlockInfo} "There are now persistent pointers to the shepherd represented by token."! {void} storeAlmostNewShepherd: shep {Abraham unused} "Do nothing"! {void} storeInitialFlock: turtle {Abraham unused} with: protocol {XcvrMaker unused} with: cookbook {Cookbook unused} Heaper BLAST: #MustBeRealDiskManager! {void} storeNewFlock: shep {Abraham} "Shep just got created!! On some later commit, assign it to a snarf and write it to the disk." | info {FlockInfo} | shep fetchInfo == NULL assert: 'Must not have an info yet'. "Create a FlockInfo to make the FlockTable registration happy." info _ FlockInfo make: shep with: myCount negated. shep flockInfo: info.! {void} storeTurtle: turtle {Turtle} myTurtle _ turtle! ! !FakePacker methodsFor: 'stubs'! {Abraham} fetchCanonical: hash {UInt32 unused} with: snarfID {SnarfID unused} with: index {Int32 unused} "If something is already imaged at that location, then return it. If there is already an existing stub with the same hash at a different location, follow them till we know that they are actually different objects." self unimplemented. ^NULL! {void} makeReal: info {FlockInfo unused} "Retrieve from the disk the flock at index within the specified snarf. Since stubs are canonical, and this only gets called by stubs, the existing stub will *become* the shepherd for the flock." self unimplemented! {void} registerStub: shep {Abraham unused} with: snarfID {SnarfID unused} with: index {Int32 unused} self unimplemented! ! !FakePacker methodsFor: 'protected: create'! create super create. myTurtle _ NULL. myCount _ UInt32Zero.! ! !FakePacker methodsFor: 'testing'! {BooleanVar} isFake ^ true! ! !FakePacker methodsFor: 'internals'! {void} destroyAbandoned! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FakePacker class instanceVariableNames: ''! (FakePacker getOrMakeCxxClassDescription) attributes: ((Set new) add: #CONCRETE; yourself)! !FakePacker class methodsFor: 'creation'! {DiskManager} make | packer {DiskManager} | packer _ FakePacker create. CurrentPacker fluidSet: packer. ^packer! !DiskManager subclass: #SnarfPacker instanceVariableNames: ' mySnarfInfo {SnarfInfoHandler} myTurtle {Turtle | NULL} myAllocationSnarf {SnarfID} mySnarfMap {MuTable of: IntegerPos with: SnarfRecord} myFlocks {SetTable of: IntegerPos and: FlockInfo} myNewFlocks {IntegerTable of: FlockInfo} myLastNewCount {IntegerVar} myNewEstimate {IntegerVar} myDestroyedFlocks {MuArray of: Abraham} myUrdiView {UrdiView star} myUrdi {Urdi star} myXcvrMaker {XcvrMaker} myBook {Cookbook} myNextHash {Counter} myConsistentCount {IntegerVar} myInsideCommit {BooleanVar} myDestroyCount {IntegerVar} myPurgeror {SanitationEngineer} myRepairer {LiberalPurgeror}' classVariableNames: ' DebugSizes {Collection smalltalk} LRUCount {Int32} ' poolDictionaries: '' category: 'Xanadu-Snarf'! SnarfPacker comment: 'Should myFlocks contain full flockInfos for forwarded flocks? Both the flags and the size mean nothing. A SnarfPacker maintains the relationship between Shepherds and the set of snarfs representing the disk. A SnarfPacker assigns flocks to snarfs based loosely on the flocks''s Shepherd''s preferences. When a flock changes, it informs the SnarfPacker. When the SnarfPacker decides to write to the disk, it ensures that the changed objects still fit in their snarf (migrating them if necessary), writes them to the snarf, then writes out the snarf. mySnarfInfo {MuTable of: XuInteger} - How much space remains in each snarf. mySnarfMap {MuTable of: SnarfRecord} - Map from snarfIDs to a SnarfRecord that handles that snarf. myChangedSnarfs {MuSet of: XuInteger} - The IDs for all snarfs in which an imaged flock has changed. myFlocks {SetTable of: XuInteger and: FlockInfo} - Indexed by Abraham hash, contains all FlockInfos that refer to flocks in memory. Multiple infos may refer to the same flock if it is referenced through forwarding. The only info considered to have the correct state wrt its flocks suitability for purging is the info pointed to by its Abraham. myInsideCommit {BooleanVar} - True while writing new and changed flocks to disk to prevent purging, and during purgeClean to prevent recursive call through Purgeror recycling.'! (SnarfPacker getOrMakeCxxClassDescription) friends: 'friend class ResetCommit_Bomb; friend class CBlockTrackingPacker;'; attributes: ((Set new) add: #CONCRETE; yourself)! !SnarfPacker methodsFor: 'shepherds'! {void} destroyFlock: info {FlockInfo} "Queue destroy of the given flock. The destroy will happen later." | flock {Abraham} | flock _ info getShepherd. (Heaper isDestructed: flock) ifTrue: [Heaper BLAST: #DestructedAbe]. info markDestroyed. info markForgotten ifTrue: [self recordUpdate: info]. info isNew ifTrue: [flock _ flock "just so I can set a breakpoint"] ifFalse: [mySnarfInfo setForgottenFlag: info snarfID with: true]. myDestroyedFlocks atInt: myDestroyedFlocks count introduce: flock! {void} diskUpdate: info {FlockInfo | NULL} InsideTransactionFlag fluidFetch assert: 'Must be inside transation'. "noop for unregistered flocks." info == NULL ifTrue: [^VOID]. info markContentsDirty ifTrue: [self recordUpdate: info].! {void} dismantleFlock: info {FlockInfo} "Turn the flock designated by info into a Pumpkin. It should have completed all dismantle actions." info markDismantled. info isNew ifFalse: [self thingToDo. "Go remove this from all the forwarded locations as well." (self getSnarfRecord: info snarfID) dismantleFlock: info].! {void} dropFlock: token {Int32} "The flock is being removed from memory. For now, this is an error if the flock has been updated. If the flock has been forgotten, then it will be dismantled when next it comes in from disk. Because of forwarding, there may be many FlockInfos refering to the flock if it is not new." | info {FlockInfo} | info := FlockInfo getInfo: token. (info isNew or: [info isForwarded]) ifTrue: [myNewFlocks intRemove: info index]. info isNew ifFalse: [info isForgotten ifFalse: [Heaper BLAST: #OnlyRemoveUnchangedFlocks]. (myFlocks stepperAtInt: info flockHash) forEach: [:oi {FlockInfo} | oi token == token ifTrue: [myFlocks wipe.IntegerVar: info flockHash with: oi]]]. FlockInfo removeInfo: token! {void} forgetFlock: info {FlockInfo} "Remember that there are no more persistent pointers to the shepherd represented by info. If it gets manually deleted, dismantle it immediately. If it gets garbage collected, remember to dismantle it when it comes back in from the disk." InsideTransactionFlag fluidFetch assert: 'Must be inside transation'. info markForgotten ifTrue: [self recordUpdate: info]. mySnarfInfo setForgottenFlag: info snarfID with: true. self thingToDo. "Don't rewrite the entire flock if it has only been forgotten."! {Turtle} getInitialFlock "Return the starting object for the entire backend. This will be the 0th flock in the first snarf following the snarfInfo tables." | handler {SnarfHandler} stream {XnReadStream} rcvr {Rcvr} protocol {char star} cookbook {char star} agend