'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